1c 2c 3c ################################################## 4c ## COPYRIGHT (C) 2015 by Jay William Ponder ## 5c ## All Rights Reserved ## 6c ################################################## 7c 8c ############################################################ 9c ## ## 10c ## subroutine epolar1 -- polarization energy & derivs ## 11c ## ## 12c ############################################################ 13c 14c 15c "epolar1" calculates the induced dipole polarization energy 16c and first derivatives with respect to Cartesian coordinates 17c 18c 19 subroutine epolar1 20 use iounit 21 use limits 22 use mplpot 23 use polpot 24 implicit none 25c 26c 27c check for use of TCG polarization with charge penetration 28c 29 if (poltyp.eq.'TCG' .and. use_chgpen) then 30 write (iout,10) 31 10 format (/,' EPOLAR1 -- TCG Polarization not Available', 32 & ' with Charge Penetration') 33 call fatal 34 end if 35c 36c choose the method for summing over polarization interactions 37c 38 if (use_ewald) then 39 if (use_mlist) then 40 call epolar1d 41 else 42 call epolar1c 43 end if 44 else 45 if (use_mlist) then 46 call epolar1b 47 else 48 call epolar1a 49 end if 50 end if 51 return 52 end 53c 54c 55c ################################################################ 56c ## ## 57c ## subroutine epolar1a -- double loop polarization derivs ## 58c ## ## 59c ################################################################ 60c 61c 62c "epolar1a" calculates the dipole polarization energy and 63c derivatives with respect to Cartesian coordinates using a 64c pairwise double loop 65c 66c 67 subroutine epolar1a 68 use atoms 69 use bound 70 use cell 71 use chgpen 72 use chgpot 73 use couple 74 use deriv 75 use energi 76 use molcul 77 use mplpot 78 use mpole 79 use polar 80 use polgrp 81 use polopt 82 use polpot 83 use poltcg 84 use potent 85 use shunt 86 use virial 87 implicit none 88 integer i,j,k,m 89 integer ii,kk,jcell 90 integer ix,iy,iz 91 real*8 f,pgamma 92 real*8 pdi,pti,ddi 93 real*8 damp,expdamp 94 real*8 temp3,temp5,temp7 95 real*8 sc3,sc5,sc7 96 real*8 sr3,sr5,sr7 97 real*8 psr3,psr5,psr7 98 real*8 dsr3,dsr5,dsr7 99 real*8 dsr3i,dsr5i,dsr7i 100 real*8 dsr3k,dsr5k,dsr7k 101 real*8 xi,yi,zi 102 real*8 xr,yr,zr 103 real*8 r,r2,rr1,rr3 104 real*8 rr5,rr7,rr9 105 real*8 ci,dix,diy,diz 106 real*8 qixx,qixy,qixz 107 real*8 qiyy,qiyz,qizz 108 real*8 uix,uiy,uiz 109 real*8 uixp,uiyp,uizp 110 real*8 ck,dkx,dky,dkz 111 real*8 qkxx,qkxy,qkxz 112 real*8 qkyy,qkyz,qkzz 113 real*8 ukx,uky,ukz 114 real*8 ukxp,ukyp,ukzp 115 real*8 dir,uir,uirp 116 real*8 dkr,ukr,ukrp 117 real*8 qix,qiy,qiz,qir 118 real*8 qkx,qky,qkz,qkr 119 real*8 corei,corek 120 real*8 vali,valk 121 real*8 alphai,alphak 122 real*8 uirm,ukrm 123 real*8 uirt,ukrt 124 real*8 tuir,tukr 125 real*8 tixx,tiyy,tizz 126 real*8 tixy,tixz,tiyz 127 real*8 tkxx,tkyy,tkzz 128 real*8 tkxy,tkxz,tkyz 129 real*8 tix3,tiy3,tiz3 130 real*8 tix5,tiy5,tiz5 131 real*8 tkx3,tky3,tkz3 132 real*8 tkx5,tky5,tkz5 133 real*8 term1,term2,term3 134 real*8 term4,term5,term6 135 real*8 term7,term8 136 real*8 term1core 137 real*8 term1i,term2i,term3i 138 real*8 term4i,term5i,term6i 139 real*8 term7i,term8i 140 real*8 term1k,term2k,term3k 141 real*8 term4k,term5k,term6k 142 real*8 term7k,term8k 143 real*8 poti,potk 144 real*8 depx,depy,depz 145 real*8 frcx,frcy,frcz 146 real*8 xix,yix,zix 147 real*8 xiy,yiy,ziy 148 real*8 xiz,yiz,ziz 149 real*8 vxx,vyy,vzz 150 real*8 vxy,vxz,vyz 151 real*8 rc3(3),rc5(3),rc7(3) 152 real*8 tep(3),fix(3) 153 real*8 fiy(3),fiz(3) 154 real*8 uax(3),uay(3),uaz(3) 155 real*8 ubx(3),uby(3),ubz(3) 156 real*8 uaxp(3),uayp(3),uazp(3) 157 real*8 ubxp(3),ubyp(3),ubzp(3) 158 real*8 dmpi(9),dmpk(9) 159 real*8 dmpik(9) 160 real*8, allocatable :: pscale(:) 161 real*8, allocatable :: dscale(:) 162 real*8, allocatable :: uscale(:) 163 real*8, allocatable :: wscale(:) 164 real*8, allocatable :: ufld(:,:) 165 real*8, allocatable :: dufld(:,:) 166 real*8, allocatable :: pot(:) 167 real*8, allocatable :: decfx(:) 168 real*8, allocatable :: decfy(:) 169 real*8, allocatable :: decfz(:) 170 character*6 mode 171c 172c 173c zero out the polarization energy and derivatives 174c 175 ep = 0.0d0 176 do i = 1, n 177 do j = 1, 3 178 dep(j,i) = 0.0d0 179 end do 180 end do 181 if (npole .eq. 0) return 182c 183c check the sign of multipole components at chiral sites 184c 185 if (.not. use_mpole) call chkpole 186c 187c rotate the multipole components into the global frame 188c 189 if (.not. use_mpole) call rotpole 190c 191c compute the induced dipoles at each polarizable atom 192c 193 call induce 194c 195c compute the total induced dipole polarization energy 196c 197 call epolar1e 198c 199c perform dynamic allocation of some local arrays 200c 201 allocate (pscale(n)) 202 allocate (dscale(n)) 203 allocate (uscale(n)) 204 allocate (wscale(n)) 205 allocate (ufld(3,n)) 206 allocate (dufld(6,n)) 207 allocate (pot(n)) 208 allocate (decfx(n)) 209 allocate (decfy(n)) 210 allocate (decfz(n)) 211c 212c set exclusion coefficients and arrays to store fields 213c 214 do i = 1, n 215 pscale(i) = 1.0d0 216 dscale(i) = 1.0d0 217 uscale(i) = 1.0d0 218 wscale(i) = 1.0d0 219 do j = 1, 3 220 ufld(j,i) = 0.0d0 221 end do 222 do j = 1, 6 223 dufld(j,i) = 0.0d0 224 end do 225 pot(i) = 0.0d0 226 end do 227c 228c set conversion factor, cutoff and switching coefficients 229c 230 f = 0.5d0 * electric / dielec 231 mode = 'MPOLE' 232 call switch (mode) 233c 234c compute the dipole polarization gradient components 235c 236 do ii = 1, npole-1 237 i = ipole(ii) 238 xi = x(i) 239 yi = y(i) 240 zi = z(i) 241 ci = rpole(1,ii) 242 dix = rpole(2,ii) 243 diy = rpole(3,ii) 244 diz = rpole(4,ii) 245 qixx = rpole(5,ii) 246 qixy = rpole(6,ii) 247 qixz = rpole(7,ii) 248 qiyy = rpole(9,ii) 249 qiyz = rpole(10,ii) 250 qizz = rpole(13,ii) 251 uix = uind(1,ii) 252 uiy = uind(2,ii) 253 uiz = uind(3,ii) 254 uixp = uinp(1,ii) 255 uiyp = uinp(2,ii) 256 uizp = uinp(3,ii) 257 do j = 1, tcgnab 258 uax(j) = uad(1,ii,j) 259 uay(j) = uad(2,ii,j) 260 uaz(j) = uad(3,ii,j) 261 uaxp(j) = uap(1,ii,j) 262 uayp(j) = uap(2,ii,j) 263 uazp(j) = uap(3,ii,j) 264 ubx(j) = ubd(1,ii,j) 265 uby(j) = ubd(2,ii,j) 266 ubz(j) = ubd(3,ii,j) 267 ubxp(j) = ubp(1,ii,j) 268 ubyp(j) = ubp(2,ii,j) 269 ubzp(j) = ubp(3,ii,j) 270 end do 271 if (use_thole) then 272 pdi = pdamp(ii) 273 pti = thole(ii) 274 ddi = dirdamp(ii) 275 else if (use_chgpen) then 276 corei = pcore(ii) 277 vali = pval(ii) 278 alphai = palpha(ii) 279 end if 280c 281c set exclusion coefficients for connected atoms 282c 283 if (dpequal) then 284 do j = 1, n12(i) 285 pscale(i12(j,i)) = p2scale 286 do k = 1, np11(i) 287 if (i12(j,i) .eq. ip11(k,i)) 288 & pscale(i12(j,i)) = p2iscale 289 end do 290 dscale(i12(j,i)) = pscale(i12(j,i)) 291 wscale(i12(j,i)) = w2scale 292 end do 293 do j = 1, n13(i) 294 pscale(i13(j,i)) = p3scale 295 do k = 1, np11(i) 296 if (i13(j,i) .eq. ip11(k,i)) 297 & pscale(i13(j,i)) = p3iscale 298 end do 299 dscale(i13(j,i)) = pscale(i13(j,i)) 300 wscale(i13(j,i)) = w3scale 301 end do 302 do j = 1, n14(i) 303 pscale(i14(j,i)) = p4scale 304 do k = 1, np11(i) 305 if (i14(j,i) .eq. ip11(k,i)) 306 & pscale(i14(j,i)) = p4iscale 307 end do 308 dscale(i14(j,i)) = pscale(i14(j,i)) 309 wscale(i14(j,i)) = w4scale 310 end do 311 do j = 1, n15(i) 312 pscale(i15(j,i)) = p5scale 313 do k = 1, np11(i) 314 if (i15(j,i) .eq. ip11(k,i)) 315 & pscale(i15(j,i)) = p5iscale 316 end do 317 dscale(i15(j,i)) = pscale(i15(j,i)) 318 wscale(i15(j,i)) = w5scale 319 end do 320 do j = 1, np11(i) 321 uscale(ip11(j,i)) = u1scale 322 end do 323 do j = 1, np12(i) 324 uscale(ip12(j,i)) = u2scale 325 end do 326 do j = 1, np13(i) 327 uscale(ip13(j,i)) = u3scale 328 end do 329 do j = 1, np14(i) 330 uscale(ip14(j,i)) = u4scale 331 end do 332 else 333 do j = 1, n12(i) 334 pscale(i12(j,i)) = p2scale 335 do k = 1, np11(i) 336 if (i12(j,i) .eq. ip11(k,i)) 337 & pscale(i12(j,i)) = p2iscale 338 end do 339 wscale(i12(j,i)) = w2scale 340 end do 341 do j = 1, n13(i) 342 pscale(i13(j,i)) = p3scale 343 do k = 1, np11(i) 344 if (i13(j,i) .eq. ip11(k,i)) 345 & pscale(i13(j,i)) = p3iscale 346 end do 347 wscale(i13(j,i)) = w3scale 348 end do 349 do j = 1, n14(i) 350 pscale(i14(j,i)) = p4scale 351 do k = 1, np11(i) 352 if (i14(j,i) .eq. ip11(k,i)) 353 & pscale(i14(j,i)) = p4iscale 354 end do 355 wscale(i14(j,i)) = w4scale 356 end do 357 do j = 1, n15(i) 358 pscale(i15(j,i)) = p5scale 359 do k = 1, np11(i) 360 if (i15(j,i) .eq. ip11(k,i)) 361 & pscale(i15(j,i)) = p5iscale 362 end do 363 wscale(i15(j,i)) = w5scale 364 end do 365 do j = 1, np11(i) 366 dscale(ip11(j,i)) = d1scale 367 uscale(ip11(j,i)) = u1scale 368 end do 369 do j = 1, np12(i) 370 dscale(ip12(j,i)) = d2scale 371 uscale(ip12(j,i)) = u2scale 372 end do 373 do j = 1, np13(i) 374 dscale(ip13(j,i)) = d3scale 375 uscale(ip13(j,i)) = u3scale 376 end do 377 do j = 1, np14(i) 378 dscale(ip14(j,i)) = d4scale 379 uscale(ip14(j,i)) = u4scale 380 end do 381 end if 382c 383c evaluate all sites within the cutoff distance 384c 385 do kk = ii+1, npole 386 k = ipole(kk) 387 xr = x(k) - xi 388 yr = y(k) - yi 389 zr = z(k) - zi 390 if (use_bounds) call image (xr,yr,zr) 391 r2 = xr*xr + yr*yr + zr*zr 392 if (r2 .le. off2) then 393 r = sqrt(r2) 394 ck = rpole(1,kk) 395 dkx = rpole(2,kk) 396 dky = rpole(3,kk) 397 dkz = rpole(4,kk) 398 qkxx = rpole(5,kk) 399 qkxy = rpole(6,kk) 400 qkxz = rpole(7,kk) 401 qkyy = rpole(9,kk) 402 qkyz = rpole(10,kk) 403 qkzz = rpole(13,kk) 404 ukx = uind(1,kk) 405 uky = uind(2,kk) 406 ukz = uind(3,kk) 407 ukxp = uinp(1,kk) 408 ukyp = uinp(2,kk) 409 ukzp = uinp(3,kk) 410c 411c intermediates involving moments and separation distance 412c 413 dir = dix*xr + diy*yr + diz*zr 414 qix = qixx*xr + qixy*yr + qixz*zr 415 qiy = qixy*xr + qiyy*yr + qiyz*zr 416 qiz = qixz*xr + qiyz*yr + qizz*zr 417 qir = qix*xr + qiy*yr + qiz*zr 418 dkr = dkx*xr + dky*yr + dkz*zr 419 qkx = qkxx*xr + qkxy*yr + qkxz*zr 420 qky = qkxy*xr + qkyy*yr + qkyz*zr 421 qkz = qkxz*xr + qkyz*yr + qkzz*zr 422 qkr = qkx*xr + qky*yr + qkz*zr 423 uir = uix*xr + uiy*yr + uiz*zr 424 uirp = uixp*xr + uiyp*yr + uizp*zr 425 ukr = ukx*xr + uky*yr + ukz*zr 426 ukrp = ukxp*xr + ukyp*yr + ukzp*zr 427c 428c get reciprocal distance terms for this interaction 429c 430 rr1 = f / r 431 rr3 = rr1 / r2 432 rr5 = 3.0d0 * rr3 / r2 433 rr7 = 5.0d0 * rr5 / r2 434 rr9 = 7.0d0 * rr7 / r2 435c 436c set initial values for tha damping scale factors 437c 438 sc3 = 1.0d0 439 sc5 = 1.0d0 440 sc7 = 1.0d0 441 do j = 1, 3 442 rc3(j) = 0.0d0 443 rc5(j) = 0.0d0 444 rc7(j) = 0.0d0 445 end do 446c 447c apply Thole polarization damping to scale factors 448c 449 if (use_thole) then 450 damp = pdi * pdamp(kk) 451 if (use_dirdamp) then 452 pgamma = min(ddi,dirdamp(kk)) 453 if (pgamma .eq. 0.0d0) then 454 pgamma = max(ddi,dirdamp(kk)) 455 end if 456 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 457 damp = pgamma * (r/damp)**(1.5d0) 458 if (damp .lt. 50.0d0) then 459 expdamp = exp(-damp) 460 sc3 = 1.0d0 - expdamp 461 sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp) 462 sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp 463 & +0.15d0*damp**2) 464 temp3 = 0.5d0 * damp * expdamp 465 temp5 = 1.5d0 * (1.0d0+damp) 466 temp7 = 5.0d0*(1.5d0*damp*expdamp 467 & *(0.35d0+0.35d0*damp 468 & +0.15d0*damp**2))/(temp3*temp5) 469 temp3 = temp3 * rr5 470 temp5 = temp5 / r2 471 temp7 = temp7 / r2 472 rc3(1) = xr * temp3 473 rc3(2) = yr * temp3 474 rc3(3) = zr * temp3 475 rc5(1) = rc3(1) * temp5 476 rc5(2) = rc3(2) * temp5 477 rc5(3) = rc3(3) * temp5 478 rc7(1) = rc5(1) * temp7 479 rc7(2) = rc5(2) * temp7 480 rc7(3) = rc5(3) * temp7 481 end if 482 end if 483 else 484 pgamma = min(pti,thole(kk)) 485 if (pgamma .eq. 0.0d0) then 486 pgamma = max(pti,thole(kk)) 487 end if 488 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 489 damp = pgamma * (r/damp)**3 490 if (damp .lt. 50.0d0) then 491 expdamp = exp(-damp) 492 sc3 = 1.0d0 - expdamp 493 sc5 = 1.0d0 - expdamp*(1.0d0+damp) 494 sc7 = 1.0d0 - expdamp*(1.0d0+damp 495 & +0.6d0*damp**2) 496 temp3 = damp * expdamp * rr5 497 temp5 = 3.0d0 * damp / r2 498 temp7 = (-1.0d0+3.0d0*damp) / r2 499 rc3(1) = xr * temp3 500 rc3(2) = yr * temp3 501 rc3(3) = zr * temp3 502 rc5(1) = rc3(1) * temp5 503 rc5(2) = rc3(2) * temp5 504 rc5(3) = rc3(3) * temp5 505 rc7(1) = rc5(1) * temp7 506 rc7(2) = rc5(2) * temp7 507 rc7(3) = rc5(3) * temp7 508 end if 509 end if 510 end if 511 sr3 = rr3 * sc3 512 sr5 = rr5 * sc5 513 sr7 = rr7 * sc7 514 dsr3 = sr3 * dscale(k) 515 dsr5 = sr5 * dscale(k) 516 dsr7 = sr7 * dscale(k) 517 psr3 = sr3 * pscale(k) 518 psr5 = sr5 * pscale(k) 519 psr7 = sr7 * pscale(k) 520c 521c apply charge penetration damping to scale factors 522c 523 else if (use_chgpen) then 524 corek = pcore(kk) 525 valk = pval(kk) 526 alphak = palpha(kk) 527 call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik) 528 dsr3i = 2.0d0 * rr3 * dmpi(3) * dscale(k) 529 dsr5i = 2.0d0 * rr5 * dmpi(5) * dscale(k) 530 dsr7i = 2.0d0 * rr7 * dmpi(7) * dscale(k) 531 dsr3k = 2.0d0 * rr3 * dmpk(3) * dscale(k) 532 dsr5k = 2.0d0 * rr5 * dmpk(5) * dscale(k) 533 dsr7k = 2.0d0 * rr7 * dmpk(7) * dscale(k) 534 end if 535c 536c store the potential at each site for use in charge flux 537c 538 if (use_chgflx) then 539 if (use_thole) then 540 poti = -ukr*psr3 - ukrp*dsr3 541 potk = uir*psr3 + uirp*dsr3 542 else if (use_chgpen) then 543 poti = -ukr * dsr3i 544 potk = uir * dsr3k 545 end if 546 pot(i) = pot(i) + poti 547 pot(k) = pot(k) + potk 548 end if 549c 550c get the induced dipole field used for dipole torques 551c 552 if (use_thole) then 553 tix3 = psr3*ukx + dsr3*ukxp 554 tiy3 = psr3*uky + dsr3*ukyp 555 tiz3 = psr3*ukz + dsr3*ukzp 556 tkx3 = psr3*uix + dsr3*uixp 557 tky3 = psr3*uiy + dsr3*uiyp 558 tkz3 = psr3*uiz + dsr3*uizp 559 tuir = -psr5*ukr - dsr5*ukrp 560 tukr = -psr5*uir - dsr5*uirp 561 else if (use_chgpen) then 562 tix3 = dsr3i*ukx 563 tiy3 = dsr3i*uky 564 tiz3 = dsr3i*ukz 565 tkx3 = dsr3k*uix 566 tky3 = dsr3k*uiy 567 tkz3 = dsr3k*uiz 568 tuir = -dsr5i*ukr 569 tukr = -dsr5k*uir 570 end if 571 ufld(1,i) = ufld(1,i) + tix3 + xr*tuir 572 ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir 573 ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir 574 ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr 575 ufld(2,k) = ufld(2,k) + tky3 + yr*tukr 576 ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr 577c 578c get induced dipole field gradient used for quadrupole torques 579c 580 if (use_thole) then 581 tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp) 582 tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp) 583 tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp) 584 tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp) 585 tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp) 586 tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp) 587 tuir = -psr7*ukr - dsr7*ukrp 588 tukr = -psr7*uir - dsr7*uirp 589 else if (use_chgpen) then 590 tix5 = 2.0d0 * (dsr5i*ukx) 591 tiy5 = 2.0d0 * (dsr5i*uky) 592 tiz5 = 2.0d0 * (dsr5i*ukz) 593 tkx5 = 2.0d0 * (dsr5k*uix) 594 tky5 = 2.0d0 * (dsr5k*uiy) 595 tkz5 = 2.0d0 * (dsr5k*uiz) 596 tuir = -dsr7i*ukr 597 tukr = -dsr7k*uir 598 end if 599 dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir 600 dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5 601 & + 2.0d0*xr*yr*tuir 602 dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir 603 dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5 604 & + 2.0d0*xr*zr*tuir 605 dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5 606 & + 2.0d0*yr*zr*tuir 607 dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir 608 dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr 609 dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5 610 & - 2.0d0*xr*yr*tukr 611 dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr 612 dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5 613 & - 2.0d0*xr*zr*tukr 614 dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5 615 & - 2.0d0*yr*zr*tukr 616 dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr 617c 618c get the field gradient for direct polarization force 619c 620 if (use_thole) then 621 term1 = sc3*(rr3-rr5*xr*xr) + rc3(1)*xr 622 term2 = (sc3+sc5)*rr5*xr - rc3(1) 623 term3 = sc5*(rr7*xr*xr-rr5) - rc5(1)*xr 624 term4 = 2.0d0 * sc5 * rr5 625 term5 = 2.0d0 * (sc5*rr7*xr-rc5(1)+1.5d0*sc7*rr7*xr) 626 term6 = xr * (sc7*rr9*xr-rc7(1)) 627 tixx = ci*term1 + dix*term2 - dir*term3 628 & - qixx*term4 + qix*term5 - qir*term6 629 & + (qiy*yr+qiz*zr)*sc7*rr7 630 tkxx = ck*term1 - dkx*term2 + dkr*term3 631 & - qkxx*term4 + qkx*term5 - qkr*term6 632 & + (qky*yr+qkz*zr)*sc7*rr7 633 term1 = sc3*(rr3-rr5*yr*yr) + rc3(2)*yr 634 term2 = (sc3+sc5)*rr5*yr - rc3(2) 635 term3 = sc5*(rr7*yr*yr-rr5) - rc5(2)*yr 636 term4 = 2.0d0 * sc5 * rr5 637 term5 = 2.0d0 * (sc5*rr7*yr-rc5(2)+1.5d0*sc7*rr7*yr) 638 term6 = yr * (sc7*rr9*yr-rc7(2)) 639 tiyy = ci*term1 + diy*term2 - dir*term3 640 & - qiyy*term4 + qiy*term5 - qir*term6 641 & + (qix*xr+qiz*zr)*sc7*rr7 642 tkyy = ck*term1 - dky*term2 + dkr*term3 643 & - qkyy*term4 + qky*term5 - qkr*term6 644 & + (qkx*xr+qkz*zr)*sc7*rr7 645 term1 = sc3*(rr3-rr5*zr*zr) + rc3(3)*zr 646 term2 = (sc3+sc5)*rr5*zr - rc3(3) 647 term3 = sc5*(rr7*zr*zr-rr5) - rc5(3)*zr 648 term4 = 2.0d0 * sc5 * rr5 649 term5 = 2.0d0 * (sc5*rr7*zr-rc5(3)+1.5d0*sc7*rr7*zr) 650 term6 = zr * (sc7*rr9*zr-rc7(3)) 651 tizz = ci*term1 + diz*term2 - dir*term3 652 & - qizz*term4 + qiz*term5 - qir*term6 653 & + (qix*xr+qiy*yr)*sc7*rr7 654 tkzz = ck*term1 - dkz*term2 + dkr*term3 655 & - qkzz*term4 + qkz*term5 - qkr*term6 656 & + (qkx*xr+qky*yr)*sc7*rr7 657 term2 = sc3*rr5*xr - rc3(1) 658 term1 = yr * term2 659 term3 = sc5 * rr5 * yr 660 term4 = yr * (sc5*rr7*xr-rc5(1)) 661 term5 = 2.0d0 * sc5 * rr5 662 term6 = 2.0d0 * (sc5*rr7*xr-rc5(1)) 663 term7 = 2.0d0 * sc7 * rr7 * yr 664 term8 = yr * (sc7*rr9*xr-rc7(1)) 665 tixy = -ci*term1 + diy*term2 + dix*term3 666 & - dir*term4 - qixy*term5 + qiy*term6 667 & + qix*term7 - qir*term8 668 tkxy = -ck*term1 - dky*term2 - dkx*term3 669 & + dkr*term4 - qkxy*term5 + qky*term6 670 & + qkx*term7 - qkr*term8 671 term2 = sc3*rr5*xr - rc3(1) 672 term1 = zr * term2 673 term3 = sc5 * rr5 * zr 674 term4 = zr * (sc5*rr7*xr-rc5(1)) 675 term5 = 2.0d0 * sc5 * rr5 676 term6 = 2.0d0 * (sc5*rr7*xr-rc5(1)) 677 term7 = 2.0d0 * sc7 * rr7 * zr 678 term8 = zr * (sc7*rr9*xr-rc7(1)) 679 tixz = -ci*term1 + diz*term2 + dix*term3 680 & - dir*term4 - qixz*term5 + qiz*term6 681 & + qix*term7 - qir*term8 682 tkxz = -ck*term1 - dkz*term2 - dkx*term3 683 & + dkr*term4 - qkxz*term5 + qkz*term6 684 & + qkx*term7 - qkr*term8 685 term2 = sc3*rr5*yr - rc3(2) 686 term1 = zr * term2 687 term3 = sc5 * rr5 * zr 688 term4 = zr * (sc5*rr7*yr-rc5(2)) 689 term5 = 2.0d0 * sc5 * rr5 690 term6 = 2.0d0 * (sc5*rr7*yr-rc5(2)) 691 term7 = 2.0d0 * sc7 * rr7 * zr 692 term8 = zr * (sc7*rr9*yr-rc7(2)) 693 tiyz = -ci*term1 + diz*term2 + diy*term3 694 & - dir*term4 - qiyz*term5 + qiz*term6 695 & + qiy*term7 - qir*term8 696 tkyz = -ck*term1 - dkz*term2 - dky*term3 697 & + dkr*term4 - qkyz*term5 + qkz*term6 698 & + qky*term7 - qkr*term8 699c 700c get the field gradient for direct polarization force 701c 702 else if (use_chgpen) then 703 term1i = rr3*dmpi(3) - rr5*dmpi(5)*xr*xr 704 term1core = rr3 - rr5*xr*xr 705 term2i = 2.0d0*rr5*dmpi(5)*xr 706 term3i = rr7*dmpi(7)*xr*xr - rr5*dmpi(5) 707 term4i = 2.0d0*rr5*dmpi(5) 708 term5i = 5.0d0*rr7*dmpi(7)*xr 709 term6i = rr9*dmpi(9)*xr*xr 710 term1k = rr3*dmpk(3) - rr5*dmpk(5)*xr*xr 711 term2k = 2.0d0*rr5*dmpk(5)*xr 712 term3k = rr7*dmpk(7)*xr*xr - rr5*dmpk(5) 713 term4k = 2.0d0*rr5*dmpk(5) 714 term5k = 5.0d0*rr7*dmpk(7)*xr 715 term6k = rr9*dmpk(9)*xr*xr 716 tixx = vali*term1i + corei*term1core 717 & + dix*term2i - dir*term3i 718 & - qixx*term4i + qix*term5i - qir*term6i 719 & + (qiy*yr+qiz*zr)*rr7*dmpi(7) 720 tkxx = valk*term1k + corek*term1core 721 & - dkx*term2k + dkr*term3k 722 & - qkxx*term4k + qkx*term5k - qkr*term6k 723 & + (qky*yr+qkz*zr)*rr7*dmpk(7) 724 term1i = rr3*dmpi(3) - rr5*dmpi(5)*yr*yr 725 term1core = rr3 - rr5*yr*yr 726 term2i = 2.0d0*rr5*dmpi(5)*yr 727 term3i = rr7*dmpi(7)*yr*yr - rr5*dmpi(5) 728 term4i = 2.0d0*rr5*dmpi(5) 729 term5i = 5.0d0*rr7*dmpi(7)*yr 730 term6i = rr9*dmpi(9)*yr*yr 731 term1k = rr3*dmpk(3) - rr5*dmpk(5)*yr*yr 732 term2k = 2.0d0*rr5*dmpk(5)*yr 733 term3k = rr7*dmpk(7)*yr*yr - rr5*dmpk(5) 734 term4k = 2.0d0*rr5*dmpk(5) 735 term5k = 5.0d0*rr7*dmpk(7)*yr 736 term6k = rr9*dmpk(9)*yr*yr 737 tiyy = vali*term1i + corei*term1core 738 & + diy*term2i - dir*term3i 739 & - qiyy*term4i + qiy*term5i - qir*term6i 740 & + (qix*xr+qiz*zr)*rr7*dmpi(7) 741 tkyy = valk*term1k + corek*term1core 742 & - dky*term2k + dkr*term3k 743 & - qkyy*term4k + qky*term5k - qkr*term6k 744 & + (qkx*xr+qkz*zr)*rr7*dmpk(7) 745 term1i = rr3*dmpi(3) - rr5*dmpi(5)*zr*zr 746 term1core = rr3 - rr5*zr*zr 747 term2i = 2.0d0*rr5*dmpi(5)*zr 748 term3i = rr7*dmpi(7)*zr*zr - rr5*dmpi(5) 749 term4i = 2.0d0*rr5*dmpi(5) 750 term5i = 5.0d0*rr7*dmpi(7)*zr 751 term6i = rr9*dmpi(9)*zr*zr 752 term1k = rr3*dmpk(3) - rr5*dmpk(5)*zr*zr 753 term2k = 2.0d0*rr5*dmpk(5)*zr 754 term3k = rr7*dmpk(7)*zr*zr - rr5*dmpk(5) 755 term4k = 2.0d0*rr5*dmpk(5) 756 term5k = 5.0d0*rr7*dmpk(7)*zr 757 term6k = rr9*dmpk(9)*zr*zr 758 tizz = vali*term1i + corei*term1core 759 & + diz*term2i - dir*term3i 760 & - qizz*term4i + qiz*term5i - qir*term6i 761 & + (qix*xr+qiy*yr)*rr7*dmpi(7) 762 tkzz = valk*term1k + corek*term1core 763 & - dkz*term2k + dkr*term3k 764 & - qkzz*term4k + qkz*term5k - qkr*term6k 765 & + (qkx*xr+qky*yr)*rr7*dmpk(7) 766 term2i = rr5*dmpi(5)*xr 767 term1i = yr * term2i 768 term1core = rr5*xr*yr 769 term3i = rr5*dmpi(5)*yr 770 term4i = yr * (rr7*dmpi(7)*xr) 771 term5i = 2.0d0*rr5*dmpi(5) 772 term6i = 2.0d0*rr7*dmpi(7)*xr 773 term7i = 2.0d0*rr7*dmpi(7)*yr 774 term8i = yr*rr9*dmpi(9)*xr 775 term2k = rr5*dmpk(5)*xr 776 term1k = yr * term2k 777 term3k = rr5*dmpk(5)*yr 778 term4k = yr * (rr7*dmpk(7)*xr) 779 term5k = 2.0d0*rr5*dmpk(5) 780 term6k = 2.0d0*rr7*dmpk(7)*xr 781 term7k = 2.0d0*rr7*dmpk(7)*yr 782 term8k = yr*rr9*dmpk(9)*xr 783 tixy = -vali*term1i - corei*term1core 784 & + diy*term2i + dix*term3i 785 & - dir*term4i - qixy*term5i + qiy*term6i 786 & + qix*term7i - qir*term8i 787 tkxy = -valk*term1k - corek*term1core 788 & - dky*term2k - dkx*term3k 789 & + dkr*term4k - qkxy*term5k + qky*term6k 790 & + qkx*term7k - qkr*term8k 791 term2i = rr5*dmpi(5)*xr 792 term1i = zr * term2i 793 term1core = rr5*xr*zr 794 term3i = rr5*dmpi(5)*zr 795 term4i = zr * (rr7*dmpi(7)*xr) 796 term5i = 2.0d0*rr5*dmpi(5) 797 term6i = 2.0d0*rr7*dmpi(7)*xr 798 term7i = 2.0d0*rr7*dmpi(7)*zr 799 term8i = zr*rr9*dmpi(9)*xr 800 term2k = rr5*dmpk(5)*xr 801 term1k = zr * term2k 802 term3k = rr5*dmpk(5)*zr 803 term4k = zr * (rr7*dmpk(7)*xr) 804 term5k = 2.0d0*rr5*dmpk(5) 805 term6k = 2.0d0*rr7*dmpk(7)*xr 806 term7k = 2.0d0*rr7*dmpk(7)*zr 807 term8k = zr*rr9*dmpk(9)*xr 808 tixz = -vali*term1i - corei*term1core 809 & + diz*term2i + dix*term3i 810 & - dir*term4i - qixz*term5i + qiz*term6i 811 & + qix*term7i - qir*term8i 812 tkxz = -valk*term1k - corek*term1core 813 & - dkz*term2k - dkx*term3k 814 & + dkr*term4k - qkxz*term5k + qkz*term6k 815 & + qkx*term7k - qkr*term8k 816 term2i = rr5*dmpi(5)*yr 817 term1i = zr * term2i 818 term1core = rr5*yr*zr 819 term3i = rr5*dmpi(5)*zr 820 term4i = zr * (rr7*dmpi(7)*yr) 821 term5i = 2.0d0*rr5*dmpi(5) 822 term6i = 2.0d0*rr7*dmpi(7)*yr 823 term7i = 2.0d0*rr7*dmpi(7)*zr 824 term8i = zr*rr9*dmpi(9)*yr 825 term2k = rr5*dmpk(5)*yr 826 term1k = zr * term2k 827 term3k = rr5*dmpk(5)*zr 828 term4k = zr * (rr7*dmpk(7)*yr) 829 term5k = 2.0d0*rr5*dmpk(5) 830 term6k = 2.0d0*rr7*dmpk(7)*yr 831 term7k = 2.0d0*rr7*dmpk(7)*zr 832 term8k = zr*rr9*dmpk(9)*yr 833 tiyz = -vali*term1i - corei*term1core 834 & + diz*term2i + diy*term3i 835 & - dir*term4i - qiyz*term5i + qiz*term6i 836 & + qiy*term7i - qir*term8i 837 tkyz = -valk*term1k - corek*term1core 838 & - dkz*term2k - dky*term3k 839 & + dkr*term4k - qkyz*term5k + qkz*term6k 840 & + qky*term7k - qkr*term8k 841 end if 842c 843c get the dEd/dR terms for Thole direct polarization force 844c 845 if (use_thole) then 846 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 847 & - tkxx*uixp - tkxy*uiyp - tkxz*uizp 848 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 849 & - tkxy*uixp - tkyy*uiyp - tkyz*uizp 850 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 851 & - tkxz*uixp - tkyz*uiyp - tkzz*uizp 852 frcx = dscale(k) * depx 853 frcy = dscale(k) * depy 854 frcz = dscale(k) * depz 855c 856c get the dEp/dR terms for Thole direct polarization force 857c 858 depx = tixx*ukx + tixy*uky + tixz*ukz 859 & - tkxx*uix - tkxy*uiy - tkxz*uiz 860 depy = tixy*ukx + tiyy*uky + tiyz*ukz 861 & - tkxy*uix - tkyy*uiy - tkyz*uiz 862 depz = tixz*ukx + tiyz*uky + tizz*ukz 863 & - tkxz*uix - tkyz*uiy - tkzz*uiz 864 frcx = frcx + pscale(k)*depx 865 frcy = frcy + pscale(k)*depy 866 frcz = frcz + pscale(k)*depz 867c 868c get the dEp/dR terms for chgpen direct polarization force 869c 870 else if (use_chgpen) then 871 depx = tixx*ukx + tixy*uky + tixz*ukz 872 & - tkxx*uix - tkxy*uiy - tkxz*uiz 873 depy = tixy*ukx + tiyy*uky + tiyz*ukz 874 & - tkxy*uix - tkyy*uiy - tkyz*uiz 875 depz = tixz*ukx + tiyz*uky + tizz*ukz 876 & - tkxz*uix - tkyz*uiy - tkzz*uiz 877 frcx = 2.0d0*dscale(k)*depx 878 frcy = 2.0d0*dscale(k)*depy 879 frcz = 2.0d0*dscale(k)*depz 880 end if 881c 882c reset Thole values if alternate direct damping was used 883c 884 if (use_dirdamp) then 885 sc3 = 1.0d0 886 sc5 = 1.0d0 887 do j = 1, 3 888 rc3(j) = 0.0d0 889 rc5(j) = 0.0d0 890 end do 891 damp = pdi * pdamp(kk) 892 if (damp .ne. 0.0d0) then 893 pgamma = min(pti,thole(kk)) 894 damp = pgamma * (r/damp)**3 895 if (damp .lt. 50.0d0) then 896 expdamp = exp(-damp) 897 sc3 = 1.0d0 - expdamp 898 sc5 = 1.0d0 - expdamp*(1.0d0+damp) 899 temp3 = damp * expdamp * rr5 900 temp5 = 3.0d0 * damp / r2 901 rc3(1) = xr * temp3 902 rc3(2) = yr * temp3 903 rc3(3) = zr * temp3 904 rc5(1) = rc3(1) * temp5 905 rc5(2) = rc3(2) * temp5 906 rc5(3) = rc3(3) * temp5 907 end if 908 end if 909 end if 910c 911c get the dtau/dr terms used for mutual polarization force 912c 913 if (poltyp.eq.'MUTUAL' .and. use_thole) then 914 term1 = (sc3+sc5) * rr5 915 term2 = term1*xr - rc3(1) 916 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 917 tixx = uix*term2 + uir*term3 918 tkxx = ukx*term2 + ukr*term3 919 term2 = term1*yr - rc3(2) 920 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 921 tiyy = uiy*term2 + uir*term3 922 tkyy = uky*term2 + ukr*term3 923 term2 = term1*zr - rc3(3) 924 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 925 tizz = uiz*term2 + uir*term3 926 tkzz = ukz*term2 + ukr*term3 927 term1 = sc5 * rr5 * yr 928 term2 = sc3*rr5*xr - rc3(1) 929 term3 = yr * (sc5*rr7*xr-rc5(1)) 930 tixy = uix*term1 + uiy*term2 - uir*term3 931 tkxy = ukx*term1 + uky*term2 - ukr*term3 932 term1 = sc5 * rr5 * zr 933 term3 = zr * (sc5*rr7*xr-rc5(1)) 934 tixz = uix*term1 + uiz*term2 - uir*term3 935 tkxz = ukx*term1 + ukz*term2 - ukr*term3 936 term2 = sc3*rr5*yr - rc3(2) 937 term3 = zr * (sc5*rr7*yr-rc5(2)) 938 tiyz = uiy*term1 + uiz*term2 - uir*term3 939 tkyz = uky*term1 + ukz*term2 - ukr*term3 940 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 941 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 942 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 943 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 944 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 945 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 946 frcx = frcx + uscale(kk)*depx 947 frcy = frcy + uscale(kk)*depy 948 frcz = frcz + uscale(kk)*depz 949c 950c get the dtau/dr terms used for mutual polarization force 951c 952 else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then 953 term1 = 2.0d0 * dmpik(5) * rr5 954 term2 = term1*xr 955 term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 956 tixx = uix*term2 + uir*term3 957 tkxx = ukx*term2 + ukr*term3 958 term2 = term1*yr 959 term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 960 tiyy = uiy*term2 + uir*term3 961 tkyy = uky*term2 + ukr*term3 962 term2 = term1*zr 963 term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 964 tizz = uiz*term2 + uir*term3 965 tkzz = ukz*term2 + ukr*term3 966 term1 = rr5*dmpik(5)*yr 967 term2 = rr5*dmpik(5)*xr 968 term3 = yr * (rr7*dmpik(7)*xr) 969 tixy = uix*term1 + uiy*term2 - uir*term3 970 tkxy = ukx*term1 + uky*term2 - ukr*term3 971 term1 = rr5 *dmpik(5) * zr 972 term3 = zr * (rr7*dmpik(7)*xr) 973 tixz = uix*term1 + uiz*term2 - uir*term3 974 tkxz = ukx*term1 + ukz*term2 - ukr*term3 975 term2 = rr5*dmpik(5)*yr 976 term3 = zr * (rr7*dmpik(7)*yr) 977 tiyz = uiy*term1 + uiz*term2 - uir*term3 978 tkyz = uky*term1 + ukz*term2 - ukr*term3 979 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 980 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 981 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 982 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 983 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 984 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 985 frcx = frcx + wscale(kk)*depx 986 frcy = frcy + wscale(kk)*depy 987 frcz = frcz + wscale(kk)*depz 988c 989c get the dtau/dr terms used for OPT polarization force 990c 991 else if (poltyp.eq.'OPT' .and. use_thole) then 992 do j = 0, optorder-1 993 uirm = uopt(j,1,ii)*xr + uopt(j,2,ii)*yr 994 & + uopt(j,3,ii)*zr 995 do m = 0, optorder-j-1 996 ukrm = uopt(m,1,kk)*xr + uopt(m,2,kk)*yr 997 & + uopt(m,3,kk)*zr 998 term1 = (sc3+sc5) * rr5 999 term2 = term1*xr - rc3(1) 1000 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 1001 tixx = uopt(j,1,ii)*term2 + uirm*term3 1002 tkxx = uopt(m,1,kk)*term2 + ukrm*term3 1003 term2 = term1*yr - rc3(2) 1004 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 1005 tiyy = uopt(j,2,ii)*term2 + uirm*term3 1006 tkyy = uopt(m,2,kk)*term2 + ukrm*term3 1007 term2 = term1*zr - rc3(3) 1008 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 1009 tizz = uopt(j,3,ii)*term2 + uirm*term3 1010 tkzz = uopt(m,3,kk)*term2 + ukrm*term3 1011 term1 = sc5 * rr5 * yr 1012 term2 = sc3*rr5*xr - rc3(1) 1013 term3 = yr * (sc5*rr7*xr-rc5(1)) 1014 tixy = uopt(j,1,ii)*term1 + uopt(j,2,ii)*term2 1015 & - uirm*term3 1016 tkxy = uopt(m,1,kk)*term1 + uopt(m,2,kk)*term2 1017 & - ukrm*term3 1018 term1 = sc5 * rr5 * zr 1019 term3 = zr * (sc5*rr7*xr-rc5(1)) 1020 tixz = uopt(j,1,ii)*term1 + uopt(j,3,ii)*term2 1021 & - uirm*term3 1022 tkxz = uopt(m,1,kk)*term1 + uopt(m,3,kk)*term2 1023 & - ukrm*term3 1024 term2 = sc3*rr5*yr - rc3(2) 1025 term3 = zr * (sc5*rr7*yr-rc5(2)) 1026 tiyz = uopt(j,2,ii)*term1 + uopt(j,3,ii)*term2 1027 & - uirm*term3 1028 tkyz = uopt(m,2,kk)*term1 + uopt(m,3,kk)*term2 1029 & - ukrm*term3 1030 depx = tixx*uoptp(m,1,kk) + tkxx*uoptp(j,1,ii) 1031 & + tixy*uoptp(m,2,kk) + tkxy*uoptp(j,2,ii) 1032 & + tixz*uoptp(m,3,kk) + tkxz*uoptp(j,3,ii) 1033 depy = tixy*uoptp(m,1,kk) + tkxy*uoptp(j,1,ii) 1034 & + tiyy*uoptp(m,2,kk) + tkyy*uoptp(j,2,ii) 1035 & + tiyz*uoptp(m,3,kk) + tkyz*uoptp(j,3,ii) 1036 depz = tixz*uoptp(m,1,kk) + tkxz*uoptp(j,1,ii) 1037 & + tiyz*uoptp(m,2,kk) + tkyz*uoptp(j,2,ii) 1038 & + tizz*uoptp(m,3,kk) + tkzz*uoptp(j,3,ii) 1039 frcx = frcx + copm(j+m+1)*uscale(k)*depx 1040 frcy = frcy + copm(j+m+1)*uscale(k)*depy 1041 frcz = frcz + copm(j+m+1)*uscale(k)*depz 1042 end do 1043 end do 1044c 1045c get the dtau/dr terms used for OPT polarization force 1046c 1047 else if (poltyp.eq.'OPT' .and. use_chgpen) then 1048 do j = 0, optorder-1 1049 uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr 1050 & + uopt(j,3,i)*zr 1051 do m = 0, optorder-j-1 1052 ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr 1053 & + uopt(m,3,k)*zr 1054 term1 = 2.0d0 * dmpik(5) * rr5 1055 term2 = term1*xr 1056 term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 1057 tixx = uopt(j,1,i)*term2 + uirm*term3 1058 tkxx = uopt(m,1,k)*term2 + ukrm*term3 1059 term2 = term1*yr 1060 term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 1061 tiyy = uopt(j,2,i)*term2 + uirm*term3 1062 tkyy = uopt(m,2,k)*term2 + ukrm*term3 1063 term2 = term1*zr 1064 term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 1065 tizz = uopt(j,3,i)*term2 + uirm*term3 1066 tkzz = uopt(m,3,k)*term2 + ukrm*term3 1067 term1 = rr5*dmpik(5)*yr 1068 term2 = rr5*dmpik(5)*xr 1069 term3 = yr * (rr7*dmpik(7)*xr) 1070 tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2 1071 & - uirm*term3 1072 tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2 1073 & - ukrm*term3 1074 term1 = rr5 *dmpik(5) * zr 1075 term3 = zr * (rr7*dmpik(7)*xr) 1076 tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2 1077 & - uirm*term3 1078 tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2 1079 & - ukrm*term3 1080 term2 = rr5*dmpik(5)*yr 1081 term3 = zr * (rr7*dmpik(7)*yr) 1082 tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2 1083 & - uirm*term3 1084 tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2 1085 & - ukrm*term3 1086 depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i) 1087 & + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i) 1088 & + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i) 1089 depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i) 1090 & + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i) 1091 & + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i) 1092 depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i) 1093 & + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i) 1094 & + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i) 1095 frcx = frcx + copm(j+m+1)*wscale(k)*depx 1096 frcy = frcy + copm(j+m+1)*wscale(k)*depy 1097 frcz = frcz + copm(j+m+1)*wscale(k)*depz 1098 end do 1099 end do 1100c 1101c get the dtau/dr terms used for TCG polarization force 1102c 1103 else if (poltyp.eq.'TCG' .and. use_thole) then 1104 do j = 1, tcgnab 1105 ukx = ubd(1,kk,j) 1106 uky = ubd(2,kk,j) 1107 ukz = ubd(3,kk,j) 1108 ukxp = ubp(1,kk,j) 1109 ukyp = ubp(2,kk,j) 1110 ukzp = ubp(3,kk,j) 1111 uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr 1112 ukrt = ukx*xr + uky*yr + ukz*zr 1113 term1 = (sc3+sc5) * rr5 1114 term2 = term1*xr - rc3(1) 1115 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 1116 tixx = uax(j)*term2 + uirt*term3 1117 tkxx = ukx*term2 + ukrt*term3 1118 term2 = term1*yr - rc3(2) 1119 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 1120 tiyy = uay(j)*term2 + uirt*term3 1121 tkyy = uky*term2 + ukrt*term3 1122 term2 = term1*zr - rc3(3) 1123 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 1124 tizz = uaz(j)*term2 + uirt*term3 1125 tkzz = ukz*term2 + ukrt*term3 1126 term1 = sc5 * rr5 * yr 1127 term2 = sc3*rr5*xr - rc3(1) 1128 term3 = yr * (sc5*rr7*xr-rc5(1)) 1129 tixy = uax(j)*term1 + uay(j)*term2 - uirt*term3 1130 tkxy = ukx*term1 + uky*term2 - ukrt*term3 1131 term1 = sc5 * rr5 * zr 1132 term3 = zr * (sc5*rr7*xr-rc5(1)) 1133 tixz = uax(j)*term1 + uaz(j)*term2 - uirt*term3 1134 tkxz = ukx*term1 + ukz*term2 - ukrt*term3 1135 term2 = sc3*rr5*yr - rc3(2) 1136 term3 = zr * (sc5*rr7*yr-rc5(2)) 1137 tiyz = uay(j)*term1 + uaz(j)*term2 - uirt*term3 1138 tkyz = uky*term1 + ukz*term2 - ukrt*term3 1139 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 1140 & + tkxx*uaxp(j) + tkxy*uayp(j) 1141 & + tkxz*uazp(j) 1142 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 1143 & + tkxy*uaxp(j) + tkyy*uayp(j) 1144 & + tkyz*uazp(j) 1145 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 1146 & + tkxz*uaxp(j) + tkyz*uayp(j) 1147 & + tkzz*uazp(j) 1148 frcx = frcx + uscale(k)*depx 1149 frcy = frcy + uscale(k)*depy 1150 frcz = frcz + uscale(k)*depz 1151 ukx = uad(1,kk,j) 1152 uky = uad(2,kk,j) 1153 ukz = uad(3,kk,j) 1154 ukxp = uap(1,kk,j) 1155 ukyp = uap(2,kk,j) 1156 ukzp = uap(3,kk,j) 1157 uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr 1158 ukrt = ukx*xr + uky*yr + ukz*zr 1159 term1 = (sc3+sc5) * rr5 1160 term2 = term1*xr - rc3(1) 1161 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 1162 tixx = ubx(j)*term2 + uirt*term3 1163 tkxx = ukx*term2 + ukrt*term3 1164 term2 = term1*yr - rc3(2) 1165 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 1166 tiyy = uby(j)*term2 + uirt*term3 1167 tkyy = uky*term2 + ukrt*term3 1168 term2 = term1*zr - rc3(3) 1169 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 1170 tizz = ubz(j)*term2 + uirt*term3 1171 tkzz = ukz*term2 + ukrt*term3 1172 term1 = sc5 * rr5 * yr 1173 term2 = sc3*rr5*xr - rc3(1) 1174 term3 = yr * (sc5*rr7*xr-rc5(1)) 1175 tixy = ubx(j)*term1 + uby(j)*term2 - uirt*term3 1176 tkxy = ukx*term1 + uky*term2 - ukrt*term3 1177 term1 = sc5 * rr5 * zr 1178 term3 = zr * (sc5*rr7*xr-rc5(1)) 1179 tixz = ubx(j)*term1 + ubz(j)*term2 - uirt*term3 1180 tkxz = ukx*term1 + ukz*term2 - ukrt*term3 1181 term2 = sc3*rr5*yr - rc3(2) 1182 term3 = zr * (sc5*rr7*yr-rc5(2)) 1183 tiyz = uby(j)*term1 + ubz(j)*term2 - uirt*term3 1184 tkyz = uky*term1 + ukz*term2 - ukrt*term3 1185 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 1186 & + tkxx*ubxp(j) + tkxy*ubyp(j) 1187 & + tkxz*ubzp(j) 1188 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 1189 & + tkxy*ubxp(j) + tkyy*ubyp(j) 1190 & + tkyz*ubzp(j) 1191 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 1192 & + tkxz*ubxp(j) + tkyz*ubyp(j) 1193 & + tkzz*ubzp(j) 1194 frcx = frcx + uscale(k)*depx 1195 frcy = frcy + uscale(k)*depy 1196 frcz = frcz + uscale(k)*depz 1197 end do 1198 end if 1199c 1200c increment force-based gradient on the interaction sites 1201c 1202 dep(1,i) = dep(1,i) + frcx 1203 dep(2,i) = dep(2,i) + frcy 1204 dep(3,i) = dep(3,i) + frcz 1205 dep(1,k) = dep(1,k) - frcx 1206 dep(2,k) = dep(2,k) - frcy 1207 dep(3,k) = dep(3,k) - frcz 1208c 1209c increment the virial due to pairwise Cartesian forces 1210c 1211 vxx = -xr * frcx 1212 vxy = -0.5d0 * (yr*frcx+xr*frcy) 1213 vxz = -0.5d0 * (zr*frcx+xr*frcz) 1214 vyy = -yr * frcy 1215 vyz = -0.5d0 * (zr*frcy+yr*frcz) 1216 vzz = -zr * frcz 1217 vir(1,1) = vir(1,1) + vxx 1218 vir(2,1) = vir(2,1) + vxy 1219 vir(3,1) = vir(3,1) + vxz 1220 vir(1,2) = vir(1,2) + vxy 1221 vir(2,2) = vir(2,2) + vyy 1222 vir(3,2) = vir(3,2) + vyz 1223 vir(1,3) = vir(1,3) + vxz 1224 vir(2,3) = vir(2,3) + vyz 1225 vir(3,3) = vir(3,3) + vzz 1226 end if 1227 end do 1228c 1229c reset exclusion coefficients for connected atoms 1230c 1231 if (dpequal) then 1232 do j = 1, n12(i) 1233 pscale(i12(j,i)) = 1.0d0 1234 dscale(i12(j,i)) = 1.0d0 1235 wscale(i12(j,i)) = 1.0d0 1236 end do 1237 do j = 1, n13(i) 1238 pscale(i13(j,i)) = 1.0d0 1239 dscale(i13(j,i)) = 1.0d0 1240 wscale(i13(j,i)) = 1.0d0 1241 end do 1242 do j = 1, n14(i) 1243 pscale(i14(j,i)) = 1.0d0 1244 dscale(i14(j,i)) = 1.0d0 1245 wscale(i14(j,i)) = 1.0d0 1246 end do 1247 do j = 1, n15(i) 1248 pscale(i15(j,i)) = 1.0d0 1249 dscale(i15(j,i)) = 1.0d0 1250 wscale(i15(j,i)) = 1.0d0 1251 end do 1252 do j = 1, np11(i) 1253 uscale(ip11(j,i)) = 1.0d0 1254 end do 1255 do j = 1, np12(i) 1256 uscale(ip12(j,i)) = 1.0d0 1257 end do 1258 do j = 1, np13(i) 1259 uscale(ip13(j,i)) = 1.0d0 1260 end do 1261 do j = 1, np14(i) 1262 uscale(ip14(j,i)) = 1.0d0 1263 end do 1264 else 1265 do j = 1, n12(i) 1266 pscale(i12(j,i)) = 1.0d0 1267 wscale(i12(j,i)) = 1.0d0 1268 end do 1269 do j = 1, n13(i) 1270 pscale(i13(j,i)) = 1.0d0 1271 wscale(i13(j,i)) = 1.0d0 1272 end do 1273 do j = 1, n14(i) 1274 pscale(i14(j,i)) = 1.0d0 1275 wscale(i14(j,i)) = 1.0d0 1276 end do 1277 do j = 1, n15(i) 1278 pscale(i15(j,i)) = 1.0d0 1279 wscale(i15(j,i)) = 1.0d0 1280 end do 1281 do j = 1, np11(i) 1282 dscale(ip11(j,i)) = 1.0d0 1283 uscale(ip11(j,i)) = 1.0d0 1284 end do 1285 do j = 1, np12(i) 1286 dscale(ip12(j,i)) = 1.0d0 1287 uscale(ip12(j,i)) = 1.0d0 1288 end do 1289 do j = 1, np13(i) 1290 dscale(ip13(j,i)) = 1.0d0 1291 uscale(ip13(j,i)) = 1.0d0 1292 end do 1293 do j = 1, np14(i) 1294 dscale(ip14(j,i)) = 1.0d0 1295 uscale(ip14(j,i)) = 1.0d0 1296 end do 1297 end if 1298 end do 1299c 1300c for periodic boundary conditions with large cutoffs 1301c neighbors must be found by the replicates method 1302c 1303 if (use_replica) then 1304c 1305c calculate interaction with other unit cells 1306c 1307 do ii = 1, npole 1308 i = ipole(ii) 1309 xi = x(i) 1310 yi = y(i) 1311 zi = z(i) 1312 ci = rpole(1,ii) 1313 dix = rpole(2,ii) 1314 diy = rpole(3,ii) 1315 diz = rpole(4,ii) 1316 qixx = rpole(5,ii) 1317 qixy = rpole(6,ii) 1318 qixz = rpole(7,ii) 1319 qiyy = rpole(9,ii) 1320 qiyz = rpole(10,ii) 1321 qizz = rpole(13,ii) 1322 uix = uind(1,ii) 1323 uiy = uind(2,ii) 1324 uiz = uind(3,ii) 1325 uixp = uinp(1,ii) 1326 uiyp = uinp(2,ii) 1327 uizp = uinp(3,ii) 1328 do j = 1, tcgnab 1329 uax(j) = uad(1,ii,j) 1330 uay(j) = uad(2,ii,j) 1331 uaz(j) = uad(3,ii,j) 1332 uaxp(j) = uap(1,ii,j) 1333 uayp(j) = uap(2,ii,j) 1334 uazp(j) = uap(3,ii,j) 1335 ubx(j) = ubd(1,ii,j) 1336 uby(j) = ubd(2,ii,j) 1337 ubz(j) = ubd(3,ii,j) 1338 ubxp(j) = ubp(1,ii,j) 1339 ubyp(j) = ubp(2,ii,j) 1340 ubzp(j) = ubp(3,ii,j) 1341 end do 1342 if (use_thole) then 1343 pdi = pdamp(ii) 1344 pti = thole(ii) 1345 ddi = dirdamp(ii) 1346 else if (use_chgpen) then 1347 corei = pcore(ii) 1348 vali = pval(ii) 1349 alphai = palpha(ii) 1350 end if 1351c 1352c set exclusion coefficients for connected atoms 1353c 1354 if (dpequal) then 1355 do j = 1, n12(i) 1356 pscale(i12(j,i)) = p2scale 1357 do k = 1, np11(i) 1358 if (i12(j,i) .eq. ip11(k,i)) 1359 & pscale(i12(j,i)) = p2iscale 1360 end do 1361 dscale(i12(j,i)) = pscale(i12(j,i)) 1362 wscale(i12(j,i)) = w2scale 1363 end do 1364 do j = 1, n13(i) 1365 pscale(i13(j,i)) = p3scale 1366 do k = 1, np11(i) 1367 if (i13(j,i) .eq. ip11(k,i)) 1368 & pscale(i13(j,i)) = p3iscale 1369 end do 1370 dscale(i13(j,i)) = pscale(i13(j,i)) 1371 wscale(i13(j,i)) = w3scale 1372 end do 1373 do j = 1, n14(i) 1374 pscale(i14(j,i)) = p4scale 1375 do k = 1, np11(i) 1376 if (i14(j,i) .eq. ip11(k,i)) 1377 & pscale(i14(j,i)) = p4iscale 1378 end do 1379 dscale(i14(j,i)) = pscale(i14(j,i)) 1380 wscale(i14(j,i)) = w4scale 1381 end do 1382 do j = 1, n15(i) 1383 pscale(i15(j,i)) = p5scale 1384 do k = 1, np11(i) 1385 if (i15(j,i) .eq. ip11(k,i)) 1386 & pscale(i15(j,i)) = p5iscale 1387 end do 1388 dscale(i15(j,i)) = pscale(i15(j,i)) 1389 wscale(i15(j,i)) = w5scale 1390 end do 1391 do j = 1, np11(i) 1392 uscale(ip11(j,i)) = u1scale 1393 end do 1394 do j = 1, np12(i) 1395 uscale(ip12(j,i)) = u2scale 1396 end do 1397 do j = 1, np13(i) 1398 uscale(ip13(j,i)) = u3scale 1399 end do 1400 do j = 1, np14(i) 1401 uscale(ip14(j,i)) = u4scale 1402 end do 1403 else 1404 do j = 1, n12(i) 1405 pscale(i12(j,i)) = p2scale 1406 do k = 1, np11(i) 1407 if (i12(j,i) .eq. ip11(k,i)) 1408 & pscale(i12(j,i)) = p2iscale 1409 end do 1410 wscale(i12(j,i)) = w2scale 1411 end do 1412 do j = 1, n13(i) 1413 pscale(i13(j,i)) = p3scale 1414 do k = 1, np11(i) 1415 if (i13(j,i) .eq. ip11(k,i)) 1416 & pscale(i13(j,i)) = p3iscale 1417 end do 1418 wscale(i13(j,i)) = w3scale 1419 end do 1420 do j = 1, n14(i) 1421 pscale(i14(j,i)) = p4scale 1422 do k = 1, np11(i) 1423 if (i14(j,i) .eq. ip11(k,i)) 1424 & pscale(i14(j,i)) = p4iscale 1425 end do 1426 wscale(i14(j,i)) = w4scale 1427 end do 1428 do j = 1, n15(i) 1429 pscale(i15(j,i)) = p5scale 1430 do k = 1, np11(i) 1431 if (i15(j,i) .eq. ip11(k,i)) 1432 & pscale(i15(j,i)) = p5iscale 1433 end do 1434 wscale(i15(j,i)) = w5scale 1435 end do 1436 do j = 1, np11(i) 1437 dscale(ip11(j,i)) = d1scale 1438 uscale(ip11(j,i)) = u1scale 1439 end do 1440 do j = 1, np12(i) 1441 dscale(ip12(j,i)) = d2scale 1442 uscale(ip12(j,i)) = u2scale 1443 end do 1444 do j = 1, np13(i) 1445 dscale(ip13(j,i)) = d3scale 1446 uscale(ip13(j,i)) = u3scale 1447 end do 1448 do j = 1, np14(i) 1449 dscale(ip14(j,i)) = d4scale 1450 uscale(ip14(j,i)) = u4scale 1451 end do 1452 end if 1453c 1454c evaluate all sites within the cutoff distance 1455c 1456 do kk = ii, npole 1457 k = ipole(kk) 1458 do jcell = 2, ncell 1459 xr = x(k) - xi 1460 yr = y(k) - yi 1461 zr = z(k) - zi 1462 if (use_bounds) call imager (xr,yr,zr,jcell) 1463 r2 = xr*xr + yr*yr + zr*zr 1464 if (.not. (use_polymer .and. r2.le.polycut2)) then 1465 pscale(k) = 1.0d0 1466 dscale(k) = 1.0d0 1467 uscale(k) = 1.0d0 1468 end if 1469 if (r2 .le. off2) then 1470 r = sqrt(r2) 1471 ck = rpole(1,kk) 1472 dkx = rpole(2,kk) 1473 dky = rpole(3,kk) 1474 dkz = rpole(4,kk) 1475 qkxx = rpole(5,kk) 1476 qkxy = rpole(6,kk) 1477 qkxz = rpole(7,kk) 1478 qkyy = rpole(9,kk) 1479 qkyz = rpole(10,kk) 1480 qkzz = rpole(13,kk) 1481 ukx = uind(1,kk) 1482 uky = uind(2,kk) 1483 ukz = uind(3,kk) 1484 ukxp = uinp(1,kk) 1485 ukyp = uinp(2,kk) 1486 ukzp = uinp(3,kk) 1487c 1488c intermediates involving moments and separation distance 1489c 1490 dir = dix*xr + diy*yr + diz*zr 1491 qix = qixx*xr + qixy*yr + qixz*zr 1492 qiy = qixy*xr + qiyy*yr + qiyz*zr 1493 qiz = qixz*xr + qiyz*yr + qizz*zr 1494 qir = qix*xr + qiy*yr + qiz*zr 1495 dkr = dkx*xr + dky*yr + dkz*zr 1496 qkx = qkxx*xr + qkxy*yr + qkxz*zr 1497 qky = qkxy*xr + qkyy*yr + qkyz*zr 1498 qkz = qkxz*xr + qkyz*yr + qkzz*zr 1499 qkr = qkx*xr + qky*yr + qkz*zr 1500 uir = uix*xr + uiy*yr + uiz*zr 1501 uirp = uixp*xr + uiyp*yr + uizp*zr 1502 ukr = ukx*xr + uky*yr + ukz*zr 1503 ukrp = ukxp*xr + ukyp*yr + ukzp*zr 1504c 1505c get reciprocal distance terms for this interaction 1506c 1507 rr1 = f / r 1508 rr3 = rr1 / r2 1509 rr5 = 3.0d0 * rr3 / r2 1510 rr7 = 5.0d0 * rr5 / r2 1511 rr9 = 7.0d0 * rr7 / r2 1512c 1513c apply Thole polarization damping to scale factors 1514c 1515 sc3 = 1.0d0 1516 sc5 = 1.0d0 1517 sc7 = 1.0d0 1518 do j = 1, 3 1519 rc3(j) = 0.0d0 1520 rc5(j) = 0.0d0 1521 rc7(j) = 0.0d0 1522 end do 1523c 1524c apply Thole polarization damping to scale factors 1525c 1526 if (use_thole) then 1527 damp = pdi * pdamp(kk) 1528 if (use_dirdamp) then 1529 pgamma = min(ddi,dirdamp(kk)) 1530 if (pgamma .eq. 0.0d0) then 1531 pgamma = max(ddi,dirdamp(kk)) 1532 end if 1533 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 1534 damp = pgamma * (r/damp)**(1.5d0) 1535 if (damp .lt. 50.0d0) then 1536 expdamp = exp(-damp) 1537 sc3 = 1.0d0 - expdamp 1538 sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp) 1539 sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp 1540 & +0.15d0*damp**2) 1541 temp3 = 0.5d0 * damp * expdamp 1542 temp5 = 1.5d0 * (1.0d0+damp) 1543 temp7 = 5.0d0*(1.5d0*damp*expdamp 1544 & *(0.35d0+0.35d0*damp 1545 & +0.15d0*damp**2))/(temp3*temp5) 1546 temp3 = temp3 * rr5 1547 temp5 = temp5 / r2 1548 temp7 = temp7 / r2 1549 rc3(1) = xr * temp3 1550 rc3(2) = yr * temp3 1551 rc3(3) = zr * temp3 1552 rc5(1) = rc3(1) * temp5 1553 rc5(2) = rc3(2) * temp5 1554 rc5(3) = rc3(3) * temp5 1555 rc7(1) = rc5(1) * temp7 1556 rc7(2) = rc5(2) * temp7 1557 rc7(3) = rc5(3) * temp7 1558 end if 1559 end if 1560 else 1561 pgamma = min(pti,thole(kk)) 1562 if (pgamma .eq. 0.0d0) then 1563 pgamma = max(pti,thole(kk)) 1564 end if 1565 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 1566 damp = pgamma * (r/damp)**3 1567 if (damp .lt. 50.0d0) then 1568 expdamp = exp(-damp) 1569 sc3 = 1.0d0 - expdamp 1570 sc5 = 1.0d0 - expdamp*(1.0d0+damp) 1571 sc7 = 1.0d0 - expdamp*(1.0d0+damp 1572 & +0.6d0*damp**2) 1573 temp3 = damp * expdamp * rr5 1574 temp5 = 3.0d0 * damp / r2 1575 temp7 = (-1.0d0+3.0d0*damp) / r2 1576 rc3(1) = xr * temp3 1577 rc3(2) = yr * temp3 1578 rc3(3) = zr * temp3 1579 rc5(1) = rc3(1) * temp5 1580 rc5(2) = rc3(2) * temp5 1581 rc5(3) = rc3(3) * temp5 1582 rc7(1) = rc5(1) * temp7 1583 rc7(2) = rc5(2) * temp7 1584 rc7(3) = rc5(3) * temp7 1585 end if 1586 end if 1587 end if 1588 sr3 = rr3 * sc3 1589 sr5 = rr5 * sc5 1590 sr7 = rr7 * sc7 1591 dsr3 = sr3 * dscale(k) 1592 dsr5 = sr5 * dscale(k) 1593 dsr7 = sr7 * dscale(k) 1594 psr3 = sr3 * pscale(k) 1595 psr5 = sr5 * pscale(k) 1596 psr7 = sr7 * pscale(k) 1597c 1598c apply charge penetration damping to scale factors 1599c 1600 else if (use_chgpen) then 1601 corek = pcore(kk) 1602 valk = pval(kk) 1603 alphak = palpha(kk) 1604 call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik) 1605 dsr3i = 2.0d0 * rr3 * dmpi(3) * dscale(k) 1606 dsr5i = 2.0d0 * rr5 * dmpi(5) * dscale(k) 1607 dsr7i = 2.0d0 * rr7 * dmpi(7) * dscale(k) 1608 dsr3k = 2.0d0 * rr3 * dmpk(3) * dscale(k) 1609 dsr5k = 2.0d0 * rr5 * dmpk(5) * dscale(k) 1610 dsr7k = 2.0d0 * rr7 * dmpk(7) * dscale(k) 1611 end if 1612c 1613c store the potential at each site for use in charge flux 1614c 1615 if (use_chgflx) then 1616 if (use_thole) then 1617 poti = -ukr*psr3 - ukrp*dsr3 1618 potk = uir*psr3 + uirp*dsr3 1619 else if (use_chgpen) then 1620 poti = -ukr * dsr3i 1621 potk = uir * dsr3k 1622 end if 1623 pot(i) = pot(i) + poti 1624 pot(k) = pot(k) + potk 1625 end if 1626c 1627c get the induced dipole field used for dipole torques 1628c 1629 if (use_thole) then 1630 tix3 = psr3*ukx + dsr3*ukxp 1631 tiy3 = psr3*uky + dsr3*ukyp 1632 tiz3 = psr3*ukz + dsr3*ukzp 1633 tkx3 = psr3*uix + dsr3*uixp 1634 tky3 = psr3*uiy + dsr3*uiyp 1635 tkz3 = psr3*uiz + dsr3*uizp 1636 tuir = -psr5*ukr - dsr5*ukrp 1637 tukr = -psr5*uir - dsr5*uirp 1638 else if (use_chgpen) then 1639 tix3 = dsr3i*ukx 1640 tiy3 = dsr3i*uky 1641 tiz3 = dsr3i*ukz 1642 tkx3 = dsr3k*uix 1643 tky3 = dsr3k*uiy 1644 tkz3 = dsr3k*uiz 1645 tuir = -dsr5i*ukr 1646 tukr = -dsr5k*uir 1647 end if 1648 ufld(1,i) = ufld(1,i) + tix3 + xr*tuir 1649 ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir 1650 ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir 1651 ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr 1652 ufld(2,k) = ufld(2,k) + tky3 + yr*tukr 1653 ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr 1654c 1655c get induced dipole field gradient used for quadrupole torques 1656c 1657 if (use_thole) then 1658 tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp) 1659 tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp) 1660 tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp) 1661 tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp) 1662 tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp) 1663 tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp) 1664 tuir = -psr7*ukr - dsr7*ukrp 1665 tukr = -psr7*uir - dsr7*uirp 1666 else if (use_chgpen) then 1667 tix5 = 2.0d0 * (dsr5i*ukx) 1668 tiy5 = 2.0d0 * (dsr5i*uky) 1669 tiz5 = 2.0d0 * (dsr5i*ukz) 1670 tkx5 = 2.0d0 * (dsr5k*uix) 1671 tky5 = 2.0d0 * (dsr5k*uiy) 1672 tkz5 = 2.0d0 * (dsr5k*uiz) 1673 tuir = -dsr7i*ukr 1674 tukr = -dsr7k*uir 1675 end if 1676 dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir 1677 dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5 1678 & + 2.0d0*xr*yr*tuir 1679 dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir 1680 dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5 1681 & + 2.0d0*xr*zr*tuir 1682 dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5 1683 & + 2.0d0*yr*zr*tuir 1684 dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir 1685 dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr 1686 dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5 1687 & - 2.0d0*xr*yr*tukr 1688 dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr 1689 dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5 1690 & - 2.0d0*xr*zr*tukr 1691 dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5 1692 & - 2.0d0*yr*zr*tukr 1693 dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr 1694c 1695c get the field gradient for direct polarization force 1696c 1697 if (use_thole) then 1698 term1 = sc3*(rr3-rr5*xr*xr) + rc3(1)*xr 1699 term2 = (sc3+sc5)*rr5*xr - rc3(1) 1700 term3 = sc5*(rr7*xr*xr-rr5) - rc5(1)*xr 1701 term4 = 2.0d0 * sc5 * rr5 1702 term5 = 2.0d0 * (sc5*rr7*xr-rc5(1)+1.5d0*sc7*rr7*xr) 1703 term6 = xr * (sc7*rr9*xr-rc7(1)) 1704 tixx = ci*term1 + dix*term2 - dir*term3 1705 & - qixx*term4 + qix*term5 - qir*term6 1706 & + (qiy*yr+qiz*zr)*sc7*rr7 1707 tkxx = ck*term1 - dkx*term2 + dkr*term3 1708 & - qkxx*term4 + qkx*term5 - qkr*term6 1709 & + (qky*yr+qkz*zr)*sc7*rr7 1710 term1 = sc3*(rr3-rr5*yr*yr) + rc3(2)*yr 1711 term2 = (sc3+sc5)*rr5*yr - rc3(2) 1712 term3 = sc5*(rr7*yr*yr-rr5) - rc5(2)*yr 1713 term4 = 2.0d0 * sc5 * rr5 1714 term5 = 2.0d0 * (sc5*rr7*yr-rc5(2)+1.5d0*sc7*rr7*yr) 1715 term6 = yr * (sc7*rr9*yr-rc7(2)) 1716 tiyy = ci*term1 + diy*term2 - dir*term3 1717 & - qiyy*term4 + qiy*term5 - qir*term6 1718 & + (qix*xr+qiz*zr)*sc7*rr7 1719 tkyy = ck*term1 - dky*term2 + dkr*term3 1720 & - qkyy*term4 + qky*term5 - qkr*term6 1721 & + (qkx*xr+qkz*zr)*sc7*rr7 1722 term1 = sc3*(rr3-rr5*zr*zr) + rc3(3)*zr 1723 term2 = (sc3+sc5)*rr5*zr - rc3(3) 1724 term3 = sc5*(rr7*zr*zr-rr5) - rc5(3)*zr 1725 term4 = 2.0d0 * sc5 * rr5 1726 term5 = 2.0d0 * (sc5*rr7*zr-rc5(3)+1.5d0*sc7*rr7*zr) 1727 term6 = zr * (sc7*rr9*zr-rc7(3)) 1728 tizz = ci*term1 + diz*term2 - dir*term3 1729 & - qizz*term4 + qiz*term5 - qir*term6 1730 & + (qix*xr+qiy*yr)*sc7*rr7 1731 tkzz = ck*term1 - dkz*term2 + dkr*term3 1732 & - qkzz*term4 + qkz*term5 - qkr*term6 1733 & + (qkx*xr+qky*yr)*sc7*rr7 1734 term2 = sc3*rr5*xr - rc3(1) 1735 term1 = yr * term2 1736 term3 = sc5 * rr5 * yr 1737 term4 = yr * (sc5*rr7*xr-rc5(1)) 1738 term5 = 2.0d0 * sc5 * rr5 1739 term6 = 2.0d0 * (sc5*rr7*xr-rc5(1)) 1740 term7 = 2.0d0 * sc7 * rr7 * yr 1741 term8 = yr * (sc7*rr9*xr-rc7(1)) 1742 tixy = -ci*term1 + diy*term2 + dix*term3 1743 & - dir*term4 - qixy*term5 + qiy*term6 1744 & + qix*term7 - qir*term8 1745 tkxy = -ck*term1 - dky*term2 - dkx*term3 1746 & + dkr*term4 - qkxy*term5 + qky*term6 1747 & + qkx*term7 - qkr*term8 1748 term2 = sc3*rr5*xr - rc3(1) 1749 term1 = zr * term2 1750 term3 = sc5 * rr5 * zr 1751 term4 = zr * (sc5*rr7*xr-rc5(1)) 1752 term5 = 2.0d0 * sc5 * rr5 1753 term6 = 2.0d0 * (sc5*rr7*xr-rc5(1)) 1754 term7 = 2.0d0 * sc7 * rr7 * zr 1755 term8 = zr * (sc7*rr9*xr-rc7(1)) 1756 tixz = -ci*term1 + diz*term2 + dix*term3 1757 & - dir*term4 - qixz*term5 + qiz*term6 1758 & + qix*term7 - qir*term8 1759 tkxz = -ck*term1 - dkz*term2 - dkx*term3 1760 & + dkr*term4 - qkxz*term5 + qkz*term6 1761 & + qkx*term7 - qkr*term8 1762 term2 = sc3*rr5*yr - rc3(2) 1763 term1 = zr * term2 1764 term3 = sc5 * rr5 * zr 1765 term4 = zr * (sc5*rr7*yr-rc5(2)) 1766 term5 = 2.0d0 * sc5 * rr5 1767 term6 = 2.0d0 * (sc5*rr7*yr-rc5(2)) 1768 term7 = 2.0d0 * sc7 * rr7 * zr 1769 term8 = zr * (sc7*rr9*yr-rc7(2)) 1770 tiyz = -ci*term1 + diz*term2 + diy*term3 1771 & - dir*term4 - qiyz*term5 + qiz*term6 1772 & + qiy*term7 - qir*term8 1773 tkyz = -ck*term1 - dkz*term2 - dky*term3 1774 & + dkr*term4 - qkyz*term5 + qkz*term6 1775 & + qky*term7 - qkr*term8 1776c 1777c get the field gradient for direct polarization force 1778c 1779 else if (use_chgpen) then 1780 term1i = rr3*dmpi(3) - rr5*dmpi(5)*xr*xr 1781 term1core = rr3 - rr5*xr*xr 1782 term2i = 2.0d0*rr5*dmpi(5)*xr 1783 term3i = rr7*dmpi(7)*xr*xr - rr5*dmpi(5) 1784 term4i = 2.0d0*rr5*dmpi(5) 1785 term5i = 5.0d0*rr7*dmpi(7)*xr 1786 term6i = rr9*dmpi(9)*xr*xr 1787 term1k = rr3*dmpk(3) - rr5*dmpk(5)*xr*xr 1788 term2k = 2.0d0*rr5*dmpk(5)*xr 1789 term3k = rr7*dmpk(7)*xr*xr - rr5*dmpk(5) 1790 term4k = 2.0d0*rr5*dmpk(5) 1791 term5k = 5.0d0*rr7*dmpk(7)*xr 1792 term6k = rr9*dmpk(9)*xr*xr 1793 tixx = vali*term1i + corei*term1core 1794 & + dix*term2i - dir*term3i 1795 & - qixx*term4i + qix*term5i - qir*term6i 1796 & + (qiy*yr+qiz*zr)*rr7*dmpi(7) 1797 tkxx = valk*term1k + corek*term1core 1798 & - dkx*term2k + dkr*term3k 1799 & - qkxx*term4k + qkx*term5k - qkr*term6k 1800 & + (qky*yr+qkz*zr)*rr7*dmpk(7) 1801 term1i = rr3*dmpi(3) - rr5*dmpi(5)*yr*yr 1802 term1core = rr3 - rr5*yr*yr 1803 term2i = 2.0d0*rr5*dmpi(5)*yr 1804 term3i = rr7*dmpi(7)*yr*yr - rr5*dmpi(5) 1805 term4i = 2.0d0*rr5*dmpi(5) 1806 term5i = 5.0d0*rr7*dmpi(7)*yr 1807 term6i = rr9*dmpi(9)*yr*yr 1808 term1k = rr3*dmpk(3) - rr5*dmpk(5)*yr*yr 1809 term2k = 2.0d0*rr5*dmpk(5)*yr 1810 term3k = rr7*dmpk(7)*yr*yr - rr5*dmpk(5) 1811 term4k = 2.0d0*rr5*dmpk(5) 1812 term5k = 5.0d0*rr7*dmpk(7)*yr 1813 term6k = rr9*dmpk(9)*yr*yr 1814 tiyy = vali*term1i + corei*term1core 1815 & + diy*term2i - dir*term3i 1816 & - qiyy*term4i + qiy*term5i - qir*term6i 1817 & + (qix*xr+qiz*zr)*rr7*dmpi(7) 1818 tkyy = valk*term1k + corek*term1core 1819 & - dky*term2k + dkr*term3k 1820 & - qkyy*term4k + qky*term5k - qkr*term6k 1821 & + (qkx*xr+qkz*zr)*rr7*dmpk(7) 1822 term1i = rr3*dmpi(3) - rr5*dmpi(5)*zr*zr 1823 term1core = rr3 - rr5*zr*zr 1824 term2i = 2.0d0*rr5*dmpi(5)*zr 1825 term3i = rr7*dmpi(7)*zr*zr - rr5*dmpi(5) 1826 term4i = 2.0d0*rr5*dmpi(5) 1827 term5i = 5.0d0*rr7*dmpi(7)*zr 1828 term6i = rr9*dmpi(9)*zr*zr 1829 term1k = rr3*dmpk(3) - rr5*dmpk(5)*zr*zr 1830 term2k = 2.0d0*rr5*dmpk(5)*zr 1831 term3k = rr7*dmpk(7)*zr*zr - rr5*dmpk(5) 1832 term4k = 2.0d0*rr5*dmpk(5) 1833 term5k = 5.0d0*rr7*dmpk(7)*zr 1834 term6k = rr9*dmpk(9)*zr*zr 1835 tizz = vali*term1i + corei*term1core 1836 & + diz*term2i - dir*term3i 1837 & - qizz*term4i + qiz*term5i - qir*term6i 1838 & + (qix*xr+qiy*yr)*rr7*dmpi(7) 1839 tkzz = valk*term1k + corek*term1core 1840 & - dkz*term2k + dkr*term3k 1841 & - qkzz*term4k + qkz*term5k - qkr*term6k 1842 & + (qkx*xr+qky*yr)*rr7*dmpk(7) 1843 term2i = rr5*dmpi(5)*xr 1844 term1i = yr * term2i 1845 term1core = rr5*xr*yr 1846 term3i = rr5*dmpi(5)*yr 1847 term4i = yr * (rr7*dmpi(7)*xr) 1848 term5i = 2.0d0*rr5*dmpi(5) 1849 term6i = 2.0d0*rr7*dmpi(7)*xr 1850 term7i = 2.0d0*rr7*dmpi(7)*yr 1851 term8i = yr*rr9*dmpi(9)*xr 1852 term2k = rr5*dmpk(5)*xr 1853 term1k = yr * term2k 1854 term3k = rr5*dmpk(5)*yr 1855 term4k = yr * (rr7*dmpk(7)*xr) 1856 term5k = 2.0d0*rr5*dmpk(5) 1857 term6k = 2.0d0*rr7*dmpk(7)*xr 1858 term7k = 2.0d0*rr7*dmpk(7)*yr 1859 term8k = yr*rr9*dmpk(9)*xr 1860 tixy = -vali*term1i - corei*term1core 1861 & + diy*term2i + dix*term3i 1862 & - dir*term4i - qixy*term5i + qiy*term6i 1863 & + qix*term7i - qir*term8i 1864 tkxy = -valk*term1k - corek*term1core 1865 & - dky*term2k - dkx*term3k 1866 & + dkr*term4k - qkxy*term5k + qky*term6k 1867 & + qkx*term7k - qkr*term8k 1868 term2i = rr5*dmpi(5)*xr 1869 term1i = zr * term2i 1870 term1core = rr5*xr*zr 1871 term3i = rr5*dmpi(5)*zr 1872 term4i = zr * (rr7*dmpi(7)*xr) 1873 term5i = 2.0d0*rr5*dmpi(5) 1874 term6i = 2.0d0*rr7*dmpi(7)*xr 1875 term7i = 2.0d0*rr7*dmpi(7)*zr 1876 term8i = zr*rr9*dmpi(9)*xr 1877 term2k = rr5*dmpk(5)*xr 1878 term1k = zr * term2k 1879 term3k = rr5*dmpk(5)*zr 1880 term4k = zr * (rr7*dmpk(7)*xr) 1881 term5k = 2.0d0*rr5*dmpk(5) 1882 term6k = 2.0d0*rr7*dmpk(7)*xr 1883 term7k = 2.0d0*rr7*dmpk(7)*zr 1884 term8k = zr*rr9*dmpk(9)*xr 1885 tixz = -vali*term1i - corei*term1core 1886 & + diz*term2i + dix*term3i 1887 & - dir*term4i - qixz*term5i + qiz*term6i 1888 & + qix*term7i - qir*term8i 1889 tkxz = -valk*term1k - corek*term1core 1890 & - dkz*term2k - dkx*term3k 1891 & + dkr*term4k - qkxz*term5k + qkz*term6k 1892 & + qkx*term7k - qkr*term8k 1893 term2i = rr5*dmpi(5)*yr 1894 term1i = zr * term2i 1895 term1core = rr5*yr*zr 1896 term3i = rr5*dmpi(5)*zr 1897 term4i = zr * (rr7*dmpi(7)*yr) 1898 term5i = 2.0d0*rr5*dmpi(5) 1899 term6i = 2.0d0*rr7*dmpi(7)*yr 1900 term7i = 2.0d0*rr7*dmpi(7)*zr 1901 term8i = zr*rr9*dmpi(9)*yr 1902 term2k = rr5*dmpk(5)*yr 1903 term1k = zr * term2k 1904 term3k = rr5*dmpk(5)*zr 1905 term4k = zr * (rr7*dmpk(7)*yr) 1906 term5k = 2.0d0*rr5*dmpk(5) 1907 term6k = 2.0d0*rr7*dmpk(7)*yr 1908 term7k = 2.0d0*rr7*dmpk(7)*zr 1909 term8k = zr*rr9*dmpk(9)*yr 1910 tiyz = -vali*term1i - corei*term1core 1911 & + diz*term2i + diy*term3i 1912 & - dir*term4i - qiyz*term5i + qiz*term6i 1913 & + qiy*term7i - qir*term8i 1914 tkyz = -valk*term1k - corek*term1core 1915 & - dkz*term2k - dky*term3k 1916 & + dkr*term4k - qkyz*term5k + qkz*term6k 1917 & + qky*term7k - qkr*term8k 1918 end if 1919c 1920c get the dEd/dR terms for Thole direct polarization force 1921c 1922 if (use_thole) then 1923 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 1924 & - tkxx*uixp - tkxy*uiyp - tkxz*uizp 1925 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 1926 & - tkxy*uixp - tkyy*uiyp - tkyz*uizp 1927 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 1928 & - tkxz*uixp - tkyz*uiyp - tkzz*uizp 1929 frcx = dscale(k) * depx 1930 frcy = dscale(k) * depy 1931 frcz = dscale(k) * depz 1932c 1933c get the dEp/dR terms for Thole direct polarization force 1934c 1935 depx = tixx*ukx + tixy*uky + tixz*ukz 1936 & - tkxx*uix - tkxy*uiy - tkxz*uiz 1937 depy = tixy*ukx + tiyy*uky + tiyz*ukz 1938 & - tkxy*uix - tkyy*uiy - tkyz*uiz 1939 depz = tixz*ukx + tiyz*uky + tizz*ukz 1940 & - tkxz*uix - tkyz*uiy - tkzz*uiz 1941 frcx = frcx + pscale(k)*depx 1942 frcy = frcy + pscale(k)*depy 1943 frcz = frcz + pscale(k)*depz 1944c 1945c get the dEp/dR terms for chgpen direct polarization force 1946c 1947 else if (use_chgpen) then 1948 depx = tixx*ukx + tixy*uky + tixz*ukz 1949 & - tkxx*uix - tkxy*uiy - tkxz*uiz 1950 depy = tixy*ukx + tiyy*uky + tiyz*ukz 1951 & - tkxy*uix - tkyy*uiy - tkyz*uiz 1952 depz = tixz*ukx + tiyz*uky + tizz*ukz 1953 & - tkxz*uix - tkyz*uiy - tkzz*uiz 1954 frcx = 2.0d0*dscale(k)*depx 1955 frcy = 2.0d0*dscale(k)*depy 1956 frcz = 2.0d0*dscale(k)*depz 1957 end if 1958c 1959c reset Thole values if alternate direct damping was used 1960c 1961 if (use_dirdamp) then 1962 sc3 = 1.0d0 1963 sc5 = 1.0d0 1964 do j = 1, 3 1965 rc3(j) = 0.0d0 1966 rc5(j) = 0.0d0 1967 end do 1968 damp = pdi * pdamp(kk) 1969 if (damp .ne. 0.0d0) then 1970 pgamma = min(pti,thole(kk)) 1971 damp = pgamma * (r/damp)**3 1972 if (damp .lt. 50.0d0) then 1973 expdamp = exp(-damp) 1974 sc3 = 1.0d0 - expdamp 1975 sc5 = 1.0d0 - expdamp*(1.0d0+damp) 1976 temp3 = damp * expdamp * rr5 1977 temp5 = 3.0d0 * damp / r2 1978 rc3(1) = xr * temp3 1979 rc3(2) = yr * temp3 1980 rc3(3) = zr * temp3 1981 rc5(1) = rc3(1) * temp5 1982 rc5(2) = rc3(2) * temp5 1983 rc5(3) = rc3(3) * temp5 1984 end if 1985 end if 1986 end if 1987c 1988c get the dtau/dr terms used for mutual polarization force 1989c 1990 if (poltyp.eq.'MUTUAL' .and. use_thole) then 1991 term1 = (sc3+sc5) * rr5 1992 term2 = term1*xr - rc3(1) 1993 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 1994 tixx = uix*term2 + uir*term3 1995 tkxx = ukx*term2 + ukr*term3 1996 term2 = term1*yr - rc3(2) 1997 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 1998 tiyy = uiy*term2 + uir*term3 1999 tkyy = uky*term2 + ukr*term3 2000 term2 = term1*zr - rc3(3) 2001 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 2002 tizz = uiz*term2 + uir*term3 2003 tkzz = ukz*term2 + ukr*term3 2004 term1 = sc5 * rr5 * yr 2005 term2 = sc3*rr5*xr - rc3(1) 2006 term3 = yr * (sc5*rr7*xr-rc5(1)) 2007 tixy = uix*term1 + uiy*term2 - uir*term3 2008 tkxy = ukx*term1 + uky*term2 - ukr*term3 2009 term1 = sc5 * rr5 * zr 2010 term3 = zr * (sc5*rr7*xr-rc5(1)) 2011 tixz = uix*term1 + uiz*term2 - uir*term3 2012 tkxz = ukx*term1 + ukz*term2 - ukr*term3 2013 term2 = sc3*rr5*yr - rc3(2) 2014 term3 = zr * (sc5*rr7*yr-rc5(2)) 2015 tiyz = uiy*term1 + uiz*term2 - uir*term3 2016 tkyz = uky*term1 + ukz*term2 - ukr*term3 2017 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 2018 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 2019 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 2020 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 2021 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 2022 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 2023 frcx = frcx + uscale(kk)*depx 2024 frcy = frcy + uscale(kk)*depy 2025 frcz = frcz + uscale(kk)*depz 2026c 2027c get the dtau/dr terms used for mutual polarization force 2028c 2029 else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then 2030 term1 = 2.0d0 * dmpik(5) * rr5 2031 term2 = term1*xr 2032 term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 2033 tixx = uix*term2 + uir*term3 2034 tkxx = ukx*term2 + ukr*term3 2035 term2 = term1*yr 2036 term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 2037 tiyy = uiy*term2 + uir*term3 2038 tkyy = uky*term2 + ukr*term3 2039 term2 = term1*zr 2040 term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 2041 tizz = uiz*term2 + uir*term3 2042 tkzz = ukz*term2 + ukr*term3 2043 term1 = rr5*dmpik(5)*yr 2044 term2 = rr5*dmpik(5)*xr 2045 term3 = yr * (rr7*dmpik(7)*xr) 2046 tixy = uix*term1 + uiy*term2 - uir*term3 2047 tkxy = ukx*term1 + uky*term2 - ukr*term3 2048 term1 = rr5 *dmpik(5) * zr 2049 term3 = zr * (rr7*dmpik(7)*xr) 2050 tixz = uix*term1 + uiz*term2 - uir*term3 2051 tkxz = ukx*term1 + ukz*term2 - ukr*term3 2052 term2 = rr5*dmpik(5)*yr 2053 term3 = zr * (rr7*dmpik(7)*yr) 2054 tiyz = uiy*term1 + uiz*term2 - uir*term3 2055 tkyz = uky*term1 + ukz*term2 - ukr*term3 2056 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 2057 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 2058 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 2059 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 2060 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 2061 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 2062 frcx = frcx + wscale(kk)*depx 2063 frcy = frcy + wscale(kk)*depy 2064 frcz = frcz + wscale(kk)*depz 2065c 2066c get the dtau/dr terms used for OPT polarization force 2067c 2068 else if (poltyp.eq.'OPT' .and. use_thole) then 2069 do j = 0, optorder-1 2070 uirm = uopt(j,1,ii)*xr + uopt(j,2,ii)*yr 2071 & + uopt(j,3,ii)*zr 2072 do m = 0, optorder-j-1 2073 ukrm = uopt(m,1,kk)*xr + uopt(m,2,kk)*yr 2074 & + uopt(m,3,kk)*zr 2075 term1 = (sc3+sc5) * rr5 2076 term2 = term1*xr - rc3(1) 2077 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 2078 tixx = uopt(j,1,ii)*term2 + uirm*term3 2079 tkxx = uopt(m,1,kk)*term2 + ukrm*term3 2080 term2 = term1*yr - rc3(2) 2081 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 2082 tiyy = uopt(j,2,ii)*term2 + uirm*term3 2083 tkyy = uopt(m,2,kk)*term2 + ukrm*term3 2084 term2 = term1*zr - rc3(3) 2085 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 2086 tizz = uopt(j,3,ii)*term2 + uirm*term3 2087 tkzz = uopt(m,3,kk)*term2 + ukrm*term3 2088 term1 = sc5 * rr5 * yr 2089 term2 = sc3*rr5*xr - rc3(1) 2090 term3 = yr * (sc5*rr7*xr-rc5(1)) 2091 tixy = uopt(j,1,ii)*term1 + uopt(j,2,ii)*term2 2092 & - uirm*term3 2093 tkxy = uopt(m,1,kk)*term1 + uopt(m,2,kk)*term2 2094 & - ukrm*term3 2095 term1 = sc5 * rr5 * zr 2096 term3 = zr * (sc5*rr7*xr-rc5(1)) 2097 tixz = uopt(j,1,ii)*term1 + uopt(j,3,ii)*term2 2098 & - uirm*term3 2099 tkxz = uopt(m,1,kk)*term1 + uopt(m,3,kk)*term2 2100 & - ukrm*term3 2101 term2 = sc3*rr5*yr - rc3(2) 2102 term3 = zr * (sc5*rr7*yr-rc5(2)) 2103 tiyz = uopt(j,2,ii)*term1 + uopt(j,3,ii)*term2 2104 & - uirm*term3 2105 tkyz = uopt(m,2,kk)*term1 + uopt(m,3,kk)*term2 2106 & - ukrm*term3 2107 depx = tixx*uoptp(m,1,kk) + tkxx*uoptp(j,1,ii) 2108 & + tixy*uoptp(m,2,kk) + tkxy*uoptp(j,2,ii) 2109 & + tixz*uoptp(m,3,kk) + tkxz*uoptp(j,3,ii) 2110 depy = tixy*uoptp(m,1,kk) + tkxy*uoptp(j,1,ii) 2111 & + tiyy*uoptp(m,2,kk) + tkyy*uoptp(j,2,ii) 2112 & + tiyz*uoptp(m,3,kk) + tkyz*uoptp(j,3,ii) 2113 depz = tixz*uoptp(m,1,kk) + tkxz*uoptp(j,1,ii) 2114 & + tiyz*uoptp(m,2,kk) + tkyz*uoptp(j,2,ii) 2115 & + tizz*uoptp(m,3,kk) + tkzz*uoptp(j,3,ii) 2116 frcx = frcx + copm(j+m+1)*uscale(k)*depx 2117 frcy = frcy + copm(j+m+1)*uscale(k)*depy 2118 frcz = frcz + copm(j+m+1)*uscale(k)*depz 2119 end do 2120 end do 2121c 2122c get the dtau/dr terms used for OPT polarization force 2123c 2124 else if (poltyp.eq.'OPT' .and. use_chgpen) then 2125 do j = 0, optorder-1 2126 uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr 2127 & + uopt(j,3,i)*zr 2128 do m = 0, optorder-j-1 2129 ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr 2130 & + uopt(m,3,k)*zr 2131 term1 = 2.0d0 * dmpik(5) * rr5 2132 term2 = term1*xr 2133 term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 2134 tixx = uopt(j,1,i)*term2 + uirm*term3 2135 tkxx = uopt(m,1,k)*term2 + ukrm*term3 2136 term2 = term1*yr 2137 term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 2138 tiyy = uopt(j,2,i)*term2 + uirm*term3 2139 tkyy = uopt(m,2,k)*term2 + ukrm*term3 2140 term2 = term1*zr 2141 term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 2142 tizz = uopt(j,3,i)*term2 + uirm*term3 2143 tkzz = uopt(m,3,k)*term2 + ukrm*term3 2144 term1 = rr5*dmpik(5)*yr 2145 term2 = rr5*dmpik(5)*xr 2146 term3 = yr * (rr7*dmpik(7)*xr) 2147 tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2 2148 & - uirm*term3 2149 tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2 2150 & - ukrm*term3 2151 term1 = rr5 *dmpik(5) * zr 2152 term3 = zr * (rr7*dmpik(7)*xr) 2153 tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2 2154 & - uirm*term3 2155 tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2 2156 & - ukrm*term3 2157 term2 = rr5*dmpik(5)*yr 2158 term3 = zr * (rr7*dmpik(7)*yr) 2159 tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2 2160 & - uirm*term3 2161 tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2 2162 & - ukrm*term3 2163 depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i) 2164 & + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i) 2165 & + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i) 2166 depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i) 2167 & + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i) 2168 & + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i) 2169 depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i) 2170 & + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i) 2171 & + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i) 2172 frcx = frcx + copm(j+m+1)*wscale(k)*depx 2173 frcy = frcy + copm(j+m+1)*wscale(k)*depy 2174 frcz = frcz + copm(j+m+1)*wscale(k)*depz 2175 end do 2176 end do 2177c 2178c get the dtau/dr terms used for TCG polarization force 2179c 2180 else if (poltyp.eq.'TCG' .and. use_thole) then 2181 do j = 1, tcgnab 2182 ukx = ubd(1,kk,j) 2183 uky = ubd(2,kk,j) 2184 ukz = ubd(3,kk,j) 2185 ukxp = ubp(1,kk,j) 2186 ukyp = ubp(2,kk,j) 2187 ukzp = ubp(3,kk,j) 2188 uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr 2189 ukrt = ukx*xr + uky*yr + ukz*zr 2190 term1 = (sc3+sc5) * rr5 2191 term2 = term1*xr - rc3(1) 2192 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 2193 tixx = uax(j)*term2 + uirt*term3 2194 tkxx = ukx*term2 + ukrt*term3 2195 term2 = term1*yr - rc3(2) 2196 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 2197 tiyy = uay(j)*term2 + uirt*term3 2198 tkyy = uky*term2 + ukrt*term3 2199 term2 = term1*zr - rc3(3) 2200 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 2201 tizz = uaz(j)*term2 + uirt*term3 2202 tkzz = ukz*term2 + ukrt*term3 2203 term1 = sc5 * rr5 * yr 2204 term2 = sc3*rr5*xr - rc3(1) 2205 term3 = yr * (sc5*rr7*xr-rc5(1)) 2206 tixy = uax(j)*term1 + uay(j)*term2 - uirt*term3 2207 tkxy = ukx*term1 + uky*term2 - ukrt*term3 2208 term1 = sc5 * rr5 * zr 2209 term3 = zr * (sc5*rr7*xr-rc5(1)) 2210 tixz = uax(j)*term1 + uaz(j)*term2 - uirt*term3 2211 tkxz = ukx*term1 + ukz*term2 - ukrt*term3 2212 term2 = sc3*rr5*yr - rc3(2) 2213 term3 = zr * (sc5*rr7*yr-rc5(2)) 2214 tiyz = uay(j)*term1 + uaz(j)*term2 - uirt*term3 2215 tkyz = uky*term1 + ukz*term2 - ukrt*term3 2216 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 2217 & + tkxx*uaxp(j) + tkxy*uayp(j) 2218 & + tkxz*uazp(j) 2219 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 2220 & + tkxy*uaxp(j) + tkyy*uayp(j) 2221 & + tkyz*uazp(j) 2222 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 2223 & + tkxz*uaxp(j) + tkyz*uayp(j) 2224 & + tkzz*uazp(j) 2225 frcx = frcx + uscale(k)*depx 2226 frcy = frcy + uscale(k)*depy 2227 frcz = frcz + uscale(k)*depz 2228 ukx = uad(1,kk,j) 2229 uky = uad(2,kk,j) 2230 ukz = uad(3,kk,j) 2231 ukxp = uap(1,kk,j) 2232 ukyp = uap(2,kk,j) 2233 ukzp = uap(3,kk,j) 2234 uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr 2235 ukrt = ukx*xr + uky*yr + ukz*zr 2236 term1 = (sc3+sc5) * rr5 2237 term2 = term1*xr - rc3(1) 2238 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 2239 tixx = ubx(j)*term2 + uirt*term3 2240 tkxx = ukx*term2 + ukrt*term3 2241 term2 = term1*yr - rc3(2) 2242 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 2243 tiyy = uby(j)*term2 + uirt*term3 2244 tkyy = uky*term2 + ukrt*term3 2245 term2 = term1*zr - rc3(3) 2246 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 2247 tizz = ubz(j)*term2 + uirt*term3 2248 tkzz = ukz*term2 + ukrt*term3 2249 term1 = sc5 * rr5 * yr 2250 term2 = sc3*rr5*xr - rc3(1) 2251 term3 = yr * (sc5*rr7*xr-rc5(1)) 2252 tixy = ubx(j)*term1 + uby(j)*term2 - uirt*term3 2253 tkxy = ukx*term1 + uky*term2 - ukrt*term3 2254 term1 = sc5 * rr5 * zr 2255 term3 = zr * (sc5*rr7*xr-rc5(1)) 2256 tixz = ubx(j)*term1 + ubz(j)*term2 - uirt*term3 2257 tkxz = ukx*term1 + ukz*term2 - ukrt*term3 2258 term2 = sc3*rr5*yr - rc3(2) 2259 term3 = zr * (sc5*rr7*yr-rc5(2)) 2260 tiyz = uby(j)*term1 + ubz(j)*term2 - uirt*term3 2261 tkyz = uky*term1 + ukz*term2 - ukrt*term3 2262 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 2263 & + tkxx*ubxp(j) + tkxy*ubyp(j) 2264 & + tkxz*ubzp(j) 2265 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 2266 & + tkxy*ubxp(j) + tkyy*ubyp(j) 2267 & + tkyz*ubzp(j) 2268 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 2269 & + tkxz*ubxp(j) + tkyz*ubyp(j) 2270 & + tkzz*ubzp(j) 2271 frcx = frcx + uscale(k)*depx 2272 frcy = frcy + uscale(k)*depy 2273 frcz = frcz + uscale(k)*depz 2274 end do 2275 end if 2276c 2277c force and torque components scaled for self-interactions 2278c 2279 if (i .eq. k) then 2280 frcx = 0.5d0 * frcx 2281 frcy = 0.5d0 * frcy 2282 frcz = 0.5d0 * frcz 2283 psr3 = 0.5d0 * psr3 2284 psr5 = 0.5d0 * psr5 2285 psr7 = 0.5d0 * psr7 2286 dsr3 = 0.5d0 * dsr3 2287 dsr5 = 0.5d0 * dsr5 2288 dsr7 = 0.5d0 * dsr7 2289 end if 2290c 2291c increment force-based gradient on the interaction sites 2292c 2293 dep(1,i) = dep(1,i) + frcx 2294 dep(2,i) = dep(2,i) + frcy 2295 dep(3,i) = dep(3,i) + frcz 2296 dep(1,k) = dep(1,k) - frcx 2297 dep(2,k) = dep(2,k) - frcy 2298 dep(3,k) = dep(3,k) - frcz 2299c 2300c increment the virial due to pairwise Cartesian forces 2301c 2302 vxx = -xr * frcx 2303 vxy = -0.5d0 * (yr*frcx+xr*frcy) 2304 vxz = -0.5d0 * (zr*frcx+xr*frcz) 2305 vyy = -yr * frcy 2306 vyz = -0.5d0 * (zr*frcy+yr*frcz) 2307 vzz = -zr * frcz 2308 vir(1,1) = vir(1,1) + vxx 2309 vir(2,1) = vir(2,1) + vxy 2310 vir(3,1) = vir(3,1) + vxz 2311 vir(1,2) = vir(1,2) + vxy 2312 vir(2,2) = vir(2,2) + vyy 2313 vir(3,2) = vir(3,2) + vyz 2314 vir(1,3) = vir(1,3) + vxz 2315 vir(2,3) = vir(2,3) + vyz 2316 vir(3,3) = vir(3,3) + vzz 2317 end if 2318 end do 2319 end do 2320c 2321c reset exclusion coefficients for connected atoms 2322c 2323 if (dpequal) then 2324 do j = 1, n12(i) 2325 pscale(i12(j,i)) = 1.0d0 2326 dscale(i12(j,i)) = 1.0d0 2327 wscale(i12(j,i)) = 1.0d0 2328 end do 2329 do j = 1, n13(i) 2330 pscale(i13(j,i)) = 1.0d0 2331 dscale(i13(j,i)) = 1.0d0 2332 wscale(i13(j,i)) = 1.0d0 2333 end do 2334 do j = 1, n14(i) 2335 pscale(i14(j,i)) = 1.0d0 2336 dscale(i14(j,i)) = 1.0d0 2337 wscale(i14(j,i)) = 1.0d0 2338 end do 2339 do j = 1, n15(i) 2340 pscale(i15(j,i)) = 1.0d0 2341 dscale(i15(j,i)) = 1.0d0 2342 wscale(i15(j,i)) = 1.0d0 2343 end do 2344 do j = 1, np11(i) 2345 uscale(ip11(j,i)) = 1.0d0 2346 end do 2347 do j = 1, np12(i) 2348 uscale(ip12(j,i)) = 1.0d0 2349 end do 2350 do j = 1, np13(i) 2351 uscale(ip13(j,i)) = 1.0d0 2352 end do 2353 do j = 1, np14(i) 2354 uscale(ip14(j,i)) = 1.0d0 2355 end do 2356 else 2357 do j = 1, n12(i) 2358 pscale(i12(j,i)) = 1.0d0 2359 wscale(i12(j,i)) = 1.0d0 2360 end do 2361 do j = 1, n13(i) 2362 pscale(i13(j,i)) = 1.0d0 2363 wscale(i13(j,i)) = 1.0d0 2364 end do 2365 do j = 1, n14(i) 2366 pscale(i14(j,i)) = 1.0d0 2367 wscale(i14(j,i)) = 1.0d0 2368 end do 2369 do j = 1, n15(i) 2370 pscale(i15(j,i)) = 1.0d0 2371 wscale(i15(j,i)) = 1.0d0 2372 end do 2373 do j = 1, np11(i) 2374 dscale(ip11(j,i)) = 1.0d0 2375 uscale(ip11(j,i)) = 1.0d0 2376 end do 2377 do j = 1, np12(i) 2378 dscale(ip12(j,i)) = 1.0d0 2379 uscale(ip12(j,i)) = 1.0d0 2380 end do 2381 do j = 1, np13(i) 2382 dscale(ip13(j,i)) = 1.0d0 2383 uscale(ip13(j,i)) = 1.0d0 2384 end do 2385 do j = 1, np14(i) 2386 dscale(ip14(j,i)) = 1.0d0 2387 uscale(ip14(j,i)) = 1.0d0 2388 end do 2389 end if 2390 end do 2391 end if 2392c 2393c torque is induced field and gradient cross permanent moments 2394c 2395 do ii = 1, npole 2396 i = ipole(ii) 2397 dix = rpole(2,ii) 2398 diy = rpole(3,ii) 2399 diz = rpole(4,ii) 2400 qixx = rpole(5,ii) 2401 qixy = rpole(6,ii) 2402 qixz = rpole(7,ii) 2403 qiyy = rpole(9,ii) 2404 qiyz = rpole(10,ii) 2405 qizz = rpole(13,ii) 2406 tep(1) = diz*ufld(2,i) - diy*ufld(3,i) 2407 & + qixz*dufld(2,i) - qixy*dufld(4,i) 2408 & + 2.0d0*qiyz*(dufld(3,i)-dufld(6,i)) 2409 & + (qizz-qiyy)*dufld(5,i) 2410 tep(2) = dix*ufld(3,i) - diz*ufld(1,i) 2411 & - qiyz*dufld(2,i) + qixy*dufld(5,i) 2412 & + 2.0d0*qixz*(dufld(6,i)-dufld(1,i)) 2413 & + (qixx-qizz)*dufld(4,i) 2414 tep(3) = diy*ufld(1,i) - dix*ufld(2,i) 2415 & + qiyz*dufld(4,i) - qixz*dufld(5,i) 2416 & + 2.0d0*qixy*(dufld(1,i)-dufld(3,i)) 2417 & + (qiyy-qixx)*dufld(2,i) 2418 call torque (ii,tep,fix,fiy,fiz,dep) 2419 iz = zaxis(ii) 2420 ix = xaxis(ii) 2421 iy = abs(yaxis(ii)) 2422 if (iz .eq. 0) iz = i 2423 if (ix .eq. 0) ix = i 2424 if (iy .eq. 0) iy = i 2425 xiz = x(iz) - x(i) 2426 yiz = y(iz) - y(i) 2427 ziz = z(iz) - z(i) 2428 xix = x(ix) - x(i) 2429 yix = y(ix) - y(i) 2430 zix = z(ix) - z(i) 2431 xiy = x(iy) - x(i) 2432 yiy = y(iy) - y(i) 2433 ziy = z(iy) - z(i) 2434 vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1) 2435 vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1) 2436 & + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2)) 2437 vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1) 2438 & + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 2439 vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2) 2440 vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2) 2441 & + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3)) 2442 vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3) 2443 vir(1,1) = vir(1,1) + vxx 2444 vir(2,1) = vir(2,1) + vxy 2445 vir(3,1) = vir(3,1) + vxz 2446 vir(1,2) = vir(1,2) + vxy 2447 vir(2,2) = vir(2,2) + vyy 2448 vir(3,2) = vir(3,2) + vyz 2449 vir(1,3) = vir(1,3) + vxz 2450 vir(2,3) = vir(2,3) + vyz 2451 vir(3,3) = vir(3,3) + vzz 2452 end do 2453c 2454c modify the gradient and virial for charge flux 2455c 2456 if (use_chgflx) then 2457 call dcflux (pot,decfx,decfy,decfz) 2458 do ii = 1, npole 2459 i = ipole(ii) 2460 xi = x(i) 2461 yi = y(i) 2462 zi = z(i) 2463 frcx = decfx(i) 2464 frcy = decfy(i) 2465 frcz = decfz(i) 2466 dep(1,i) = dep(1,i) + frcx 2467 dep(2,i) = dep(2,i) + frcy 2468 dep(3,i) = dep(3,i) + frcz 2469 vxx = xi * frcx 2470 vxy = yi * frcx 2471 vxz = zi * frcx 2472 vyy = yi * frcy 2473 vyz = zi * frcy 2474 vzz = zi * frcz 2475 vir(1,1) = vir(1,1) + vxx 2476 vir(2,1) = vir(2,1) + vxy 2477 vir(3,1) = vir(3,1) + vxz 2478 vir(1,2) = vir(1,2) + vxy 2479 vir(2,2) = vir(2,2) + vyy 2480 vir(3,2) = vir(3,2) + vyz 2481 vir(1,3) = vir(1,3) + vxz 2482 vir(2,3) = vir(2,3) + vyz 2483 vir(3,3) = vir(3,3) + vzz 2484 end do 2485 end if 2486c 2487c perform deallocation of some local arrays 2488c 2489 deallocate (pscale) 2490 deallocate (dscale) 2491 deallocate (uscale) 2492 deallocate (wscale) 2493 deallocate (ufld) 2494 deallocate (dufld) 2495 deallocate (pot) 2496 deallocate (decfx) 2497 deallocate (decfy) 2498 deallocate (decfz) 2499 return 2500 end 2501c 2502c 2503c ################################################################## 2504c ## ## 2505c ## subroutine epolar1b -- neighbor list polarization derivs ## 2506c ## ## 2507c ################################################################## 2508c 2509c 2510c "epolar1b" calculates the dipole polarization energy and 2511c derivatives with respect to Cartesian coordinates using a 2512c neighbor list 2513c 2514c 2515 subroutine epolar1b 2516 use atoms 2517 use bound 2518 use chgpen 2519 use chgpot 2520 use couple 2521 use deriv 2522 use energi 2523 use molcul 2524 use mplpot 2525 use mpole 2526 use neigh 2527 use polar 2528 use polgrp 2529 use polopt 2530 use polpot 2531 use poltcg 2532 use potent 2533 use shunt 2534 use virial 2535 implicit none 2536 integer i,j,k,m 2537 integer ii,kk,kkk 2538 integer ix,iy,iz 2539 real*8 f,pgamma 2540 real*8 pdi,pti,ddi 2541 real*8 damp,expdamp 2542 real*8 temp3,temp5,temp7 2543 real*8 sc3,sc5,sc7 2544 real*8 sr3,sr5,sr7 2545 real*8 psr3,psr5,psr7 2546 real*8 dsr3,dsr5,dsr7 2547 real*8 dsr3i,dsr5i,dsr7i 2548 real*8 dsr3k,dsr5k,dsr7k 2549 real*8 xi,yi,zi 2550 real*8 xr,yr,zr 2551 real*8 r,r2,rr1,rr3 2552 real*8 rr5,rr7,rr9 2553 real*8 ci,dix,diy,diz 2554 real*8 qixx,qixy,qixz 2555 real*8 qiyy,qiyz,qizz 2556 real*8 uix,uiy,uiz 2557 real*8 uixp,uiyp,uizp 2558 real*8 ck,dkx,dky,dkz 2559 real*8 qkxx,qkxy,qkxz 2560 real*8 qkyy,qkyz,qkzz 2561 real*8 ukx,uky,ukz 2562 real*8 ukxp,ukyp,ukzp 2563 real*8 dir,uir,uirp 2564 real*8 dkr,ukr,ukrp 2565 real*8 qix,qiy,qiz,qir 2566 real*8 qkx,qky,qkz,qkr 2567 real*8 corei,corek 2568 real*8 vali,valk 2569 real*8 alphai,alphak 2570 real*8 uirm,ukrm 2571 real*8 uirt,ukrt 2572 real*8 tuir,tukr 2573 real*8 tixx,tiyy,tizz 2574 real*8 tixy,tixz,tiyz 2575 real*8 tkxx,tkyy,tkzz 2576 real*8 tkxy,tkxz,tkyz 2577 real*8 tix3,tiy3,tiz3 2578 real*8 tix5,tiy5,tiz5 2579 real*8 tkx3,tky3,tkz3 2580 real*8 tkx5,tky5,tkz5 2581 real*8 term1,term2,term3 2582 real*8 term4,term5,term6 2583 real*8 term7,term8 2584 real*8 term1core 2585 real*8 term1i,term2i,term3i 2586 real*8 term4i,term5i,term6i 2587 real*8 term7i,term8i 2588 real*8 term1k,term2k,term3k 2589 real*8 term4k,term5k,term6k 2590 real*8 term7k,term8k 2591 real*8 poti,potk 2592 real*8 depx,depy,depz 2593 real*8 frcx,frcy,frcz 2594 real*8 xix,yix,zix 2595 real*8 xiy,yiy,ziy 2596 real*8 xiz,yiz,ziz 2597 real*8 vxx,vyy,vzz 2598 real*8 vxy,vxz,vyz 2599 real*8 rc3(3),rc5(3),rc7(3) 2600 real*8 tep(3),fix(3) 2601 real*8 fiy(3),fiz(3) 2602 real*8 uax(3),uay(3),uaz(3) 2603 real*8 ubx(3),uby(3),ubz(3) 2604 real*8 uaxp(3),uayp(3),uazp(3) 2605 real*8 ubxp(3),ubyp(3),ubzp(3) 2606 real*8 dmpi(9),dmpk(9) 2607 real*8 dmpik(9) 2608 real*8, allocatable :: pscale(:) 2609 real*8, allocatable :: dscale(:) 2610 real*8, allocatable :: uscale(:) 2611 real*8, allocatable :: wscale(:) 2612 real*8, allocatable :: ufld(:,:) 2613 real*8, allocatable :: dufld(:,:) 2614 real*8, allocatable :: pot(:) 2615 real*8, allocatable :: decfx(:) 2616 real*8, allocatable :: decfy(:) 2617 real*8, allocatable :: decfz(:) 2618 character*6 mode 2619c 2620c 2621c zero out the polarization energy and derivatives 2622c 2623 ep = 0.0d0 2624 do i = 1, n 2625 do j = 1, 3 2626 dep(j,i) = 0.0d0 2627 end do 2628 end do 2629 if (npole .eq. 0) return 2630c 2631c check the sign of multipole components at chiral sites 2632c 2633 if (.not. use_mpole) call chkpole 2634c 2635c rotate the multipole components into the global frame 2636c 2637 if (.not. use_mpole) call rotpole 2638c 2639c compute the induced dipoles at each polarizable atom 2640c 2641 call induce 2642c 2643c compute the total induced dipole polarization energy 2644c 2645 call epolar1e 2646c 2647c perform dynamic allocation of some local arrays 2648c 2649 allocate (pscale(n)) 2650 allocate (dscale(n)) 2651 allocate (uscale(n)) 2652 allocate (wscale(n)) 2653 allocate (ufld(3,n)) 2654 allocate (dufld(6,n)) 2655 allocate (pot(n)) 2656 allocate (decfx(n)) 2657 allocate (decfy(n)) 2658 allocate (decfz(n)) 2659c 2660c set exclusion coefficients and arrays to store fields 2661c 2662 do i = 1, n 2663 pscale(i) = 1.0d0 2664 dscale(i) = 1.0d0 2665 uscale(i) = 1.0d0 2666 wscale(i) = 1.0d0 2667 do j = 1, 3 2668 ufld(j,i) = 0.0d0 2669 end do 2670 do j = 1, 6 2671 dufld(j,i) = 0.0d0 2672 end do 2673 pot(i) = 0.0d0 2674 end do 2675c 2676c set conversion factor, cutoff and switching coefficients 2677c 2678 f = 0.5d0 * electric / dielec 2679 mode = 'MPOLE' 2680 call switch (mode) 2681c 2682c OpenMP directives for the major loop structure 2683c 2684!$OMP PARALLEL default(private) shared(npole,ipole,x,y,z,rpole,uind, 2685!$OMP& uinp,pdamp,thole,dirdamp,pcore,pval,palpha,n12,i12,n13,i13,n14, 2686!$OMP& i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14,p2scale, 2687!$OMP& p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,p5iscale, 2688!$OMP& d1scale,d2scale,d3scale,d4scale,u1scale,u2scale,u3scale,u4scale, 2689!$OMP& w2scale,w3scale,w4scale,w5scale,nelst,elst,dpequal,use_thole, 2690!$OMP& use_dirdamp,use_chgpen,use_chgflx,use_bounds,off2,f,molcule, 2691!$OMP& optorder,copm,uopt,uoptp,poltyp,tcgnab,uad,uap,ubd,ubp, 2692!$OMP& xaxis,yaxis,zaxis) 2693!$OMP& shared (dep,ufld,dufld,pot,vir) 2694!$OMP& firstprivate(pscale,dscale,uscale,wscale) 2695!$OMP DO reduction(+:dep,ufld,dufld,pot,vir) schedule(guided) 2696c 2697c compute the dipole polarization gradient components 2698c 2699 do ii = 1, npole 2700 i = ipole(ii) 2701 xi = x(i) 2702 yi = y(i) 2703 zi = z(i) 2704 ci = rpole(1,ii) 2705 dix = rpole(2,ii) 2706 diy = rpole(3,ii) 2707 diz = rpole(4,ii) 2708 qixx = rpole(5,ii) 2709 qixy = rpole(6,ii) 2710 qixz = rpole(7,ii) 2711 qiyy = rpole(9,ii) 2712 qiyz = rpole(10,ii) 2713 qizz = rpole(13,ii) 2714 uix = uind(1,ii) 2715 uiy = uind(2,ii) 2716 uiz = uind(3,ii) 2717 uixp = uinp(1,ii) 2718 uiyp = uinp(2,ii) 2719 uizp = uinp(3,ii) 2720 do j = 1, tcgnab 2721 uax(j) = uad(1,ii,j) 2722 uay(j) = uad(2,ii,j) 2723 uaz(j) = uad(3,ii,j) 2724 uaxp(j) = uap(1,ii,j) 2725 uayp(j) = uap(2,ii,j) 2726 uazp(j) = uap(3,ii,j) 2727 ubx(j) = ubd(1,ii,j) 2728 uby(j) = ubd(2,ii,j) 2729 ubz(j) = ubd(3,ii,j) 2730 ubxp(j) = ubp(1,ii,j) 2731 ubyp(j) = ubp(2,ii,j) 2732 ubzp(j) = ubp(3,ii,j) 2733 end do 2734 if (use_thole) then 2735 pdi = pdamp(ii) 2736 pti = thole(ii) 2737 ddi = dirdamp(ii) 2738 else if (use_chgpen) then 2739 corei = pcore(ii) 2740 vali = pval(ii) 2741 alphai = palpha(ii) 2742 end if 2743c 2744c set exclusion coefficients for connected atoms 2745c 2746 if (dpequal) then 2747 do j = 1, n12(i) 2748 pscale(i12(j,i)) = p2scale 2749 do k = 1, np11(i) 2750 if (i12(j,i) .eq. ip11(k,i)) 2751 & pscale(i12(j,i)) = p2iscale 2752 end do 2753 dscale(i12(j,i)) = pscale(i12(j,i)) 2754 wscale(i12(j,i)) = w2scale 2755 end do 2756 do j = 1, n13(i) 2757 pscale(i13(j,i)) = p3scale 2758 do k = 1, np11(i) 2759 if (i13(j,i) .eq. ip11(k,i)) 2760 & pscale(i13(j,i)) = p3iscale 2761 end do 2762 dscale(i13(j,i)) = pscale(i13(j,i)) 2763 wscale(i13(j,i)) = w3scale 2764 end do 2765 do j = 1, n14(i) 2766 pscale(i14(j,i)) = p4scale 2767 do k = 1, np11(i) 2768 if (i14(j,i) .eq. ip11(k,i)) 2769 & pscale(i14(j,i)) = p4iscale 2770 end do 2771 dscale(i14(j,i)) = pscale(i14(j,i)) 2772 wscale(i14(j,i)) = w4scale 2773 end do 2774 do j = 1, n15(i) 2775 pscale(i15(j,i)) = p5scale 2776 do k = 1, np11(i) 2777 if (i15(j,i) .eq. ip11(k,i)) 2778 & pscale(i15(j,i)) = p5iscale 2779 end do 2780 dscale(i15(j,i)) = pscale(i15(j,i)) 2781 wscale(i15(j,i)) = w5scale 2782 end do 2783 do j = 1, np11(i) 2784 uscale(ip11(j,i)) = u1scale 2785 end do 2786 do j = 1, np12(i) 2787 uscale(ip12(j,i)) = u2scale 2788 end do 2789 do j = 1, np13(i) 2790 uscale(ip13(j,i)) = u3scale 2791 end do 2792 do j = 1, np14(i) 2793 uscale(ip14(j,i)) = u4scale 2794 end do 2795 else 2796 do j = 1, n12(i) 2797 pscale(i12(j,i)) = p2scale 2798 do k = 1, np11(i) 2799 if (i12(j,i) .eq. ip11(k,i)) 2800 & pscale(i12(j,i)) = p2iscale 2801 end do 2802 wscale(i12(j,i)) = w2scale 2803 end do 2804 do j = 1, n13(i) 2805 pscale(i13(j,i)) = p3scale 2806 do k = 1, np11(i) 2807 if (i13(j,i) .eq. ip11(k,i)) 2808 & pscale(i13(j,i)) = p3iscale 2809 end do 2810 wscale(i13(j,i)) = w3scale 2811 end do 2812 do j = 1, n14(i) 2813 pscale(i14(j,i)) = p4scale 2814 do k = 1, np11(i) 2815 if (i14(j,i) .eq. ip11(k,i)) 2816 & pscale(i14(j,i)) = p4iscale 2817 end do 2818 wscale(i14(j,i)) = w4scale 2819 end do 2820 do j = 1, n15(i) 2821 pscale(i15(j,i)) = p5scale 2822 do k = 1, np11(i) 2823 if (i15(j,i) .eq. ip11(k,i)) 2824 & pscale(i15(j,i)) = p5iscale 2825 end do 2826 wscale(i15(j,i)) = w5scale 2827 end do 2828 do j = 1, np11(i) 2829 dscale(ip11(j,i)) = d1scale 2830 uscale(ip11(j,i)) = u1scale 2831 end do 2832 do j = 1, np12(i) 2833 dscale(ip12(j,i)) = d2scale 2834 uscale(ip12(j,i)) = u2scale 2835 end do 2836 do j = 1, np13(i) 2837 dscale(ip13(j,i)) = d3scale 2838 uscale(ip13(j,i)) = u3scale 2839 end do 2840 do j = 1, np14(i) 2841 dscale(ip14(j,i)) = d4scale 2842 uscale(ip14(j,i)) = u4scale 2843 end do 2844 end if 2845c 2846c evaluate all sites within the cutoff distance 2847c 2848 do kkk = 1, nelst(ii) 2849 kk = elst(kkk,ii) 2850 k = ipole(kk) 2851 xr = x(k) - xi 2852 yr = y(k) - yi 2853 zr = z(k) - zi 2854 if (use_bounds) call image (xr,yr,zr) 2855 r2 = xr*xr + yr*yr + zr*zr 2856 if (r2 .le. off2) then 2857 r = sqrt(r2) 2858 ck = rpole(1,kk) 2859 dkx = rpole(2,kk) 2860 dky = rpole(3,kk) 2861 dkz = rpole(4,kk) 2862 qkxx = rpole(5,kk) 2863 qkxy = rpole(6,kk) 2864 qkxz = rpole(7,kk) 2865 qkyy = rpole(9,kk) 2866 qkyz = rpole(10,kk) 2867 qkzz = rpole(13,kk) 2868 ukx = uind(1,kk) 2869 uky = uind(2,kk) 2870 ukz = uind(3,kk) 2871 ukxp = uinp(1,kk) 2872 ukyp = uinp(2,kk) 2873 ukzp = uinp(3,kk) 2874c 2875c intermediates involving moments and separation distance 2876c 2877 dir = dix*xr + diy*yr + diz*zr 2878 qix = qixx*xr + qixy*yr + qixz*zr 2879 qiy = qixy*xr + qiyy*yr + qiyz*zr 2880 qiz = qixz*xr + qiyz*yr + qizz*zr 2881 qir = qix*xr + qiy*yr + qiz*zr 2882 dkr = dkx*xr + dky*yr + dkz*zr 2883 qkx = qkxx*xr + qkxy*yr + qkxz*zr 2884 qky = qkxy*xr + qkyy*yr + qkyz*zr 2885 qkz = qkxz*xr + qkyz*yr + qkzz*zr 2886 qkr = qkx*xr + qky*yr + qkz*zr 2887 uir = uix*xr + uiy*yr + uiz*zr 2888 uirp = uixp*xr + uiyp*yr + uizp*zr 2889 ukr = ukx*xr + uky*yr + ukz*zr 2890 ukrp = ukxp*xr + ukyp*yr + ukzp*zr 2891c 2892c get reciprocal distance terms for this interaction 2893c 2894 rr1 = f / r 2895 rr3 = rr1 / r2 2896 rr5 = 3.0d0 * rr3 / r2 2897 rr7 = 5.0d0 * rr5 / r2 2898 rr9 = 7.0d0 * rr7 / r2 2899c 2900c set initial values for tha damping scale factors 2901c 2902 sc3 = 1.0d0 2903 sc5 = 1.0d0 2904 sc7 = 1.0d0 2905 do j = 1, 3 2906 rc3(j) = 0.0d0 2907 rc5(j) = 0.0d0 2908 rc7(j) = 0.0d0 2909 end do 2910c 2911c apply Thole polarization damping to scale factors 2912c 2913 if (use_thole) then 2914 damp = pdi * pdamp(kk) 2915 if (use_dirdamp) then 2916 pgamma = min(ddi,dirdamp(kk)) 2917 if (pgamma .eq. 0.0d0) then 2918 pgamma = max(ddi,dirdamp(kk)) 2919 end if 2920 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 2921 damp = pgamma * (r/damp)**(1.5d0) 2922 if (damp .lt. 50.0d0) then 2923 expdamp = exp(-damp) 2924 sc3 = 1.0d0 - expdamp 2925 sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp) 2926 sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp 2927 & +0.15d0*damp**2) 2928 temp3 = 0.5d0 * damp * expdamp 2929 temp5 = 1.5d0 * (1.0d0+damp) 2930 temp7 = 5.0d0*(1.5d0*damp*expdamp 2931 & *(0.35d0+0.35d0*damp 2932 & +0.15d0*damp**2))/(temp3*temp5) 2933 temp3 = temp3 * rr5 2934 temp5 = temp5 / r2 2935 temp7 = temp7 / r2 2936 rc3(1) = xr * temp3 2937 rc3(2) = yr * temp3 2938 rc3(3) = zr * temp3 2939 rc5(1) = rc3(1) * temp5 2940 rc5(2) = rc3(2) * temp5 2941 rc5(3) = rc3(3) * temp5 2942 rc7(1) = rc5(1) * temp7 2943 rc7(2) = rc5(2) * temp7 2944 rc7(3) = rc5(3) * temp7 2945 end if 2946 end if 2947 else 2948 pgamma = min(pti,thole(kk)) 2949 if (pgamma .eq. 0.0d0) then 2950 pgamma = max(pti,thole(kk)) 2951 end if 2952 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 2953 damp = pgamma * (r/damp)**3 2954 if (damp .lt. 50.0d0) then 2955 expdamp = exp(-damp) 2956 sc3 = 1.0d0 - expdamp 2957 sc5 = 1.0d0 - expdamp*(1.0d0+damp) 2958 sc7 = 1.0d0 - expdamp*(1.0d0+damp 2959 & +0.6d0*damp**2) 2960 temp3 = damp * expdamp * rr5 2961 temp5 = 3.0d0 * damp / r2 2962 temp7 = (-1.0d0+3.0d0*damp) / r2 2963 rc3(1) = xr * temp3 2964 rc3(2) = yr * temp3 2965 rc3(3) = zr * temp3 2966 rc5(1) = rc3(1) * temp5 2967 rc5(2) = rc3(2) * temp5 2968 rc5(3) = rc3(3) * temp5 2969 rc7(1) = rc5(1) * temp7 2970 rc7(2) = rc5(2) * temp7 2971 rc7(3) = rc5(3) * temp7 2972 end if 2973 end if 2974 end if 2975 sr3 = rr3 * sc3 2976 sr5 = rr5 * sc5 2977 sr7 = rr7 * sc7 2978 dsr3 = sr3 * dscale(k) 2979 dsr5 = sr5 * dscale(k) 2980 dsr7 = sr7 * dscale(k) 2981 psr3 = sr3 * pscale(k) 2982 psr5 = sr5 * pscale(k) 2983 psr7 = sr7 * pscale(k) 2984c 2985c apply charge penetration damping to scale factors 2986c 2987 else if (use_chgpen) then 2988 corek = pcore(kk) 2989 valk = pval(kk) 2990 alphak = palpha(kk) 2991 call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik) 2992 dsr3i = 2.0d0 * rr3 * dmpi(3) * dscale(k) 2993 dsr5i = 2.0d0 * rr5 * dmpi(5) * dscale(k) 2994 dsr7i = 2.0d0 * rr7 * dmpi(7) * dscale(k) 2995 dsr3k = 2.0d0 * rr3 * dmpk(3) * dscale(k) 2996 dsr5k = 2.0d0 * rr5 * dmpk(5) * dscale(k) 2997 dsr7k = 2.0d0 * rr7 * dmpk(7) * dscale(k) 2998 end if 2999c 3000c store the potential at each site for use in charge flux 3001c 3002 if (use_chgflx) then 3003 if (use_thole) then 3004 poti = -ukr*psr3 - ukrp*dsr3 3005 potk = uir*psr3 + uirp*dsr3 3006 else if (use_chgpen) then 3007 poti = -ukr * dsr3i 3008 potk = uir * dsr3k 3009 end if 3010 pot(i) = pot(i) + poti 3011 pot(k) = pot(k) + potk 3012 end if 3013c 3014c get the induced dipole field used for dipole torques 3015c 3016 if (use_thole) then 3017 tix3 = psr3*ukx + dsr3*ukxp 3018 tiy3 = psr3*uky + dsr3*ukyp 3019 tiz3 = psr3*ukz + dsr3*ukzp 3020 tkx3 = psr3*uix + dsr3*uixp 3021 tky3 = psr3*uiy + dsr3*uiyp 3022 tkz3 = psr3*uiz + dsr3*uizp 3023 tuir = -psr5*ukr - dsr5*ukrp 3024 tukr = -psr5*uir - dsr5*uirp 3025 else if (use_chgpen) then 3026 tix3 = dsr3i*ukx 3027 tiy3 = dsr3i*uky 3028 tiz3 = dsr3i*ukz 3029 tkx3 = dsr3k*uix 3030 tky3 = dsr3k*uiy 3031 tkz3 = dsr3k*uiz 3032 tuir = -dsr5i*ukr 3033 tukr = -dsr5k*uir 3034 end if 3035 ufld(1,i) = ufld(1,i) + tix3 + xr*tuir 3036 ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir 3037 ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir 3038 ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr 3039 ufld(2,k) = ufld(2,k) + tky3 + yr*tukr 3040 ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr 3041c 3042c get induced dipole field gradient used for quadrupole torques 3043c 3044 if (use_thole) then 3045 tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp) 3046 tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp) 3047 tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp) 3048 tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp) 3049 tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp) 3050 tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp) 3051 tuir = -psr7*ukr - dsr7*ukrp 3052 tukr = -psr7*uir - dsr7*uirp 3053 else if (use_chgpen) then 3054 tix5 = 2.0d0 * (dsr5i*ukx) 3055 tiy5 = 2.0d0 * (dsr5i*uky) 3056 tiz5 = 2.0d0 * (dsr5i*ukz) 3057 tkx5 = 2.0d0 * (dsr5k*uix) 3058 tky5 = 2.0d0 * (dsr5k*uiy) 3059 tkz5 = 2.0d0 * (dsr5k*uiz) 3060 tuir = -dsr7i*ukr 3061 tukr = -dsr7k*uir 3062 end if 3063 dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir 3064 dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5 3065 & + 2.0d0*xr*yr*tuir 3066 dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir 3067 dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5 3068 & + 2.0d0*xr*zr*tuir 3069 dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5 3070 & + 2.0d0*yr*zr*tuir 3071 dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir 3072 dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr 3073 dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5 3074 & - 2.0d0*xr*yr*tukr 3075 dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr 3076 dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5 3077 & - 2.0d0*xr*zr*tukr 3078 dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5 3079 & - 2.0d0*yr*zr*tukr 3080 dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr 3081c 3082c get the field gradient for direct polarization force 3083c 3084 if (use_thole) then 3085 term1 = sc3*(rr3-rr5*xr*xr) + rc3(1)*xr 3086 term2 = (sc3+sc5)*rr5*xr - rc3(1) 3087 term3 = sc5*(rr7*xr*xr-rr5) - rc5(1)*xr 3088 term4 = 2.0d0 * sc5 * rr5 3089 term5 = 2.0d0 * (sc5*rr7*xr-rc5(1)+1.5d0*sc7*rr7*xr) 3090 term6 = xr * (sc7*rr9*xr-rc7(1)) 3091 tixx = ci*term1 + dix*term2 - dir*term3 3092 & - qixx*term4 + qix*term5 - qir*term6 3093 & + (qiy*yr+qiz*zr)*sc7*rr7 3094 tkxx = ck*term1 - dkx*term2 + dkr*term3 3095 & - qkxx*term4 + qkx*term5 - qkr*term6 3096 & + (qky*yr+qkz*zr)*sc7*rr7 3097 term1 = sc3*(rr3-rr5*yr*yr) + rc3(2)*yr 3098 term2 = (sc3+sc5)*rr5*yr - rc3(2) 3099 term3 = sc5*(rr7*yr*yr-rr5) - rc5(2)*yr 3100 term4 = 2.0d0 * sc5 * rr5 3101 term5 = 2.0d0 * (sc5*rr7*yr-rc5(2)+1.5d0*sc7*rr7*yr) 3102 term6 = yr * (sc7*rr9*yr-rc7(2)) 3103 tiyy = ci*term1 + diy*term2 - dir*term3 3104 & - qiyy*term4 + qiy*term5 - qir*term6 3105 & + (qix*xr+qiz*zr)*sc7*rr7 3106 tkyy = ck*term1 - dky*term2 + dkr*term3 3107 & - qkyy*term4 + qky*term5 - qkr*term6 3108 & + (qkx*xr+qkz*zr)*sc7*rr7 3109 term1 = sc3*(rr3-rr5*zr*zr) + rc3(3)*zr 3110 term2 = (sc3+sc5)*rr5*zr - rc3(3) 3111 term3 = sc5*(rr7*zr*zr-rr5) - rc5(3)*zr 3112 term4 = 2.0d0 * sc5 * rr5 3113 term5 = 2.0d0 * (sc5*rr7*zr-rc5(3)+1.5d0*sc7*rr7*zr) 3114 term6 = zr * (sc7*rr9*zr-rc7(3)) 3115 tizz = ci*term1 + diz*term2 - dir*term3 3116 & - qizz*term4 + qiz*term5 - qir*term6 3117 & + (qix*xr+qiy*yr)*sc7*rr7 3118 tkzz = ck*term1 - dkz*term2 + dkr*term3 3119 & - qkzz*term4 + qkz*term5 - qkr*term6 3120 & + (qkx*xr+qky*yr)*sc7*rr7 3121 term2 = sc3*rr5*xr - rc3(1) 3122 term1 = yr * term2 3123 term3 = sc5 * rr5 * yr 3124 term4 = yr * (sc5*rr7*xr-rc5(1)) 3125 term5 = 2.0d0 * sc5 * rr5 3126 term6 = 2.0d0 * (sc5*rr7*xr-rc5(1)) 3127 term7 = 2.0d0 * sc7 * rr7 * yr 3128 term8 = yr * (sc7*rr9*xr-rc7(1)) 3129 tixy = -ci*term1 + diy*term2 + dix*term3 3130 & - dir*term4 - qixy*term5 + qiy*term6 3131 & + qix*term7 - qir*term8 3132 tkxy = -ck*term1 - dky*term2 - dkx*term3 3133 & + dkr*term4 - qkxy*term5 + qky*term6 3134 & + qkx*term7 - qkr*term8 3135 term2 = sc3*rr5*xr - rc3(1) 3136 term1 = zr * term2 3137 term3 = sc5 * rr5 * zr 3138 term4 = zr * (sc5*rr7*xr-rc5(1)) 3139 term5 = 2.0d0 * sc5 * rr5 3140 term6 = 2.0d0 * (sc5*rr7*xr-rc5(1)) 3141 term7 = 2.0d0 * sc7 * rr7 * zr 3142 term8 = zr * (sc7*rr9*xr-rc7(1)) 3143 tixz = -ci*term1 + diz*term2 + dix*term3 3144 & - dir*term4 - qixz*term5 + qiz*term6 3145 & + qix*term7 - qir*term8 3146 tkxz = -ck*term1 - dkz*term2 - dkx*term3 3147 & + dkr*term4 - qkxz*term5 + qkz*term6 3148 & + qkx*term7 - qkr*term8 3149 term2 = sc3*rr5*yr - rc3(2) 3150 term1 = zr * term2 3151 term3 = sc5 * rr5 * zr 3152 term4 = zr * (sc5*rr7*yr-rc5(2)) 3153 term5 = 2.0d0 * sc5 * rr5 3154 term6 = 2.0d0 * (sc5*rr7*yr-rc5(2)) 3155 term7 = 2.0d0 * sc7 * rr7 * zr 3156 term8 = zr * (sc7*rr9*yr-rc7(2)) 3157 tiyz = -ci*term1 + diz*term2 + diy*term3 3158 & - dir*term4 - qiyz*term5 + qiz*term6 3159 & + qiy*term7 - qir*term8 3160 tkyz = -ck*term1 - dkz*term2 - dky*term3 3161 & + dkr*term4 - qkyz*term5 + qkz*term6 3162 & + qky*term7 - qkr*term8 3163c 3164c get the field gradient for direct polarization force 3165c 3166 else if (use_chgpen) then 3167 term1i = rr3*dmpi(3) - rr5*dmpi(5)*xr*xr 3168 term1core = rr3 - rr5*xr*xr 3169 term2i = 2.0d0*rr5*dmpi(5)*xr 3170 term3i = rr7*dmpi(7)*xr*xr - rr5*dmpi(5) 3171 term4i = 2.0d0*rr5*dmpi(5) 3172 term5i = 5.0d0*rr7*dmpi(7)*xr 3173 term6i = rr9*dmpi(9)*xr*xr 3174 term1k = rr3*dmpk(3) - rr5*dmpk(5)*xr*xr 3175 term2k = 2.0d0*rr5*dmpk(5)*xr 3176 term3k = rr7*dmpk(7)*xr*xr - rr5*dmpk(5) 3177 term4k = 2.0d0*rr5*dmpk(5) 3178 term5k = 5.0d0*rr7*dmpk(7)*xr 3179 term6k = rr9*dmpk(9)*xr*xr 3180 tixx = vali*term1i + corei*term1core 3181 & + dix*term2i - dir*term3i 3182 & - qixx*term4i + qix*term5i - qir*term6i 3183 & + (qiy*yr+qiz*zr)*rr7*dmpi(7) 3184 tkxx = valk*term1k + corek*term1core 3185 & - dkx*term2k + dkr*term3k 3186 & - qkxx*term4k + qkx*term5k - qkr*term6k 3187 & + (qky*yr+qkz*zr)*rr7*dmpk(7) 3188 term1i = rr3*dmpi(3) - rr5*dmpi(5)*yr*yr 3189 term1core = rr3 - rr5*yr*yr 3190 term2i = 2.0d0*rr5*dmpi(5)*yr 3191 term3i = rr7*dmpi(7)*yr*yr - rr5*dmpi(5) 3192 term4i = 2.0d0*rr5*dmpi(5) 3193 term5i = 5.0d0*rr7*dmpi(7)*yr 3194 term6i = rr9*dmpi(9)*yr*yr 3195 term1k = rr3*dmpk(3) - rr5*dmpk(5)*yr*yr 3196 term2k = 2.0d0*rr5*dmpk(5)*yr 3197 term3k = rr7*dmpk(7)*yr*yr - rr5*dmpk(5) 3198 term4k = 2.0d0*rr5*dmpk(5) 3199 term5k = 5.0d0*rr7*dmpk(7)*yr 3200 term6k = rr9*dmpk(9)*yr*yr 3201 tiyy = vali*term1i + corei*term1core 3202 & + diy*term2i - dir*term3i 3203 & - qiyy*term4i + qiy*term5i - qir*term6i 3204 & + (qix*xr+qiz*zr)*rr7*dmpi(7) 3205 tkyy = valk*term1k + corek*term1core 3206 & - dky*term2k + dkr*term3k 3207 & - qkyy*term4k + qky*term5k - qkr*term6k 3208 & + (qkx*xr+qkz*zr)*rr7*dmpk(7) 3209 term1i = rr3*dmpi(3) - rr5*dmpi(5)*zr*zr 3210 term1core = rr3 - rr5*zr*zr 3211 term2i = 2.0d0*rr5*dmpi(5)*zr 3212 term3i = rr7*dmpi(7)*zr*zr - rr5*dmpi(5) 3213 term4i = 2.0d0*rr5*dmpi(5) 3214 term5i = 5.0d0*rr7*dmpi(7)*zr 3215 term6i = rr9*dmpi(9)*zr*zr 3216 term1k = rr3*dmpk(3) - rr5*dmpk(5)*zr*zr 3217 term2k = 2.0d0*rr5*dmpk(5)*zr 3218 term3k = rr7*dmpk(7)*zr*zr - rr5*dmpk(5) 3219 term4k = 2.0d0*rr5*dmpk(5) 3220 term5k = 5.0d0*rr7*dmpk(7)*zr 3221 term6k = rr9*dmpk(9)*zr*zr 3222 tizz = vali*term1i + corei*term1core 3223 & + diz*term2i - dir*term3i 3224 & - qizz*term4i + qiz*term5i - qir*term6i 3225 & + (qix*xr+qiy*yr)*rr7*dmpi(7) 3226 tkzz = valk*term1k + corek*term1core 3227 & - dkz*term2k + dkr*term3k 3228 & - qkzz*term4k + qkz*term5k - qkr*term6k 3229 & + (qkx*xr+qky*yr)*rr7*dmpk(7) 3230 term2i = rr5*dmpi(5)*xr 3231 term1i = yr * term2i 3232 term1core = rr5*xr*yr 3233 term3i = rr5*dmpi(5)*yr 3234 term4i = yr * (rr7*dmpi(7)*xr) 3235 term5i = 2.0d0*rr5*dmpi(5) 3236 term6i = 2.0d0*rr7*dmpi(7)*xr 3237 term7i = 2.0d0*rr7*dmpi(7)*yr 3238 term8i = yr*rr9*dmpi(9)*xr 3239 term2k = rr5*dmpk(5)*xr 3240 term1k = yr * term2k 3241 term3k = rr5*dmpk(5)*yr 3242 term4k = yr * (rr7*dmpk(7)*xr) 3243 term5k = 2.0d0*rr5*dmpk(5) 3244 term6k = 2.0d0*rr7*dmpk(7)*xr 3245 term7k = 2.0d0*rr7*dmpk(7)*yr 3246 term8k = yr*rr9*dmpk(9)*xr 3247 tixy = -vali*term1i - corei*term1core 3248 & + diy*term2i + dix*term3i 3249 & - dir*term4i - qixy*term5i + qiy*term6i 3250 & + qix*term7i - qir*term8i 3251 tkxy = -valk*term1k - corek*term1core 3252 & - dky*term2k - dkx*term3k 3253 & + dkr*term4k - qkxy*term5k + qky*term6k 3254 & + qkx*term7k - qkr*term8k 3255 term2i = rr5*dmpi(5)*xr 3256 term1i = zr * term2i 3257 term1core = rr5*xr*zr 3258 term3i = rr5*dmpi(5)*zr 3259 term4i = zr * (rr7*dmpi(7)*xr) 3260 term5i = 2.0d0*rr5*dmpi(5) 3261 term6i = 2.0d0*rr7*dmpi(7)*xr 3262 term7i = 2.0d0*rr7*dmpi(7)*zr 3263 term8i = zr*rr9*dmpi(9)*xr 3264 term2k = rr5*dmpk(5)*xr 3265 term1k = zr * term2k 3266 term3k = rr5*dmpk(5)*zr 3267 term4k = zr * (rr7*dmpk(7)*xr) 3268 term5k = 2.0d0*rr5*dmpk(5) 3269 term6k = 2.0d0*rr7*dmpk(7)*xr 3270 term7k = 2.0d0*rr7*dmpk(7)*zr 3271 term8k = zr*rr9*dmpk(9)*xr 3272 tixz = -vali*term1i - corei*term1core 3273 & + diz*term2i + dix*term3i 3274 & - dir*term4i - qixz*term5i + qiz*term6i 3275 & + qix*term7i - qir*term8i 3276 tkxz = -valk*term1k - corek*term1core 3277 & - dkz*term2k - dkx*term3k 3278 & + dkr*term4k - qkxz*term5k + qkz*term6k 3279 & + qkx*term7k - qkr*term8k 3280 term2i = rr5*dmpi(5)*yr 3281 term1i = zr * term2i 3282 term1core = rr5*yr*zr 3283 term3i = rr5*dmpi(5)*zr 3284 term4i = zr * (rr7*dmpi(7)*yr) 3285 term5i = 2.0d0*rr5*dmpi(5) 3286 term6i = 2.0d0*rr7*dmpi(7)*yr 3287 term7i = 2.0d0*rr7*dmpi(7)*zr 3288 term8i = zr*rr9*dmpi(9)*yr 3289 term2k = rr5*dmpk(5)*yr 3290 term1k = zr * term2k 3291 term3k = rr5*dmpk(5)*zr 3292 term4k = zr * (rr7*dmpk(7)*yr) 3293 term5k = 2.0d0*rr5*dmpk(5) 3294 term6k = 2.0d0*rr7*dmpk(7)*yr 3295 term7k = 2.0d0*rr7*dmpk(7)*zr 3296 term8k = zr*rr9*dmpk(9)*yr 3297 tiyz = -vali*term1i - corei*term1core 3298 & + diz*term2i + diy*term3i 3299 & - dir*term4i - qiyz*term5i + qiz*term6i 3300 & + qiy*term7i - qir*term8i 3301 tkyz = -valk*term1k - corek*term1core 3302 & - dkz*term2k - dky*term3k 3303 & + dkr*term4k - qkyz*term5k + qkz*term6k 3304 & + qky*term7k - qkr*term8k 3305 end if 3306c 3307c get the dEd/dR terms for Thole direct polarization force 3308c 3309 if (use_thole) then 3310 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 3311 & - tkxx*uixp - tkxy*uiyp - tkxz*uizp 3312 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 3313 & - tkxy*uixp - tkyy*uiyp - tkyz*uizp 3314 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 3315 & - tkxz*uixp - tkyz*uiyp - tkzz*uizp 3316 frcx = dscale(k) * depx 3317 frcy = dscale(k) * depy 3318 frcz = dscale(k) * depz 3319c 3320c get the dEp/dR terms for Thole direct polarization force 3321c 3322 depx = tixx*ukx + tixy*uky + tixz*ukz 3323 & - tkxx*uix - tkxy*uiy - tkxz*uiz 3324 depy = tixy*ukx + tiyy*uky + tiyz*ukz 3325 & - tkxy*uix - tkyy*uiy - tkyz*uiz 3326 depz = tixz*ukx + tiyz*uky + tizz*ukz 3327 & - tkxz*uix - tkyz*uiy - tkzz*uiz 3328 frcx = frcx + pscale(k)*depx 3329 frcy = frcy + pscale(k)*depy 3330 frcz = frcz + pscale(k)*depz 3331c 3332c get the dEp/dR terms for chgpen direct polarization force 3333c 3334 else if (use_chgpen) then 3335 depx = tixx*ukx + tixy*uky + tixz*ukz 3336 & - tkxx*uix - tkxy*uiy - tkxz*uiz 3337 depy = tixy*ukx + tiyy*uky + tiyz*ukz 3338 & - tkxy*uix - tkyy*uiy - tkyz*uiz 3339 depz = tixz*ukx + tiyz*uky + tizz*ukz 3340 & - tkxz*uix - tkyz*uiy - tkzz*uiz 3341 frcx = 2.0d0*dscale(k)*depx 3342 frcy = 2.0d0*dscale(k)*depy 3343 frcz = 2.0d0*dscale(k)*depz 3344 end if 3345c 3346c reset Thole values if alternate direct damping was used 3347c 3348 if (use_dirdamp) then 3349 sc3 = 1.0d0 3350 sc5 = 1.0d0 3351 do j = 1, 3 3352 rc3(j) = 0.0d0 3353 rc5(j) = 0.0d0 3354 end do 3355 damp = pdi * pdamp(kk) 3356 if (damp .ne. 0.0d0) then 3357 pgamma = min(pti,thole(kk)) 3358 damp = pgamma * (r/damp)**3 3359 if (damp .lt. 50.0d0) then 3360 expdamp = exp(-damp) 3361 sc3 = 1.0d0 - expdamp 3362 sc5 = 1.0d0 - expdamp*(1.0d0+damp) 3363 temp3 = damp * expdamp * rr5 3364 temp5 = 3.0d0 * damp / r2 3365 rc3(1) = xr * temp3 3366 rc3(2) = yr * temp3 3367 rc3(3) = zr * temp3 3368 rc5(1) = rc3(1) * temp5 3369 rc5(2) = rc3(2) * temp5 3370 rc5(3) = rc3(3) * temp5 3371 end if 3372 end if 3373 end if 3374c 3375c get the dtau/dr terms used for mutual polarization force 3376c 3377 if (poltyp.eq.'MUTUAL' .and. use_thole) then 3378 term1 = (sc3+sc5) * rr5 3379 term2 = term1*xr - rc3(1) 3380 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 3381 tixx = uix*term2 + uir*term3 3382 tkxx = ukx*term2 + ukr*term3 3383 term2 = term1*yr - rc3(2) 3384 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 3385 tiyy = uiy*term2 + uir*term3 3386 tkyy = uky*term2 + ukr*term3 3387 term2 = term1*zr - rc3(3) 3388 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 3389 tizz = uiz*term2 + uir*term3 3390 tkzz = ukz*term2 + ukr*term3 3391 term1 = sc5 * rr5 * yr 3392 term2 = sc3*rr5*xr - rc3(1) 3393 term3 = yr * (sc5*rr7*xr-rc5(1)) 3394 tixy = uix*term1 + uiy*term2 - uir*term3 3395 tkxy = ukx*term1 + uky*term2 - ukr*term3 3396 term1 = sc5 * rr5 * zr 3397 term3 = zr * (sc5*rr7*xr-rc5(1)) 3398 tixz = uix*term1 + uiz*term2 - uir*term3 3399 tkxz = ukx*term1 + ukz*term2 - ukr*term3 3400 term2 = sc3*rr5*yr - rc3(2) 3401 term3 = zr * (sc5*rr7*yr-rc5(2)) 3402 tiyz = uiy*term1 + uiz*term2 - uir*term3 3403 tkyz = uky*term1 + ukz*term2 - ukr*term3 3404 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 3405 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 3406 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 3407 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 3408 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 3409 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 3410 frcx = frcx + uscale(kk)*depx 3411 frcy = frcy + uscale(kk)*depy 3412 frcz = frcz + uscale(kk)*depz 3413c 3414c get the dtau/dr terms used for mutual polarization force 3415c 3416 else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then 3417 term1 = 2.0d0 * dmpik(5) * rr5 3418 term2 = term1*xr 3419 term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 3420 tixx = uix*term2 + uir*term3 3421 tkxx = ukx*term2 + ukr*term3 3422 term2 = term1*yr 3423 term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 3424 tiyy = uiy*term2 + uir*term3 3425 tkyy = uky*term2 + ukr*term3 3426 term2 = term1*zr 3427 term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 3428 tizz = uiz*term2 + uir*term3 3429 tkzz = ukz*term2 + ukr*term3 3430 term1 = rr5*dmpik(5)*yr 3431 term2 = rr5*dmpik(5)*xr 3432 term3 = yr * (rr7*dmpik(7)*xr) 3433 tixy = uix*term1 + uiy*term2 - uir*term3 3434 tkxy = ukx*term1 + uky*term2 - ukr*term3 3435 term1 = rr5 *dmpik(5) * zr 3436 term3 = zr * (rr7*dmpik(7)*xr) 3437 tixz = uix*term1 + uiz*term2 - uir*term3 3438 tkxz = ukx*term1 + ukz*term2 - ukr*term3 3439 term2 = rr5*dmpik(5)*yr 3440 term3 = zr * (rr7*dmpik(7)*yr) 3441 tiyz = uiy*term1 + uiz*term2 - uir*term3 3442 tkyz = uky*term1 + ukz*term2 - ukr*term3 3443 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 3444 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 3445 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 3446 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 3447 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 3448 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 3449 frcx = frcx + wscale(kk)*depx 3450 frcy = frcy + wscale(kk)*depy 3451 frcz = frcz + wscale(kk)*depz 3452c 3453c get the dtau/dr terms used for OPT polarization force 3454c 3455 else if (poltyp.eq.'OPT' .and. use_thole) then 3456 do j = 0, optorder-1 3457 uirm = uopt(j,1,ii)*xr + uopt(j,2,ii)*yr 3458 & + uopt(j,3,ii)*zr 3459 do m = 0, optorder-j-1 3460 ukrm = uopt(m,1,kk)*xr + uopt(m,2,kk)*yr 3461 & + uopt(m,3,kk)*zr 3462 term1 = (sc3+sc5) * rr5 3463 term2 = term1*xr - rc3(1) 3464 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 3465 tixx = uopt(j,1,ii)*term2 + uirm*term3 3466 tkxx = uopt(m,1,kk)*term2 + ukrm*term3 3467 term2 = term1*yr - rc3(2) 3468 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 3469 tiyy = uopt(j,2,ii)*term2 + uirm*term3 3470 tkyy = uopt(m,2,kk)*term2 + ukrm*term3 3471 term2 = term1*zr - rc3(3) 3472 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 3473 tizz = uopt(j,3,ii)*term2 + uirm*term3 3474 tkzz = uopt(m,3,kk)*term2 + ukrm*term3 3475 term1 = sc5 * rr5 * yr 3476 term2 = sc3*rr5*xr - rc3(1) 3477 term3 = yr * (sc5*rr7*xr-rc5(1)) 3478 tixy = uopt(j,1,ii)*term1 + uopt(j,2,ii)*term2 3479 & - uirm*term3 3480 tkxy = uopt(m,1,kk)*term1 + uopt(m,2,kk)*term2 3481 & - ukrm*term3 3482 term1 = sc5 * rr5 * zr 3483 term3 = zr * (sc5*rr7*xr-rc5(1)) 3484 tixz = uopt(j,1,ii)*term1 + uopt(j,3,ii)*term2 3485 & - uirm*term3 3486 tkxz = uopt(m,1,kk)*term1 + uopt(m,3,kk)*term2 3487 & - ukrm*term3 3488 term2 = sc3*rr5*yr - rc3(2) 3489 term3 = zr * (sc5*rr7*yr-rc5(2)) 3490 tiyz = uopt(j,2,ii)*term1 + uopt(j,3,ii)*term2 3491 & - uirm*term3 3492 tkyz = uopt(m,2,kk)*term1 + uopt(m,3,kk)*term2 3493 & - ukrm*term3 3494 depx = tixx*uoptp(m,1,kk) + tkxx*uoptp(j,1,ii) 3495 & + tixy*uoptp(m,2,kk) + tkxy*uoptp(j,2,ii) 3496 & + tixz*uoptp(m,3,kk) + tkxz*uoptp(j,3,ii) 3497 depy = tixy*uoptp(m,1,kk) + tkxy*uoptp(j,1,ii) 3498 & + tiyy*uoptp(m,2,kk) + tkyy*uoptp(j,2,ii) 3499 & + tiyz*uoptp(m,3,kk) + tkyz*uoptp(j,3,ii) 3500 depz = tixz*uoptp(m,1,kk) + tkxz*uoptp(j,1,ii) 3501 & + tiyz*uoptp(m,2,kk) + tkyz*uoptp(j,2,ii) 3502 & + tizz*uoptp(m,3,kk) + tkzz*uoptp(j,3,ii) 3503 frcx = frcx + copm(j+m+1)*uscale(k)*depx 3504 frcy = frcy + copm(j+m+1)*uscale(k)*depy 3505 frcz = frcz + copm(j+m+1)*uscale(k)*depz 3506 end do 3507 end do 3508c 3509c get the dtau/dr terms used for OPT polarization force 3510c 3511 else if (poltyp.eq.'OPT' .and. use_chgpen) then 3512 do j = 0, optorder-1 3513 uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr 3514 & + uopt(j,3,i)*zr 3515 do m = 0, optorder-j-1 3516 ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr 3517 & + uopt(m,3,k)*zr 3518 term1 = 2.0d0 * dmpik(5) * rr5 3519 term2 = term1*xr 3520 term3 = rr5*dmpik(5) - rr7*dmpik(7)*xr*xr 3521 tixx = uopt(j,1,i)*term2 + uirm*term3 3522 tkxx = uopt(m,1,k)*term2 + ukrm*term3 3523 term2 = term1*yr 3524 term3 = rr5*dmpik(5) - rr7*dmpik(7)*yr*yr 3525 tiyy = uopt(j,2,i)*term2 + uirm*term3 3526 tkyy = uopt(m,2,k)*term2 + ukrm*term3 3527 term2 = term1*zr 3528 term3 = rr5*dmpik(5) - rr7*dmpik(7)*zr*zr 3529 tizz = uopt(j,3,i)*term2 + uirm*term3 3530 tkzz = uopt(m,3,k)*term2 + ukrm*term3 3531 term1 = rr5*dmpik(5)*yr 3532 term2 = rr5*dmpik(5)*xr 3533 term3 = yr * (rr7*dmpik(7)*xr) 3534 tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2 3535 & - uirm*term3 3536 tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2 3537 & - ukrm*term3 3538 term1 = rr5 *dmpik(5) * zr 3539 term3 = zr * (rr7*dmpik(7)*xr) 3540 tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2 3541 & - uirm*term3 3542 tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2 3543 & - ukrm*term3 3544 term2 = rr5*dmpik(5)*yr 3545 term3 = zr * (rr7*dmpik(7)*yr) 3546 tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2 3547 & - uirm*term3 3548 tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2 3549 & - ukrm*term3 3550 depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i) 3551 & + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i) 3552 & + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i) 3553 depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i) 3554 & + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i) 3555 & + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i) 3556 depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i) 3557 & + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i) 3558 & + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i) 3559 frcx = frcx + copm(j+m+1)*wscale(k)*depx 3560 frcy = frcy + copm(j+m+1)*wscale(k)*depy 3561 frcz = frcz + copm(j+m+1)*wscale(k)*depz 3562 end do 3563 end do 3564c 3565c get the dtau/dr terms used for TCG polarization force 3566c 3567 else if (poltyp.eq.'TCG' .and. use_thole) then 3568 do j = 1, tcgnab 3569 ukx = ubd(1,kk,j) 3570 uky = ubd(2,kk,j) 3571 ukz = ubd(3,kk,j) 3572 ukxp = ubp(1,kk,j) 3573 ukyp = ubp(2,kk,j) 3574 ukzp = ubp(3,kk,j) 3575 uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr 3576 ukrt = ukx*xr + uky*yr + ukz*zr 3577 term1 = (sc3+sc5) * rr5 3578 term2 = term1*xr - rc3(1) 3579 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 3580 tixx = uax(j)*term2 + uirt*term3 3581 tkxx = ukx*term2 + ukrt*term3 3582 term2 = term1*yr - rc3(2) 3583 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 3584 tiyy = uay(j)*term2 + uirt*term3 3585 tkyy = uky*term2 + ukrt*term3 3586 term2 = term1*zr - rc3(3) 3587 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 3588 tizz = uaz(j)*term2 + uirt*term3 3589 tkzz = ukz*term2 + ukrt*term3 3590 term1 = sc5 * rr5 * yr 3591 term2 = sc3*rr5*xr - rc3(1) 3592 term3 = yr * (sc5*rr7*xr-rc5(1)) 3593 tixy = uax(j)*term1 + uay(j)*term2 - uirt*term3 3594 tkxy = ukx*term1 + uky*term2 - ukrt*term3 3595 term1 = sc5 * rr5 * zr 3596 term3 = zr * (sc5*rr7*xr-rc5(1)) 3597 tixz = uax(j)*term1 + uaz(j)*term2 - uirt*term3 3598 tkxz = ukx*term1 + ukz*term2 - ukrt*term3 3599 term2 = sc3*rr5*yr - rc3(2) 3600 term3 = zr * (sc5*rr7*yr-rc5(2)) 3601 tiyz = uay(j)*term1 + uaz(j)*term2 - uirt*term3 3602 tkyz = uky*term1 + ukz*term2 - ukrt*term3 3603 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 3604 & + tkxx*uaxp(j) + tkxy*uayp(j) 3605 & + tkxz*uazp(j) 3606 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 3607 & + tkxy*uaxp(j) + tkyy*uayp(j) 3608 & + tkyz*uazp(j) 3609 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 3610 & + tkxz*uaxp(j) + tkyz*uayp(j) 3611 & + tkzz*uazp(j) 3612 frcx = frcx + uscale(k)*depx 3613 frcy = frcy + uscale(k)*depy 3614 frcz = frcz + uscale(k)*depz 3615 ukx = uad(1,kk,j) 3616 uky = uad(2,kk,j) 3617 ukz = uad(3,kk,j) 3618 ukxp = uap(1,kk,j) 3619 ukyp = uap(2,kk,j) 3620 ukzp = uap(3,kk,j) 3621 uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr 3622 ukrt = ukx*xr + uky*yr + ukz*zr 3623 term1 = (sc3+sc5) * rr5 3624 term2 = term1*xr - rc3(1) 3625 term3 = sc5*(rr5-rr7*xr*xr) + rc5(1)*xr 3626 tixx = ubx(j)*term2 + uirt*term3 3627 tkxx = ukx*term2 + ukrt*term3 3628 term2 = term1*yr - rc3(2) 3629 term3 = sc5*(rr5-rr7*yr*yr) + rc5(2)*yr 3630 tiyy = uby(j)*term2 + uirt*term3 3631 tkyy = uky*term2 + ukrt*term3 3632 term2 = term1*zr - rc3(3) 3633 term3 = sc5*(rr5-rr7*zr*zr) + rc5(3)*zr 3634 tizz = ubz(j)*term2 + uirt*term3 3635 tkzz = ukz*term2 + ukrt*term3 3636 term1 = sc5 * rr5 * yr 3637 term2 = sc3*rr5*xr - rc3(1) 3638 term3 = yr * (sc5*rr7*xr-rc5(1)) 3639 tixy = ubx(j)*term1 + uby(j)*term2 - uirt*term3 3640 tkxy = ukx*term1 + uky*term2 - ukrt*term3 3641 term1 = sc5 * rr5 * zr 3642 term3 = zr * (sc5*rr7*xr-rc5(1)) 3643 tixz = ubx(j)*term1 + ubz(j)*term2 - uirt*term3 3644 tkxz = ukx*term1 + ukz*term2 - ukrt*term3 3645 term2 = sc3*rr5*yr - rc3(2) 3646 term3 = zr * (sc5*rr7*yr-rc5(2)) 3647 tiyz = uby(j)*term1 + ubz(j)*term2 - uirt*term3 3648 tkyz = uky*term1 + ukz*term2 - ukrt*term3 3649 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 3650 & + tkxx*ubxp(j) + tkxy*ubyp(j) 3651 & + tkxz*ubzp(j) 3652 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 3653 & + tkxy*ubxp(j) + tkyy*ubyp(j) 3654 & + tkyz*ubzp(j) 3655 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 3656 & + tkxz*ubxp(j) + tkyz*ubyp(j) 3657 & + tkzz*ubzp(j) 3658 frcx = frcx + uscale(k)*depx 3659 frcy = frcy + uscale(k)*depy 3660 frcz = frcz + uscale(k)*depz 3661 end do 3662 end if 3663c 3664c increment force-based gradient on the interaction sites 3665c 3666 dep(1,i) = dep(1,i) + frcx 3667 dep(2,i) = dep(2,i) + frcy 3668 dep(3,i) = dep(3,i) + frcz 3669 dep(1,k) = dep(1,k) - frcx 3670 dep(2,k) = dep(2,k) - frcy 3671 dep(3,k) = dep(3,k) - frcz 3672c 3673c increment the virial due to pairwise Cartesian forces 3674c 3675 vxx = -xr * frcx 3676 vxy = -0.5d0 * (yr*frcx+xr*frcy) 3677 vxz = -0.5d0 * (zr*frcx+xr*frcz) 3678 vyy = -yr * frcy 3679 vyz = -0.5d0 * (zr*frcy+yr*frcz) 3680 vzz = -zr * frcz 3681 vir(1,1) = vir(1,1) + vxx 3682 vir(2,1) = vir(2,1) + vxy 3683 vir(3,1) = vir(3,1) + vxz 3684 vir(1,2) = vir(1,2) + vxy 3685 vir(2,2) = vir(2,2) + vyy 3686 vir(3,2) = vir(3,2) + vyz 3687 vir(1,3) = vir(1,3) + vxz 3688 vir(2,3) = vir(2,3) + vyz 3689 vir(3,3) = vir(3,3) + vzz 3690 end if 3691 end do 3692c 3693c reset exclusion coefficients for connected atoms 3694c 3695 if (dpequal) then 3696 do j = 1, n12(i) 3697 pscale(i12(j,i)) = 1.0d0 3698 dscale(i12(j,i)) = 1.0d0 3699 wscale(i12(j,i)) = 1.0d0 3700 end do 3701 do j = 1, n13(i) 3702 pscale(i13(j,i)) = 1.0d0 3703 dscale(i13(j,i)) = 1.0d0 3704 wscale(i13(j,i)) = 1.0d0 3705 end do 3706 do j = 1, n14(i) 3707 pscale(i14(j,i)) = 1.0d0 3708 dscale(i14(j,i)) = 1.0d0 3709 wscale(i14(j,i)) = 1.0d0 3710 end do 3711 do j = 1, n15(i) 3712 pscale(i15(j,i)) = 1.0d0 3713 dscale(i15(j,i)) = 1.0d0 3714 wscale(i15(j,i)) = 1.0d0 3715 end do 3716 do j = 1, np11(i) 3717 uscale(ip11(j,i)) = 1.0d0 3718 end do 3719 do j = 1, np12(i) 3720 uscale(ip12(j,i)) = 1.0d0 3721 end do 3722 do j = 1, np13(i) 3723 uscale(ip13(j,i)) = 1.0d0 3724 end do 3725 do j = 1, np14(i) 3726 uscale(ip14(j,i)) = 1.0d0 3727 end do 3728 else 3729 do j = 1, n12(i) 3730 pscale(i12(j,i)) = 1.0d0 3731 wscale(i12(j,i)) = 1.0d0 3732 end do 3733 do j = 1, n13(i) 3734 pscale(i13(j,i)) = 1.0d0 3735 wscale(i13(j,i)) = 1.0d0 3736 end do 3737 do j = 1, n14(i) 3738 pscale(i14(j,i)) = 1.0d0 3739 wscale(i14(j,i)) = 1.0d0 3740 end do 3741 do j = 1, n15(i) 3742 pscale(i15(j,i)) = 1.0d0 3743 wscale(i15(j,i)) = 1.0d0 3744 end do 3745 do j = 1, np11(i) 3746 dscale(ip11(j,i)) = 1.0d0 3747 uscale(ip11(j,i)) = 1.0d0 3748 end do 3749 do j = 1, np12(i) 3750 dscale(ip12(j,i)) = 1.0d0 3751 uscale(ip12(j,i)) = 1.0d0 3752 end do 3753 do j = 1, np13(i) 3754 dscale(ip13(j,i)) = 1.0d0 3755 uscale(ip13(j,i)) = 1.0d0 3756 end do 3757 do j = 1, np14(i) 3758 dscale(ip14(j,i)) = 1.0d0 3759 uscale(ip14(j,i)) = 1.0d0 3760 end do 3761 end if 3762 end do 3763c 3764c OpenMP directives for the major loop structure 3765c 3766!$OMP END DO 3767!$OMP DO reduction(+:dep,vir) schedule(guided) 3768c 3769c torque is induced field and gradient cross permanent moments 3770c 3771 do ii = 1, npole 3772 i = ipole(ii) 3773 dix = rpole(2,ii) 3774 diy = rpole(3,ii) 3775 diz = rpole(4,ii) 3776 qixx = rpole(5,ii) 3777 qixy = rpole(6,ii) 3778 qixz = rpole(7,ii) 3779 qiyy = rpole(9,ii) 3780 qiyz = rpole(10,ii) 3781 qizz = rpole(13,ii) 3782 tep(1) = diz*ufld(2,i) - diy*ufld(3,i) 3783 & + qixz*dufld(2,i) - qixy*dufld(4,i) 3784 & + 2.0d0*qiyz*(dufld(3,i)-dufld(6,i)) 3785 & + (qizz-qiyy)*dufld(5,i) 3786 tep(2) = dix*ufld(3,i) - diz*ufld(1,i) 3787 & - qiyz*dufld(2,i) + qixy*dufld(5,i) 3788 & + 2.0d0*qixz*(dufld(6,i)-dufld(1,i)) 3789 & + (qixx-qizz)*dufld(4,i) 3790 tep(3) = diy*ufld(1,i) - dix*ufld(2,i) 3791 & + qiyz*dufld(4,i) - qixz*dufld(5,i) 3792 & + 2.0d0*qixy*(dufld(1,i)-dufld(3,i)) 3793 & + (qiyy-qixx)*dufld(2,i) 3794 call torque (ii,tep,fix,fiy,fiz,dep) 3795 iz = zaxis(ii) 3796 ix = xaxis(ii) 3797 iy = abs(yaxis(ii)) 3798 if (iz .eq. 0) iz = i 3799 if (ix .eq. 0) ix = i 3800 if (iy .eq. 0) iy = i 3801 xiz = x(iz) - x(i) 3802 yiz = y(iz) - y(i) 3803 ziz = z(iz) - z(i) 3804 xix = x(ix) - x(i) 3805 yix = y(ix) - y(i) 3806 zix = z(ix) - z(i) 3807 xiy = x(iy) - x(i) 3808 yiy = y(iy) - y(i) 3809 ziy = z(iy) - z(i) 3810 vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1) 3811 vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1) 3812 & + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2)) 3813 vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1) 3814 & + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 3815 vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2) 3816 vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2) 3817 & + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3)) 3818 vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3) 3819 vir(1,1) = vir(1,1) + vxx 3820 vir(2,1) = vir(2,1) + vxy 3821 vir(3,1) = vir(3,1) + vxz 3822 vir(1,2) = vir(1,2) + vxy 3823 vir(2,2) = vir(2,2) + vyy 3824 vir(3,2) = vir(3,2) + vyz 3825 vir(1,3) = vir(1,3) + vxz 3826 vir(2,3) = vir(2,3) + vyz 3827 vir(3,3) = vir(3,3) + vzz 3828 end do 3829c 3830c OpenMP directives for the major loop structure 3831c 3832!$OMP END DO 3833c 3834c modify the gradient and virial for charge flux 3835c 3836 if (use_chgflx) then 3837 call dcflux (pot,decfx,decfy,decfz) 3838!$OMP DO reduction(+:dep,vir) schedule(guided) 3839 do ii = 1, npole 3840 i = ipole(ii) 3841 xi = x(i) 3842 yi = y(i) 3843 zi = z(i) 3844 frcx = decfx(i) 3845 frcy = decfy(i) 3846 frcz = decfz(i) 3847 dep(1,i) = dep(1,i) + frcx 3848 dep(2,i) = dep(2,i) + frcy 3849 dep(3,i) = dep(3,i) + frcz 3850 vxx = xi * frcx 3851 vxy = yi * frcx 3852 vxz = zi * frcx 3853 vyy = yi * frcy 3854 vyz = zi * frcy 3855 vzz = zi * frcz 3856 vir(1,1) = vir(1,1) + vxx 3857 vir(2,1) = vir(2,1) + vxy 3858 vir(3,1) = vir(3,1) + vxz 3859 vir(1,2) = vir(1,2) + vxy 3860 vir(2,2) = vir(2,2) + vyy 3861 vir(3,2) = vir(3,2) + vyz 3862 vir(1,3) = vir(1,3) + vxz 3863 vir(2,3) = vir(2,3) + vyz 3864 vir(3,3) = vir(3,3) + vzz 3865 end do 3866!$OMP END DO 3867 end if 3868c 3869c OpenMP directives for the major loop structure 3870c 3871!$OMP END PARALLEL 3872c 3873c perform deallocation of some local arrays 3874c 3875 deallocate (pscale) 3876 deallocate (dscale) 3877 deallocate (uscale) 3878 deallocate (wscale) 3879 deallocate (ufld) 3880 deallocate (dufld) 3881 deallocate (pot) 3882 deallocate (decfx) 3883 deallocate (decfy) 3884 deallocate (decfz) 3885 return 3886 end 3887c 3888c 3889c ################################################################### 3890c ## ## 3891c ## subroutine epolar1c -- Ewald polarization derivs via loop ## 3892c ## ## 3893c ################################################################### 3894c 3895c 3896c "epolar1c" calculates the dipole polarization energy and 3897c derivatives with respect to Cartesian coordinates using 3898c particle mesh Ewald summation and a double loop 3899c 3900c 3901 subroutine epolar1c 3902 use atoms 3903 use boxes 3904 use chgpot 3905 use deriv 3906 use energi 3907 use ewald 3908 use math 3909 use mpole 3910 use pme 3911 use polar 3912 use polpot 3913 use poltcg 3914 use potent 3915 use virial 3916 implicit none 3917 integer i,j,ii 3918 integer ix,iy,iz 3919 real*8 f,term 3920 real*8 dix,diy,diz 3921 real*8 uix,uiy,uiz 3922 real*8 xd,yd,zd 3923 real*8 xq,yq,zq 3924 real*8 xu,yu,zu 3925 real*8 xup,yup,zup 3926 real*8 xv,yv,zv,vterm 3927 real*8 xufield,yufield 3928 real*8 zufield 3929 real*8 xix,yix,zix 3930 real*8 xiy,yiy,ziy 3931 real*8 xiz,yiz,ziz 3932 real*8 vxx,vyy,vzz 3933 real*8 vxy,vxz,vyz 3934 real*8 fix(3),fiy(3),fiz(3) 3935 real*8 tep(3) 3936c 3937c 3938c zero out the polarization energy and derivatives 3939c 3940 ep = 0.0d0 3941 do i = 1, n 3942 do j = 1, 3 3943 dep(j,i) = 0.0d0 3944 end do 3945 end do 3946 if (npole .eq. 0) return 3947c 3948c set grid size, spline order and Ewald coefficient 3949c 3950 nfft1 = nefft1 3951 nfft2 = nefft2 3952 nfft3 = nefft3 3953 bsorder = bsporder 3954 aewald = apewald 3955c 3956c set the energy unit conversion factor 3957c 3958 f = electric / dielec 3959c 3960c check the sign of multipole components at chiral sites 3961c 3962 if (.not. use_mpole) call chkpole 3963c 3964c rotate the multipole components into the global frame 3965c 3966 if (.not. use_mpole) call rotpole 3967c 3968c compute the induced dipoles at each polarizable atom 3969c 3970 call induce 3971c 3972c compute the total induced dipole polarization energy 3973c 3974 call epolar1e 3975c 3976c compute the real space part of the Ewald summation 3977c 3978 call epreal1c 3979c 3980c compute the reciprocal space part of the Ewald summation 3981c 3982 call eprecip1 3983c 3984c compute the Ewald self-energy torque and virial terms 3985c 3986 term = (4.0d0/3.0d0) * f * aewald**3 / rootpi 3987 do ii = 1, npole 3988 i = ipole(ii) 3989 dix = rpole(2,ii) 3990 diy = rpole(3,ii) 3991 diz = rpole(4,ii) 3992 uix = 0.5d0 * (uind(1,ii)+uinp(1,ii)) 3993 uiy = 0.5d0 * (uind(2,ii)+uinp(2,ii)) 3994 uiz = 0.5d0 * (uind(3,ii)+uinp(3,ii)) 3995 tep(1) = term * (diy*uiz-diz*uiy) 3996 tep(2) = term * (diz*uix-dix*uiz) 3997 tep(3) = term * (dix*uiy-diy*uix) 3998 call torque (ii,tep,fix,fiy,fiz,dep) 3999 iz = zaxis(ii) 4000 ix = xaxis(ii) 4001 iy = abs(yaxis(ii)) 4002 if (iz .eq. 0) iz = i 4003 if (ix .eq. 0) ix = i 4004 if (iy .eq. 0) iy = i 4005 xiz = x(iz) - x(i) 4006 yiz = y(iz) - y(i) 4007 ziz = z(iz) - z(i) 4008 xix = x(ix) - x(i) 4009 yix = y(ix) - y(i) 4010 zix = z(ix) - z(i) 4011 xiy = x(iy) - x(i) 4012 yiy = y(iy) - y(i) 4013 ziy = z(iy) - z(i) 4014 vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1) 4015 vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1) 4016 & + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2)) 4017 vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1) 4018 & + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 4019 vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2) 4020 vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2) 4021 & + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3)) 4022 vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3) 4023 vir(1,1) = vir(1,1) + vxx 4024 vir(2,1) = vir(2,1) + vxy 4025 vir(3,1) = vir(3,1) + vxz 4026 vir(1,2) = vir(1,2) + vxy 4027 vir(2,2) = vir(2,2) + vyy 4028 vir(3,2) = vir(3,2) + vyz 4029 vir(1,3) = vir(1,3) + vxz 4030 vir(2,3) = vir(2,3) + vyz 4031 vir(3,3) = vir(3,3) + vzz 4032 end do 4033c 4034c compute the cell dipole boundary correction term 4035c 4036 if (boundary .eq. 'VACUUM') then 4037 xd = 0.0d0 4038 yd = 0.0d0 4039 zd = 0.0d0 4040 xu = 0.0d0 4041 yu = 0.0d0 4042 zu = 0.0d0 4043 xup = 0.0d0 4044 yup = 0.0d0 4045 zup = 0.0d0 4046 do ii = 1, npole 4047 i = ipole(ii) 4048 xd = xd + rpole(2,ii) + rpole(1,ii)*x(i) 4049 yd = yd + rpole(3,ii) + rpole(1,ii)*y(i) 4050 zd = zd + rpole(4,ii) + rpole(1,ii)*z(i) 4051 xu = xu + uind(1,ii) 4052 yu = yu + uind(2,ii) 4053 zu = zu + uind(3,ii) 4054 xup = xup + uinp(1,ii) 4055 yup = yup + uinp(2,ii) 4056 zup = zup + uinp(3,ii) 4057 end do 4058 term = (2.0d0/3.0d0) * f * (pi/volbox) 4059 ep = ep + term*(xd*xu+yd*yu+zd*zu) 4060 do ii = 1, npole 4061 i = ipole(ii) 4062 dep(1,i) = dep(1,i) + term*rpole(1,ii)*(xu+xup) 4063 dep(2,i) = dep(2,i) + term*rpole(1,ii)*(yu+yup) 4064 dep(3,i) = dep(3,i) + term*rpole(1,ii)*(zu+zup) 4065 end do 4066 xufield = -term * (xu+xup) 4067 yufield = -term * (yu+yup) 4068 zufield = -term * (zu+zup) 4069 do ii = 1, npole 4070 tep(1) = rpole(3,ii)*zufield - rpole(4,ii)*yufield 4071 tep(2) = rpole(4,ii)*xufield - rpole(2,ii)*zufield 4072 tep(3) = rpole(2,ii)*yufield - rpole(3,ii)*xufield 4073 call torque (ii,tep,fix,fiy,fiz,dep) 4074 end do 4075c 4076c boundary correction to virial due to overall cell dipole 4077c 4078 xd = 0.0d0 4079 yd = 0.0d0 4080 zd = 0.0d0 4081 xq = 0.0d0 4082 yq = 0.0d0 4083 zq = 0.0d0 4084 do ii = 1, npole 4085 i = ipole(ii) 4086 xd = xd + rpole(2,ii) 4087 yd = yd + rpole(3,ii) 4088 zd = zd + rpole(4,ii) 4089 xq = xq + rpole(1,ii)*x(i) 4090 yq = yq + rpole(1,ii)*y(i) 4091 zq = zq + rpole(1,ii)*z(i) 4092 end do 4093 xv = xq * (xu+xup) 4094 yv = yq * (yu+yup) 4095 zv = zq * (zu+zup) 4096 vterm = xv + yv + zv + xu*xup + yu*yup + zu*zup 4097 & + xd*(xu+xup) + yd*(yu+yup) + zd*(zu+zup) 4098 vterm = term * vterm 4099 vir(1,1) = vir(1,1) + term*xv + vterm 4100 vir(2,1) = vir(2,1) + term*xv 4101 vir(3,1) = vir(3,1) + term*xv 4102 vir(1,2) = vir(1,2) + term*yv 4103 vir(2,2) = vir(2,2) + term*yv + vterm 4104 vir(3,2) = vir(3,2) + term*yv 4105 vir(1,3) = vir(1,3) + term*zv 4106 vir(2,3) = vir(2,3) + term*zv 4107 vir(3,3) = vir(3,3) + term*zv + vterm 4108 if (poltyp .eq. 'DIRECT') then 4109 vterm = term * (xu*xup+yu*yup+zu*zup) 4110 vir(1,1) = vir(1,1) + vterm 4111 vir(2,2) = vir(2,2) + vterm 4112 vir(3,3) = vir(3,3) + vterm 4113 end if 4114 end if 4115 return 4116 end 4117c 4118c 4119c ################################################################# 4120c ## ## 4121c ## subroutine epreal1c -- Ewald real space derivs via loop ## 4122c ## ## 4123c ################################################################# 4124c 4125c 4126c "epreal1c" evaluates the real space portion of the Ewald 4127c summation energy and gradient due to dipole polarization 4128c via a double loop 4129c 4130c 4131 subroutine epreal1c 4132 use atoms 4133 use bound 4134 use cell 4135 use chgpen 4136 use chgpot 4137 use couple 4138 use deriv 4139 use ewald 4140 use math 4141 use mplpot 4142 use molcul 4143 use mpole 4144 use polar 4145 use polgrp 4146 use polopt 4147 use polpot 4148 use poltcg 4149 use potent 4150 use shunt 4151 use virial 4152 implicit none 4153 integer i,j,k,m 4154 integer ii,kk,jcell 4155 integer ix,iy,iz 4156 real*8 f,pgamma 4157 real*8 pdi,pti,ddi 4158 real*8 damp,expdamp 4159 real*8 temp3,temp5,temp7 4160 real*8 sc3,sc5,sc7 4161 real*8 psc3,psc5,psc7 4162 real*8 dsc3,dsc5,dsc7 4163 real*8 usc3,usc5 4164 real*8 psr3,psr5,psr7 4165 real*8 dsr3,dsr5,dsr7 4166 real*8 usr3,usr5 4167 real*8 rr3core,rr5core 4168 real*8 rr3i,rr5i 4169 real*8 rr7i,rr9i 4170 real*8 rr3k,rr5k 4171 real*8 rr7k,rr9k 4172 real*8 rr5ik,rr7ik 4173 real*8 xi,yi,zi 4174 real*8 xr,yr,zr 4175 real*8 r,r2,rr1,rr3 4176 real*8 rr5,rr7,rr9 4177 real*8 ci,dix,diy,diz 4178 real*8 qixx,qixy,qixz 4179 real*8 qiyy,qiyz,qizz 4180 real*8 uix,uiy,uiz 4181 real*8 uixp,uiyp,uizp 4182 real*8 ck,dkx,dky,dkz 4183 real*8 qkxx,qkxy,qkxz 4184 real*8 qkyy,qkyz,qkzz 4185 real*8 ukx,uky,ukz 4186 real*8 ukxp,ukyp,ukzp 4187 real*8 dir,uir,uirp 4188 real*8 dkr,ukr,ukrp 4189 real*8 qix,qiy,qiz,qir 4190 real*8 qkx,qky,qkz,qkr 4191 real*8 corei,corek 4192 real*8 vali,valk 4193 real*8 alphai,alphak 4194 real*8 uirm,ukrm 4195 real*8 uirt,ukrt 4196 real*8 tuir,tukr 4197 real*8 tixx,tiyy,tizz 4198 real*8 tixy,tixz,tiyz 4199 real*8 tkxx,tkyy,tkzz 4200 real*8 tkxy,tkxz,tkyz 4201 real*8 tix3,tiy3,tiz3 4202 real*8 tix5,tiy5,tiz5 4203 real*8 tkx3,tky3,tkz3 4204 real*8 tkx5,tky5,tkz5 4205 real*8 term1,term2,term3 4206 real*8 term4,term5 4207 real*8 term6,term7 4208 real*8 term1core 4209 real*8 term1i,term2i,term3i 4210 real*8 term4i,term5i,term6i 4211 real*8 term7i,term8i 4212 real*8 term1k,term2k,term3k 4213 real*8 term4k,term5k,term6k 4214 real*8 term7k,term8k 4215 real*8 poti,potk 4216 real*8 depx,depy,depz 4217 real*8 frcx,frcy,frcz 4218 real*8 xix,yix,zix 4219 real*8 xiy,yiy,ziy 4220 real*8 xiz,yiz,ziz 4221 real*8 vxx,vyy,vzz 4222 real*8 vxy,vxz,vyz 4223 real*8 rc3(3),rc5(3),rc7(3) 4224 real*8 prc3(3),prc5(3),prc7(3) 4225 real*8 drc3(3),drc5(3),drc7(3) 4226 real*8 urc3(3),urc5(3),tep(3) 4227 real*8 fix(3),fiy(3),fiz(3) 4228 real*8 uax(3),uay(3),uaz(3) 4229 real*8 ubx(3),uby(3),ubz(3) 4230 real*8 uaxp(3),uayp(3),uazp(3) 4231 real*8 ubxp(3),ubyp(3),ubzp(3) 4232 real*8 dmpi(9),dmpk(9) 4233 real*8 dmpik(9),dmpe(9) 4234 real*8, allocatable :: pscale(:) 4235 real*8, allocatable :: dscale(:) 4236 real*8, allocatable :: uscale(:) 4237 real*8, allocatable :: wscale(:) 4238 real*8, allocatable :: ufld(:,:) 4239 real*8, allocatable :: dufld(:,:) 4240 real*8, allocatable :: pot(:) 4241 real*8, allocatable :: decfx(:) 4242 real*8, allocatable :: decfy(:) 4243 real*8, allocatable :: decfz(:) 4244 character*6 mode 4245c 4246c 4247c perform dynamic allocation of some local arrays 4248c 4249 allocate (pscale(n)) 4250 allocate (dscale(n)) 4251 allocate (uscale(n)) 4252 allocate (wscale(n)) 4253 allocate (ufld(3,n)) 4254 allocate (dufld(6,n)) 4255 allocate (pot(n)) 4256 allocate (decfx(n)) 4257 allocate (decfy(n)) 4258 allocate (decfz(n)) 4259c 4260c set exclusion coefficients and arrays to store fields 4261c 4262 do i = 1, n 4263 pscale(i) = 1.0d0 4264 dscale(i) = 1.0d0 4265 uscale(i) = 1.0d0 4266 wscale(i) = 1.0d0 4267 do j = 1, 3 4268 ufld(j,i) = 0.0d0 4269 end do 4270 do j = 1, 6 4271 dufld(j,i) = 0.0d0 4272 end do 4273 pot(i) = 0.0d0 4274 end do 4275c 4276c set conversion factor, cutoff and switching coefficients 4277c 4278 f = 0.5d0 * electric / dielec 4279 mode = 'EWALD' 4280 call switch (mode) 4281c 4282c compute the dipole polarization gradient components 4283c 4284 do ii = 1, npole-1 4285 i = ipole(ii) 4286 xi = x(i) 4287 yi = y(i) 4288 zi = z(i) 4289 ci = rpole(1,ii) 4290 dix = rpole(2,ii) 4291 diy = rpole(3,ii) 4292 diz = rpole(4,ii) 4293 qixx = rpole(5,ii) 4294 qixy = rpole(6,ii) 4295 qixz = rpole(7,ii) 4296 qiyy = rpole(9,ii) 4297 qiyz = rpole(10,ii) 4298 qizz = rpole(13,ii) 4299 uix = uind(1,ii) 4300 uiy = uind(2,ii) 4301 uiz = uind(3,ii) 4302 uixp = uinp(1,ii) 4303 uiyp = uinp(2,ii) 4304 uizp = uinp(3,ii) 4305 do j = 1, tcgnab 4306 uax(j) = uad(1,ii,j) 4307 uay(j) = uad(2,ii,j) 4308 uaz(j) = uad(3,ii,j) 4309 uaxp(j) = uap(1,ii,j) 4310 uayp(j) = uap(2,ii,j) 4311 uazp(j) = uap(3,ii,j) 4312 ubx(j) = ubd(1,ii,j) 4313 uby(j) = ubd(2,ii,j) 4314 ubz(j) = ubd(3,ii,j) 4315 ubxp(j) = ubp(1,ii,j) 4316 ubyp(j) = ubp(2,ii,j) 4317 ubzp(j) = ubp(3,ii,j) 4318 end do 4319 if (use_thole) then 4320 pdi = pdamp(ii) 4321 pti = thole(ii) 4322 ddi = dirdamp(ii) 4323 else if (use_chgpen) then 4324 corei = pcore(ii) 4325 vali = pval(ii) 4326 alphai = palpha(ii) 4327 end if 4328c 4329c set exclusion coefficients for connected atoms 4330c 4331 if (dpequal) then 4332 do j = 1, n12(i) 4333 pscale(i12(j,i)) = p2scale 4334 do k = 1, np11(i) 4335 if (i12(j,i) .eq. ip11(k,i)) 4336 & pscale(i12(j,i)) = p2iscale 4337 end do 4338 dscale(i12(j,i)) = pscale(i12(j,i)) 4339 wscale(i12(j,i)) = w2scale 4340 end do 4341 do j = 1, n13(i) 4342 pscale(i13(j,i)) = p3scale 4343 do k = 1, np11(i) 4344 if (i13(j,i) .eq. ip11(k,i)) 4345 & pscale(i13(j,i)) = p3iscale 4346 end do 4347 dscale(i13(j,i)) = pscale(i13(j,i)) 4348 wscale(i13(j,i)) = w3scale 4349 end do 4350 do j = 1, n14(i) 4351 pscale(i14(j,i)) = p4scale 4352 do k = 1, np11(i) 4353 if (i14(j,i) .eq. ip11(k,i)) 4354 & pscale(i14(j,i)) = p4iscale 4355 end do 4356 dscale(i14(j,i)) = pscale(i14(j,i)) 4357 wscale(i14(j,i)) = w4scale 4358 end do 4359 do j = 1, n15(i) 4360 pscale(i15(j,i)) = p5scale 4361 do k = 1, np11(i) 4362 if (i15(j,i) .eq. ip11(k,i)) 4363 & pscale(i15(j,i)) = p5iscale 4364 end do 4365 dscale(i15(j,i)) = pscale(i15(j,i)) 4366 wscale(i15(j,i)) = w5scale 4367 end do 4368 do j = 1, np11(i) 4369 uscale(ip11(j,i)) = u1scale 4370 end do 4371 do j = 1, np12(i) 4372 uscale(ip12(j,i)) = u2scale 4373 end do 4374 do j = 1, np13(i) 4375 uscale(ip13(j,i)) = u3scale 4376 end do 4377 do j = 1, np14(i) 4378 uscale(ip14(j,i)) = u4scale 4379 end do 4380 else 4381 do j = 1, n12(i) 4382 pscale(i12(j,i)) = p2scale 4383 do k = 1, np11(i) 4384 if (i12(j,i) .eq. ip11(k,i)) 4385 & pscale(i12(j,i)) = p2iscale 4386 end do 4387 wscale(i12(j,i)) = w2scale 4388 end do 4389 do j = 1, n13(i) 4390 pscale(i13(j,i)) = p3scale 4391 do k = 1, np11(i) 4392 if (i13(j,i) .eq. ip11(k,i)) 4393 & pscale(i13(j,i)) = p3iscale 4394 end do 4395 wscale(i13(j,i)) = w3scale 4396 end do 4397 do j = 1, n14(i) 4398 pscale(i14(j,i)) = p4scale 4399 do k = 1, np11(i) 4400 if (i14(j,i) .eq. ip11(k,i)) 4401 & pscale(i14(j,i)) = p4iscale 4402 end do 4403 wscale(i14(j,i)) = w4scale 4404 end do 4405 do j = 1, n15(i) 4406 pscale(i15(j,i)) = p5scale 4407 do k = 1, np11(i) 4408 if (i15(j,i) .eq. ip11(k,i)) 4409 & pscale(i15(j,i)) = p5iscale 4410 end do 4411 wscale(i15(j,i)) = w5scale 4412 end do 4413 do j = 1, np11(i) 4414 dscale(ip11(j,i)) = d1scale 4415 uscale(ip11(j,i)) = u1scale 4416 end do 4417 do j = 1, np12(i) 4418 dscale(ip12(j,i)) = d2scale 4419 uscale(ip12(j,i)) = u2scale 4420 end do 4421 do j = 1, np13(i) 4422 dscale(ip13(j,i)) = d3scale 4423 uscale(ip13(j,i)) = u3scale 4424 end do 4425 do j = 1, np14(i) 4426 dscale(ip14(j,i)) = d4scale 4427 uscale(ip14(j,i)) = u4scale 4428 end do 4429 end if 4430c 4431c evaluate all sites within the cutoff distance 4432c 4433 do kk = ii+1, npole 4434 k = ipole(kk) 4435 xr = x(k) - xi 4436 yr = y(k) - yi 4437 zr = z(k) - zi 4438 if (use_bounds) call image (xr,yr,zr) 4439 r2 = xr*xr + yr*yr + zr*zr 4440 if (r2 .le. off2) then 4441 r = sqrt(r2) 4442 ck = rpole(1,kk) 4443 dkx = rpole(2,kk) 4444 dky = rpole(3,kk) 4445 dkz = rpole(4,kk) 4446 qkxx = rpole(5,kk) 4447 qkxy = rpole(6,kk) 4448 qkxz = rpole(7,kk) 4449 qkyy = rpole(9,kk) 4450 qkyz = rpole(10,kk) 4451 qkzz = rpole(13,kk) 4452 ukx = uind(1,kk) 4453 uky = uind(2,kk) 4454 ukz = uind(3,kk) 4455 ukxp = uinp(1,kk) 4456 ukyp = uinp(2,kk) 4457 ukzp = uinp(3,kk) 4458c 4459c intermediates involving moments and separation distance 4460c 4461 dir = dix*xr + diy*yr + diz*zr 4462 qix = qixx*xr + qixy*yr + qixz*zr 4463 qiy = qixy*xr + qiyy*yr + qiyz*zr 4464 qiz = qixz*xr + qiyz*yr + qizz*zr 4465 qir = qix*xr + qiy*yr + qiz*zr 4466 dkr = dkx*xr + dky*yr + dkz*zr 4467 qkx = qkxx*xr + qkxy*yr + qkxz*zr 4468 qky = qkxy*xr + qkyy*yr + qkyz*zr 4469 qkz = qkxz*xr + qkyz*yr + qkzz*zr 4470 qkr = qkx*xr + qky*yr + qkz*zr 4471 uir = uix*xr + uiy*yr + uiz*zr 4472 uirp = uixp*xr + uiyp*yr + uizp*zr 4473 ukr = ukx*xr + uky*yr + ukz*zr 4474 ukrp = ukxp*xr + ukyp*yr + ukzp*zr 4475c 4476c get reciprocal distance terms for this interaction 4477c 4478 rr1 = f / r 4479 rr3 = rr1 / r2 4480 rr5 = 3.0d0 * rr3 / r2 4481 rr7 = 5.0d0 * rr5 / r2 4482 rr9 = 7.0d0 * rr7 / r2 4483c 4484c calculate real space Ewald error function damping 4485c 4486 call dampewald (9,r,r2,f,dmpe) 4487c 4488c apply Thole polarization damping to scale factors 4489c 4490 sc3 = 1.0d0 4491 sc5 = 1.0d0 4492 sc7 = 1.0d0 4493 do j = 1, 3 4494 rc3(j) = 0.0d0 4495 rc5(j) = 0.0d0 4496 rc7(j) = 0.0d0 4497 end do 4498c 4499c apply Thole polarization damping to scale factors 4500c 4501 if (use_thole) then 4502 damp = pdi * pdamp(kk) 4503 if (use_dirdamp) then 4504 pgamma = min(ddi,dirdamp(kk)) 4505 if (pgamma .eq. 0.0d0) then 4506 pgamma = max(ddi,dirdamp(kk)) 4507 end if 4508 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 4509 damp = pgamma * (r/damp)**(1.5d0) 4510 if (damp .lt. 50.0d0) then 4511 expdamp = exp(-damp) 4512 sc3 = 1.0d0 - expdamp 4513 sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp) 4514 sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp 4515 & +0.15d0*damp**2) 4516 temp3 = 1.5d0 * damp * expdamp / r2 4517 temp5 = 0.5d0 * (1.0d0+damp) 4518 temp7 = 0.7d0 + 0.15d0*damp**2/temp5 4519 rc3(1) = xr * temp3 4520 rc3(2) = yr * temp3 4521 rc3(3) = zr * temp3 4522 rc5(1) = rc3(1) * temp5 4523 rc5(2) = rc3(2) * temp5 4524 rc5(3) = rc3(3) * temp5 4525 rc7(1) = rc5(1) * temp7 4526 rc7(2) = rc5(2) * temp7 4527 rc7(3) = rc5(3) * temp7 4528 end if 4529 end if 4530 else 4531 pgamma = min(pti,thole(kk)) 4532 if (pgamma .eq. 0.0d0) then 4533 pgamma = max(pti,thole(kk)) 4534 end if 4535 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 4536 damp = pgamma * (r/damp)**3 4537 if (damp .lt. 50.0d0) then 4538 expdamp = exp(-damp) 4539 sc3 = 1.0d0 - expdamp 4540 sc5 = 1.0d0 - (1.0d0+damp)*expdamp 4541 sc7 = 1.0d0 - (1.0d0+damp+0.6d0*damp**2) 4542 & *expdamp 4543 temp3 = 3.0d0 * damp * expdamp / r2 4544 temp5 = damp 4545 temp7 = -0.2d0 + 0.6d0*damp 4546 rc3(1) = xr * temp3 4547 rc3(2) = yr * temp3 4548 rc3(3) = zr * temp3 4549 rc5(1) = rc3(1) * temp5 4550 rc5(2) = rc3(2) * temp5 4551 rc5(3) = rc3(3) * temp5 4552 rc7(1) = rc5(1) * temp7 4553 rc7(2) = rc5(2) * temp7 4554 rc7(3) = rc5(3) * temp7 4555 end if 4556 end if 4557 end if 4558 psc3 = 1.0d0 - sc3*pscale(k) 4559 psc5 = 1.0d0 - sc5*pscale(k) 4560 psc7 = 1.0d0 - sc7*pscale(k) 4561 dsc3 = 1.0d0 - sc3*dscale(k) 4562 dsc5 = 1.0d0 - sc5*dscale(k) 4563 dsc7 = 1.0d0 - sc7*dscale(k) 4564 usc3 = 1.0d0 - sc3*uscale(k) 4565 usc5 = 1.0d0 - sc5*uscale(k) 4566 psr3 = dmpe(3) - psc3*rr3 4567 psr5 = dmpe(5) - psc5*rr5 4568 psr7 = dmpe(7) - psc7*rr7 4569 dsr3 = dmpe(3) - dsc3*rr3 4570 dsr5 = dmpe(5) - dsc5*rr5 4571 dsr7 = dmpe(7) - dsc7*rr7 4572 usr3 = dmpe(3) - usc3*rr3 4573 usr5 = dmpe(5) - usc5*rr5 4574 do j = 1, 3 4575 prc3(j) = rc3(j) * pscale(k) 4576 prc5(j) = rc5(j) * pscale(k) 4577 prc7(j) = rc7(j) * pscale(k) 4578 drc3(j) = rc3(j) * dscale(k) 4579 drc5(j) = rc5(j) * dscale(k) 4580 drc7(j) = rc7(j) * dscale(k) 4581 urc3(j) = rc3(j) * uscale(k) 4582 urc5(j) = rc5(j) * uscale(k) 4583 end do 4584c 4585c apply charge penetration damping to scale factors 4586c 4587 else if (use_chgpen) then 4588 corek = pcore(kk) 4589 valk = pval(kk) 4590 alphak = palpha(kk) 4591 call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik) 4592 rr3core = dmpe(3) - (1.0d0-dscale(k))*rr3 4593 rr5core = dmpe(5) - (1.0d0-dscale(k))*rr5 4594 rr3i = dmpe(3) - (1.0d0-dscale(k)*dmpi(3))*rr3 4595 rr5i = dmpe(5) - (1.0d0-dscale(k)*dmpi(5))*rr5 4596 rr7i = dmpe(7) - (1.0d0-dscale(k)*dmpi(7))*rr7 4597 rr9i = dmpe(9) - (1.0d0-dscale(k)*dmpi(9))*rr9 4598 rr3k = dmpe(3) - (1.0d0-dscale(k)*dmpk(3))*rr3 4599 rr5k = dmpe(5) - (1.0d0-dscale(k)*dmpk(5))*rr5 4600 rr7k = dmpe(7) - (1.0d0-dscale(k)*dmpk(7))*rr7 4601 rr9k = dmpe(9) - (1.0d0-dscale(k)*dmpk(9))*rr9 4602 rr5ik = dmpe(5) - (1.0d0-wscale(k)*dmpik(5))*rr5 4603 rr7ik = dmpe(7) - (1.0d0-wscale(k)*dmpik(7))*rr7 4604 end if 4605c 4606c store the potential at each site for use in charge flux 4607c 4608 if (use_chgflx) then 4609 if (use_thole) then 4610 poti = -ukr*psr3 - ukrp*dsr3 4611 potk = uir*psr3 + uirp*dsr3 4612 else if (use_chgpen) then 4613 poti = -2.0d0 * ukr * rr3i 4614 potk = 2.0d0 * uir * rr3k 4615 end if 4616 pot(i) = pot(i) + poti 4617 pot(k) = pot(k) + potk 4618 end if 4619c 4620c get the induced dipole field used for dipole torques 4621c 4622 if (use_thole) then 4623 tix3 = psr3*ukx + dsr3*ukxp 4624 tiy3 = psr3*uky + dsr3*ukyp 4625 tiz3 = psr3*ukz + dsr3*ukzp 4626 tkx3 = psr3*uix + dsr3*uixp 4627 tky3 = psr3*uiy + dsr3*uiyp 4628 tkz3 = psr3*uiz + dsr3*uizp 4629 tuir = -psr5*ukr - dsr5*ukrp 4630 tukr = -psr5*uir - dsr5*uirp 4631 else if (use_chgpen) then 4632 tix3 = 2.0d0*rr3i*ukx 4633 tiy3 = 2.0d0*rr3i*uky 4634 tiz3 = 2.0d0*rr3i*ukz 4635 tkx3 = 2.0d0*rr3k*uix 4636 tky3 = 2.0d0*rr3k*uiy 4637 tkz3 = 2.0d0*rr3k*uiz 4638 tuir = -2.0d0*rr5i*ukr 4639 tukr = -2.0d0*rr5k*uir 4640 end if 4641 ufld(1,i) = ufld(1,i) + tix3 + xr*tuir 4642 ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir 4643 ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir 4644 ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr 4645 ufld(2,k) = ufld(2,k) + tky3 + yr*tukr 4646 ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr 4647c 4648c get induced dipole field gradient used for quadrupole torques 4649c 4650 if (use_thole) then 4651 tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp) 4652 tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp) 4653 tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp) 4654 tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp) 4655 tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp) 4656 tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp) 4657 tuir = -psr7*ukr - dsr7*ukrp 4658 tukr = -psr7*uir - dsr7*uirp 4659 else if (use_chgpen) then 4660 tix5 = 4.0d0 * (rr5i*ukx) 4661 tiy5 = 4.0d0 * (rr5i*uky) 4662 tiz5 = 4.0d0 * (rr5i*ukz) 4663 tkx5 = 4.0d0 * (rr5k*uix) 4664 tky5 = 4.0d0 * (rr5k*uiy) 4665 tkz5 = 4.0d0 * (rr5k*uiz) 4666 tuir = -2.0d0*rr7i*ukr 4667 tukr = -2.0d0*rr7k*uir 4668 end if 4669 dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir 4670 dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5 4671 & + 2.0d0*xr*yr*tuir 4672 dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir 4673 dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5 4674 & + 2.0d0*xr*zr*tuir 4675 dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5 4676 & + 2.0d0*yr*zr*tuir 4677 dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir 4678 dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr 4679 dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5 4680 & - 2.0d0*xr*yr*tukr 4681 dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr 4682 dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5 4683 & - 2.0d0*xr*zr*tukr 4684 dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5 4685 & - 2.0d0*yr*zr*tukr 4686 dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr 4687c 4688c get the dEd/dR terms used for direct polarization force 4689c 4690 if (use_thole) then 4691 term1 = dmpe(5) - dsc3*rr5 4692 term2 = dmpe(7) - dsc5*rr7 4693 term3 = -dsr3 + term1*xr*xr - rr3*xr*drc3(1) 4694 term4 = rr3*drc3(1) - term1*xr - dsr5*xr 4695 term5 = term2*xr*xr - dsr5 - rr5*xr*drc5(1) 4696 term6 = (dmpe(9)-dsc7*rr9)*xr*xr - dmpe(7) 4697 & - rr7*xr*drc7(1) 4698 term7 = rr5*drc5(1) - 2.0d0*dmpe(7)*xr 4699 & + (dsc5+1.5d0*dsc7)*rr7*xr 4700 tixx = ci*term3 + dix*term4 + dir*term5 4701 & + 2.0d0*dsr5*qixx + (qiy*yr+qiz*zr)*dsc7*rr7 4702 & + 2.0d0*qix*term7 + qir*term6 4703 tkxx = ck*term3 - dkx*term4 - dkr*term5 4704 & + 2.0d0*dsr5*qkxx + (qky*yr+qkz*zr)*dsc7*rr7 4705 & + 2.0d0*qkx*term7 + qkr*term6 4706 term3 = -dsr3 + term1*yr*yr - rr3*yr*drc3(2) 4707 term4 = rr3*drc3(2) - term1*yr - dsr5*yr 4708 term5 = term2*yr*yr - dsr5 - rr5*yr*drc5(2) 4709 term6 = (dmpe(9)-dsc7*rr9)*yr*yr - dmpe(7) 4710 & - rr7*yr*drc7(2) 4711 term7 = rr5*drc5(2) - 2.0d0*dmpe(7)*yr 4712 & + (dsc5+1.5d0*dsc7)*rr7*yr 4713 tiyy = ci*term3 + diy*term4 + dir*term5 4714 & + 2.0d0*dsr5*qiyy + (qix*xr+qiz*zr)*dsc7*rr7 4715 & + 2.0d0*qiy*term7 + qir*term6 4716 tkyy = ck*term3 - dky*term4 - dkr*term5 4717 & + 2.0d0*dsr5*qkyy + (qkx*xr+qkz*zr)*dsc7*rr7 4718 & + 2.0d0*qky*term7 + qkr*term6 4719 term3 = -dsr3 + term1*zr*zr - rr3*zr*drc3(3) 4720 term4 = rr3*drc3(3) - term1*zr - dsr5*zr 4721 term5 = term2*zr*zr - dsr5 - rr5*zr*drc5(3) 4722 term6 = (dmpe(9)-dsc7*rr9)*zr*zr - dmpe(7) 4723 & - rr7*zr*drc7(3) 4724 term7 = rr5*drc5(3) - 2.0d0*dmpe(7)*zr 4725 & + (dsc5+1.5d0*dsc7)*rr7*zr 4726 tizz = ci*term3 + diz*term4 + dir*term5 4727 & + 2.0d0*dsr5*qizz + (qix*xr+qiy*yr)*dsc7*rr7 4728 & + 2.0d0*qiz*term7 + qir*term6 4729 tkzz = ck*term3 - dkz*term4 - dkr*term5 4730 & + 2.0d0*dsr5*qkzz + (qkx*xr+qky*yr)*dsc7*rr7 4731 & + 2.0d0*qkz*term7 + qkr*term6 4732 term3 = term1*xr*yr - rr3*yr*drc3(1) 4733 term4 = rr3*drc3(1) - term1*xr 4734 term5 = term2*xr*yr - rr5*yr*drc5(1) 4735 term6 = (dmpe(9)-dsc7*rr9)*xr*yr - rr7*yr*drc7(1) 4736 term7 = rr5*drc5(1) - term2*xr 4737 tixy = ci*term3 - dsr5*dix*yr + diy*term4 + dir*term5 4738 & + 2.0d0*dsr5*qixy - 2.0d0*dsr7*yr*qix 4739 & + 2.0d0*qiy*term7 + qir*term6 4740 tkxy = ck*term3 + dsr5*dkx*yr - dky*term4 - dkr*term5 4741 & + 2.0d0*dsr5*qkxy - 2.0d0*dsr7*yr*qkx 4742 & + 2.0d0*qky*term7 + qkr*term6 4743 term3 = term1*xr*zr - rr3*zr*drc3(1) 4744 term5 = term2*xr*zr - rr5*zr*drc5(1) 4745 term6 = (dmpe(9)-dsc7*rr9)*xr*zr - rr7*zr*drc7(1) 4746 tixz = ci*term3 - dsr5*dix*zr + diz*term4 + dir*term5 4747 & + 2.0d0*dsr5*qixz - 2.0d0*dsr7*zr*qix 4748 & + 2.0d0*qiz*term7 + qir*term6 4749 tkxz = ck*term3 + dsr5*dkx*zr - dkz*term4 - dkr*term5 4750 & + 2.0d0*dsr5*qkxz - 2.0d0*dsr7*zr*qkx 4751 & + 2.0d0*qkz*term7 + qkr*term6 4752 term3 = term1*yr*zr - rr3*zr*drc3(2) 4753 term4 = rr3*drc3(2) - term1*yr 4754 term5 = term2*yr*zr - rr5*zr*drc5(2) 4755 term6 = (dmpe(9)-dsc7*rr9)*yr*zr - rr7*zr*drc7(2) 4756 term7 = rr5*drc5(2) - term2*yr 4757 tiyz = ci*term3 - dsr5*diy*zr + diz*term4 + dir*term5 4758 & + 2.0d0*dsr5*qiyz - 2.0d0*dsr7*zr*qiy 4759 & + 2.0d0*qiz*term7 + qir*term6 4760 tkyz = ck*term3 + dsr5*dky*zr - dkz*term4 - dkr*term5 4761 & + 2.0d0*dsr5*qkyz - 2.0d0*dsr7*zr*qky 4762 & + 2.0d0*qkz*term7 + qkr*term6 4763 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 4764 & - tkxx*uixp - tkxy*uiyp - tkxz*uizp 4765 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 4766 & - tkxy*uixp - tkyy*uiyp - tkyz*uizp 4767 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 4768 & - tkxz*uixp - tkyz*uiyp - tkzz*uizp 4769 frcx = depx 4770 frcy = depy 4771 frcz = depz 4772c 4773c get the dEp/dR terms used for direct polarization force 4774c 4775 term1 = dmpe(5) - psc3*rr5 4776 term2 = dmpe(7) - psc5*rr7 4777 term3 = -psr3 + term1*xr*xr - rr3*xr*prc3(1) 4778 term4 = rr3*prc3(1) - term1*xr - psr5*xr 4779 term5 = term2*xr*xr - psr5 - rr5*xr*prc5(1) 4780 term6 = (dmpe(9)-psc7*rr9)*xr*xr - dmpe(7) 4781 & - rr7*xr*prc7(1) 4782 term7 = rr5*prc5(1) - 2.0d0*dmpe(7)*xr 4783 & + (psc5+1.5d0*psc7)*rr7*xr 4784 tixx = ci*term3 + dix*term4 + dir*term5 4785 & + 2.0d0*psr5*qixx + (qiy*yr+qiz*zr)*psc7*rr7 4786 & + 2.0d0*qix*term7 + qir*term6 4787 tkxx = ck*term3 - dkx*term4 - dkr*term5 4788 & + 2.0d0*psr5*qkxx + (qky*yr+qkz*zr)*psc7*rr7 4789 & + 2.0d0*qkx*term7 + qkr*term6 4790 term3 = -psr3 + term1*yr*yr - rr3*yr*prc3(2) 4791 term4 = rr3*prc3(2) - term1*yr - psr5*yr 4792 term5 = term2*yr*yr - psr5 - rr5*yr*prc5(2) 4793 term6 = (dmpe(9)-psc7*rr9)*yr*yr - dmpe(7) 4794 & - rr7*yr*prc7(2) 4795 term7 = rr5*prc5(2) - 2.0d0*dmpe(7)*yr 4796 & + (psc5+1.5d0*psc7)*rr7*yr 4797 tiyy = ci*term3 + diy*term4 + dir*term5 4798 & + 2.0d0*psr5*qiyy + (qix*xr+qiz*zr)*psc7*rr7 4799 & + 2.0d0*qiy*term7 + qir*term6 4800 tkyy = ck*term3 - dky*term4 - dkr*term5 4801 & + 2.0d0*psr5*qkyy + (qkx*xr+qkz*zr)*psc7*rr7 4802 & + 2.0d0*qky*term7 + qkr*term6 4803 term3 = -psr3 + term1*zr*zr - rr3*zr*prc3(3) 4804 term4 = rr3*prc3(3) - term1*zr - psr5*zr 4805 term5 = term2*zr*zr - psr5 - rr5*zr*prc5(3) 4806 term6 = (dmpe(9)-psc7*rr9)*zr*zr - dmpe(7) 4807 & - rr7*zr*prc7(3) 4808 term7 = rr5*prc5(3) - 2.0d0*dmpe(7)*zr 4809 & + (psc5+1.5d0*psc7)*rr7*zr 4810 tizz = ci*term3 + diz*term4 + dir*term5 4811 & + 2.0d0*psr5*qizz + (qix*xr+qiy*yr)*psc7*rr7 4812 & + 2.0d0*qiz*term7 + qir*term6 4813 tkzz = ck*term3 - dkz*term4 - dkr*term5 4814 & + 2.0d0*psr5*qkzz + (qkx*xr+qky*yr)*psc7*rr7 4815 & + 2.0d0*qkz*term7 + qkr*term6 4816 term3 = term1*xr*yr - rr3*yr*prc3(1) 4817 term4 = rr3*prc3(1) - term1*xr 4818 term5 = term2*xr*yr - rr5*yr*prc5(1) 4819 term6 = (dmpe(9)-psc7*rr9)*xr*yr - rr7*yr*prc7(1) 4820 term7 = rr5*prc5(1) - term2*xr 4821 tixy = ci*term3 - psr5*dix*yr + diy*term4 + dir*term5 4822 & + 2.0d0*psr5*qixy - 2.0d0*psr7*yr*qix 4823 & + 2.0d0*qiy*term7 + qir*term6 4824 tkxy = ck*term3 + psr5*dkx*yr - dky*term4 - dkr*term5 4825 & + 2.0d0*psr5*qkxy - 2.0d0*psr7*yr*qkx 4826 & + 2.0d0*qky*term7 + qkr*term6 4827 term3 = term1*xr*zr - rr3*zr*prc3(1) 4828 term5 = term2*xr*zr - rr5*zr*prc5(1) 4829 term6 = (dmpe(9)-psc7*rr9)*xr*zr - rr7*zr*prc7(1) 4830 tixz = ci*term3 - psr5*dix*zr + diz*term4 + dir*term5 4831 & + 2.0d0*psr5*qixz - 2.0d0*psr7*zr*qix 4832 & + 2.0d0*qiz*term7 + qir*term6 4833 tkxz = ck*term3 + psr5*dkx*zr - dkz*term4 - dkr*term5 4834 & + 2.0d0*psr5*qkxz - 2.0d0*psr7*zr*qkx 4835 & + 2.0d0*qkz*term7 + qkr*term6 4836 term3 = term1*yr*zr - rr3*zr*prc3(2) 4837 term4 = rr3*prc3(2) - term1*yr 4838 term5 = term2*yr*zr - rr5*zr*prc5(2) 4839 term6 = (dmpe(9)-psc7*rr9)*yr*zr - rr7*zr*prc7(2) 4840 term7 = rr5*prc5(2) - term2*yr 4841 tiyz = ci*term3 - psr5*diy*zr + diz*term4 + dir*term5 4842 & + 2.0d0*psr5*qiyz - 2.0d0*psr7*zr*qiy 4843 & + 2.0d0*qiz*term7 + qir*term6 4844 tkyz = ck*term3 + psr5*dky*zr - dkz*term4 - dkr*term5 4845 & + 2.0d0*psr5*qkyz - 2.0d0*psr7*zr*qky 4846 & + 2.0d0*qkz*term7 + qkr*term6 4847 depx = tixx*ukx + tixy*uky + tixz*ukz 4848 & - tkxx*uix - tkxy*uiy - tkxz*uiz 4849 depy = tixy*ukx + tiyy*uky + tiyz*ukz 4850 & - tkxy*uix - tkyy*uiy - tkyz*uiz 4851 depz = tixz*ukx + tiyz*uky + tizz*ukz 4852 & - tkxz*uix - tkyz*uiy - tkzz*uiz 4853 frcx = frcx + depx 4854 frcy = frcy + depy 4855 frcz = frcz + depz 4856c 4857c get the field gradient for direct polarization force 4858c 4859 else if (use_chgpen) then 4860 term1i = rr3i - rr5i*xr*xr 4861 term1core = rr3core - rr5core*xr*xr 4862 term2i = 2.0d0*rr5i*xr 4863 term3i = rr7i*xr*xr - rr5i 4864 term4i = 2.0d0*rr5i 4865 term5i = 5.0d0*rr7i*xr 4866 term6i = rr9i*xr*xr 4867 term1k = rr3k - rr5k*xr*xr 4868 term2k = 2.0d0*rr5k*xr 4869 term3k = rr7k*xr*xr - rr5k 4870 term4k = 2.0d0*rr5k 4871 term5k = 5.0d0*rr7k*xr 4872 term6k = rr9k*xr*xr 4873 tixx = vali*term1i + corei*term1core 4874 & + dix*term2i - dir*term3i 4875 & - qixx*term4i + qix*term5i - qir*term6i 4876 & + (qiy*yr+qiz*zr)*rr7i 4877 tkxx = valk*term1k + corek*term1core 4878 & - dkx*term2k + dkr*term3k 4879 & - qkxx*term4k + qkx*term5k - qkr*term6k 4880 & + (qky*yr+qkz*zr)*rr7k 4881 term1i = rr3i - rr5i*yr*yr 4882 term1core = rr3core - rr5core*yr*yr 4883 term2i = 2.0d0*rr5i*yr 4884 term3i = rr7i*yr*yr - rr5i 4885 term4i = 2.0d0*rr5i 4886 term5i = 5.0d0*rr7i*yr 4887 term6i = rr9i*yr*yr 4888 term1k = rr3k - rr5k*yr*yr 4889 term2k = 2.0d0*rr5k*yr 4890 term3k = rr7k*yr*yr - rr5k 4891 term4k = 2.0d0*rr5k 4892 term5k = 5.0d0*rr7k*yr 4893 term6k = rr9k*yr*yr 4894 tiyy = vali*term1i + corei*term1core 4895 & + diy*term2i - dir*term3i 4896 & - qiyy*term4i + qiy*term5i - qir*term6i 4897 & + (qix*xr+qiz*zr)*rr7i 4898 tkyy = valk*term1k + corek*term1core 4899 & - dky*term2k + dkr*term3k 4900 & - qkyy*term4k + qky*term5k - qkr*term6k 4901 & + (qkx*xr+qkz*zr)*rr7k 4902 term1i = rr3i - rr5i*zr*zr 4903 term1core = rr3core - rr5core*zr*zr 4904 term2i = 2.0d0*rr5i*zr 4905 term3i = rr7i*zr*zr - rr5i 4906 term4i = 2.0d0*rr5i 4907 term5i = 5.0d0*rr7i*zr 4908 term6i = rr9i*zr*zr 4909 term1k = rr3k - rr5k*zr*zr 4910 term2k = 2.0d0*rr5k*zr 4911 term3k = rr7k*zr*zr - rr5k 4912 term4k = 2.0d0*rr5k 4913 term5k = 5.0d0*rr7k*zr 4914 term6k = rr9k*zr*zr 4915 tizz = vali*term1i + corei*term1core 4916 & + diz*term2i - dir*term3i 4917 & - qizz*term4i + qiz*term5i - qir*term6i 4918 & + (qix*xr+qiy*yr)*rr7i 4919 tkzz = valk*term1k + corek*term1core 4920 & - dkz*term2k + dkr*term3k 4921 & - qkzz*term4k + qkz*term5k - qkr*term6k 4922 & + (qkx*xr+qky*yr)*rr7k 4923 term2i = rr5i*xr 4924 term1i = yr * term2i 4925 term1core = rr5core*xr*yr 4926 term3i = rr5i*yr 4927 term4i = yr * (rr7i*xr) 4928 term5i = 2.0d0*rr5i 4929 term6i = 2.0d0*rr7i*xr 4930 term7i = 2.0d0*rr7i*yr 4931 term8i = yr*rr9i*xr 4932 term2k = rr5k*xr 4933 term1k = yr * term2k 4934 term3k = rr5k*yr 4935 term4k = yr * (rr7k*xr) 4936 term5k = 2.0d0*rr5k 4937 term6k = 2.0d0*rr7k*xr 4938 term7k = 2.0d0*rr7k*yr 4939 term8k = yr*rr9k*xr 4940 tixy = -vali*term1i - corei*term1core 4941 & + diy*term2i + dix*term3i 4942 & - dir*term4i - qixy*term5i + qiy*term6i 4943 & + qix*term7i - qir*term8i 4944 tkxy = -valk*term1k - corek*term1core 4945 & - dky*term2k - dkx*term3k 4946 & + dkr*term4k - qkxy*term5k + qky*term6k 4947 & + qkx*term7k - qkr*term8k 4948 term2i = rr5i*xr 4949 term1i = zr * term2i 4950 term1core = rr5core*xr*zr 4951 term3i = rr5i*zr 4952 term4i = zr * (rr7i*xr) 4953 term5i = 2.0d0*rr5i 4954 term6i = 2.0d0*rr7i*xr 4955 term7i = 2.0d0*rr7i*zr 4956 term8i = zr*rr9i*xr 4957 term2k = rr5k*xr 4958 term1k = zr * term2k 4959 term3k = rr5k*zr 4960 term4k = zr * (rr7k*xr) 4961 term5k = 2.0d0*rr5k 4962 term6k = 2.0d0*rr7k*xr 4963 term7k = 2.0d0*rr7k*zr 4964 term8k = zr*rr9k*xr 4965 tixz = -vali*term1i - corei*term1core 4966 & + diz*term2i + dix*term3i 4967 & - dir*term4i - qixz*term5i + qiz*term6i 4968 & + qix*term7i - qir*term8i 4969 tkxz = -valk*term1k - corek*term1core 4970 & - dkz*term2k - dkx*term3k 4971 & + dkr*term4k - qkxz*term5k + qkz*term6k 4972 & + qkx*term7k - qkr*term8k 4973 term2i = rr5i*yr 4974 term1i = zr * term2i 4975 term1core = rr5core*yr*zr 4976 term3i = rr5i*zr 4977 term4i = zr * (rr7i*yr) 4978 term5i = 2.0d0*rr5i 4979 term6i = 2.0d0*rr7i*yr 4980 term7i = 2.0d0*rr7i*zr 4981 term8i = zr*rr9i*yr 4982 term2k = rr5k*yr 4983 term1k = zr * term2k 4984 term3k = rr5k*zr 4985 term4k = zr * (rr7k*yr) 4986 term5k = 2.0d0*rr5k 4987 term6k = 2.0d0*rr7k*yr 4988 term7k = 2.0d0*rr7k*zr 4989 term8k = zr*rr9k*yr 4990 tiyz = -vali*term1i - corei*term1core 4991 & + diz*term2i + diy*term3i 4992 & - dir*term4i - qiyz*term5i + qiz*term6i 4993 & + qiy*term7i - qir*term8i 4994 tkyz = -valk*term1k - corek*term1core 4995 & - dkz*term2k - dky*term3k 4996 & + dkr*term4k - qkyz*term5k + qkz*term6k 4997 & + qky*term7k - qkr*term8k 4998 depx = tixx*ukx + tixy*uky + tixz*ukz 4999 & - tkxx*uix - tkxy*uiy - tkxz*uiz 5000 depy = tixy*ukx + tiyy*uky + tiyz*ukz 5001 & - tkxy*uix - tkyy*uiy - tkyz*uiz 5002 depz = tixz*ukx + tiyz*uky + tizz*ukz 5003 & - tkxz*uix - tkyz*uiy - tkzz*uiz 5004 frcx = -2.0d0 * depx 5005 frcy = -2.0d0 * depy 5006 frcz = -2.0d0 * depz 5007 end if 5008c 5009c reset Thole values if alternate direct damping was used 5010c 5011 if (use_dirdamp) then 5012 sc3 = 1.0d0 5013 sc5 = 1.0d0 5014 do j = 1, 3 5015 rc3(j) = 0.0d0 5016 rc5(j) = 0.0d0 5017 end do 5018 damp = pdi * pdamp(kk) 5019 if (damp .ne. 0.0d0) then 5020 pgamma = min(pti,thole(kk)) 5021 damp = pgamma * (r/damp)**3 5022 if (damp .lt. 50.0d0) then 5023 expdamp = exp(-damp) 5024 sc3 = 1.0d0 - expdamp 5025 sc5 = 1.0d0 - expdamp*(1.0d0+damp) 5026 temp3 = 3.0d0 * damp * expdamp / r2 5027 temp5 = damp 5028 rc3(1) = xr * temp3 5029 rc3(2) = yr * temp3 5030 rc3(3) = zr * temp3 5031 rc5(1) = rc3(1) * temp5 5032 rc5(2) = rc3(2) * temp5 5033 rc5(3) = rc3(3) * temp5 5034 end if 5035 end if 5036 usc3 = 1.0d0 - sc3*uscale(k) 5037 usc5 = 1.0d0 - sc5*uscale(k) 5038 usr3 = dmpe(3) - usc3*rr3 5039 usr5 = dmpe(5) - usc5*rr5 5040 do j = 1, 3 5041 urc3(j) = rc3(j) * uscale(k) 5042 urc5(j) = rc5(j) * uscale(k) 5043 end do 5044 end if 5045c 5046c get the dtau/dr terms used for mutual polarization force 5047c 5048 if (poltyp.eq.'MUTUAL' .and. use_thole) then 5049 term1 = dmpe(5) - usc3*rr5 5050 term2 = dmpe(7) - usc5*rr7 5051 term3 = usr5 + term1 5052 term4 = rr3 * uscale(k) 5053 term5 = -xr*term3 + rc3(1)*term4 5054 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 5055 tixx = uix*term5 + uir*term6 5056 tkxx = ukx*term5 + ukr*term6 5057 term5 = -yr*term3 + rc3(2)*term4 5058 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 5059 tiyy = uiy*term5 + uir*term6 5060 tkyy = uky*term5 + ukr*term6 5061 term5 = -zr*term3 + rc3(3)*term4 5062 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 5063 tizz = uiz*term5 + uir*term6 5064 tkzz = ukz*term5 + ukr*term6 5065 term4 = -usr5 * yr 5066 term5 = -xr*term1 + rr3*urc3(1) 5067 term6 = xr*yr*term2 - rr5*yr*urc5(1) 5068 tixy = uix*term4 + uiy*term5 + uir*term6 5069 tkxy = ukx*term4 + uky*term5 + ukr*term6 5070 term4 = -usr5 * zr 5071 term6 = xr*zr*term2 - rr5*zr*urc5(1) 5072 tixz = uix*term4 + uiz*term5 + uir*term6 5073 tkxz = ukx*term4 + ukz*term5 + ukr*term6 5074 term5 = -yr*term1 + rr3*urc3(2) 5075 term6 = yr*zr*term2 - rr5*zr*urc5(2) 5076 tiyz = uiy*term4 + uiz*term5 + uir*term6 5077 tkyz = uky*term4 + ukz*term5 + ukr*term6 5078 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 5079 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 5080 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 5081 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 5082 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 5083 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 5084 frcx = frcx + depx 5085 frcy = frcy + depy 5086 frcz = frcz + depz 5087c 5088c get the dtau/dr terms used for mutual polarization force 5089c 5090 else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then 5091 term1 = 2.0d0 * rr5ik 5092 term2 = term1*xr 5093 term3 = rr5ik - rr7ik*xr*xr 5094 tixx = uix*term2 + uir*term3 5095 tkxx = ukx*term2 + ukr*term3 5096 term2 = term1*yr 5097 term3 = rr5ik - rr7ik*yr*yr 5098 tiyy = uiy*term2 + uir*term3 5099 tkyy = uky*term2 + ukr*term3 5100 term2 = term1*zr 5101 term3 = rr5ik - rr7ik*zr*zr 5102 tizz = uiz*term2 + uir*term3 5103 tkzz = ukz*term2 + ukr*term3 5104 term1 = rr5ik*yr 5105 term2 = rr5ik*xr 5106 term3 = yr * (rr7ik*xr) 5107 tixy = uix*term1 + uiy*term2 - uir*term3 5108 tkxy = ukx*term1 + uky*term2 - ukr*term3 5109 term1 = rr5ik * zr 5110 term3 = zr * (rr7ik*xr) 5111 tixz = uix*term1 + uiz*term2 - uir*term3 5112 tkxz = ukx*term1 + ukz*term2 - ukr*term3 5113 term2 = rr5ik*yr 5114 term3 = zr * (rr7ik*yr) 5115 tiyz = uiy*term1 + uiz*term2 - uir*term3 5116 tkyz = uky*term1 + ukz*term2 - ukr*term3 5117 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 5118 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 5119 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 5120 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 5121 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 5122 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 5123 frcx = frcx - depx 5124 frcy = frcy - depy 5125 frcz = frcz - depz 5126c 5127c get the dtau/dr terms used for OPT polarization force 5128c 5129 else if (poltyp.eq.'OPT' .and. use_thole) then 5130 do j = 0, optorder-1 5131 uirm = uopt(j,1,ii)*xr + uopt(j,2,ii)*yr 5132 & + uopt(j,3,ii)*zr 5133 do m = 0, optorder-j-1 5134 ukrm = uopt(m,1,kk)*xr + uopt(m,2,kk)*yr 5135 & + uopt(m,3,kk)*zr 5136 term1 = dmpe(5) - usc3*rr5 5137 term2 = dmpe(7) - usc5*rr7 5138 term3 = usr5 + term1 5139 term4 = rr3 * uscale(k) 5140 term5 = -xr*term3 + rc3(1)*term4 5141 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 5142 tixx = uopt(j,1,ii)*term5 + uirm*term6 5143 tkxx = uopt(m,1,kk)*term5 + ukrm*term6 5144 term5 = -yr*term3 + rc3(2)*term4 5145 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 5146 tiyy = uopt(j,2,ii)*term5 + uirm*term6 5147 tkyy = uopt(m,2,kk)*term5 + ukrm*term6 5148 term5 = -zr*term3 + rc3(3)*term4 5149 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 5150 tizz = uopt(j,3,ii)*term5 + uirm*term6 5151 tkzz = uopt(m,3,kk)*term5 + ukrm*term6 5152 term4 = -usr5 * yr 5153 term5 = -xr*term1 + rr3*urc3(1) 5154 term6 = xr*yr*term2 - rr5*yr*urc5(1) 5155 tixy = uopt(j,1,ii)*term4 + uopt(j,2,ii)*term5 5156 & + uirm*term6 5157 tkxy = uopt(m,1,kk)*term4 + uopt(m,2,kk)*term5 5158 & + ukrm*term6 5159 term4 = -usr5 * zr 5160 term6 = xr*zr*term2 - rr5*zr*urc5(1) 5161 tixz = uopt(j,1,ii)*term4 + uopt(j,3,ii)*term5 5162 & + uirm*term6 5163 tkxz = uopt(m,1,kk)*term4 + uopt(m,3,kk)*term5 5164 & + ukrm*term6 5165 term5 = -yr*term1 + rr3*urc3(2) 5166 term6 = yr*zr*term2 - rr5*zr*urc5(2) 5167 tiyz = uopt(j,2,ii)*term4 + uopt(j,3,ii)*term5 5168 & + uirm*term6 5169 tkyz = uopt(m,2,kk)*term4 + uopt(m,3,kk)*term5 5170 & + ukrm*term6 5171 depx = tixx*uoptp(m,1,kk) + tkxx*uoptp(j,1,ii) 5172 & + tixy*uoptp(m,2,kk) + tkxy*uoptp(j,2,ii) 5173 & + tixz*uoptp(m,3,kk) + tkxz*uoptp(j,3,ii) 5174 depy = tixy*uoptp(m,1,kk) + tkxy*uoptp(j,1,ii) 5175 & + tiyy*uoptp(m,2,kk) + tkyy*uoptp(j,2,ii) 5176 & + tiyz*uoptp(m,3,kk) + tkyz*uoptp(j,3,ii) 5177 depz = tixz*uoptp(m,1,kk) + tkxz*uoptp(j,1,ii) 5178 & + tiyz*uoptp(m,2,kk) + tkyz*uoptp(j,2,ii) 5179 & + tizz*uoptp(m,3,kk) + tkzz*uoptp(j,3,ii) 5180 frcx = frcx + copm(j+m+1)*depx 5181 frcy = frcy + copm(j+m+1)*depy 5182 frcz = frcz + copm(j+m+1)*depz 5183 end do 5184 end do 5185c 5186c get the dtau/dr terms used for OPT polarization force 5187c 5188 else if (poltyp.eq.'OPT' .and. use_chgpen) then 5189 do j = 0, optorder-1 5190 uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr 5191 & + uopt(j,3,i)*zr 5192 do m = 0, optorder-j-1 5193 ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr 5194 & + uopt(m,3,k)*zr 5195 term1 = 2.0d0 * rr5ik 5196 term2 = term1*xr 5197 term3 = rr5ik - rr7ik*xr*xr 5198 tixx = uopt(j,1,i)*term2 + uirm*term3 5199 tkxx = uopt(m,1,k)*term2 + ukrm*term3 5200 term2 = term1*yr 5201 term3 = rr5ik - rr7ik*yr*yr 5202 tiyy = uopt(j,2,i)*term2 + uirm*term3 5203 tkyy = uopt(m,2,k)*term2 + ukrm*term3 5204 term2 = term1*zr 5205 term3 = rr5ik - rr7ik*zr*zr 5206 tizz = uopt(j,3,i)*term2 + uirm*term3 5207 tkzz = uopt(m,3,k)*term2 + ukrm*term3 5208 term1 = rr5ik*yr 5209 term2 = rr5ik*xr 5210 term3 = yr * (rr7ik*xr) 5211 tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2 5212 & - uirm*term3 5213 tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2 5214 & - ukrm*term3 5215 term1 = rr5ik * zr 5216 term3 = zr * (rr7ik*xr) 5217 tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2 5218 & - uirm*term3 5219 tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2 5220 & - ukrm*term3 5221 term2 = rr5ik*yr 5222 term3 = zr * (rr7ik*yr) 5223 tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2 5224 & - uirm*term3 5225 tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2 5226 & - ukrm*term3 5227 depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i) 5228 & + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i) 5229 & + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i) 5230 depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i) 5231 & + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i) 5232 & + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i) 5233 depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i) 5234 & + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i) 5235 & + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i) 5236 frcx = frcx - copm(j+m+1)*depx 5237 frcy = frcy - copm(j+m+1)*depy 5238 frcz = frcz - copm(j+m+1)*depz 5239 end do 5240 end do 5241c 5242c get the dtau/dr terms used for TCG polarization force 5243c 5244 else if (poltyp.eq.'TCG' .and. use_thole) then 5245 do j = 1, tcgnab 5246 ukx = ubd(1,kk,j) 5247 uky = ubd(2,kk,j) 5248 ukz = ubd(3,kk,j) 5249 ukxp = ubp(1,kk,j) 5250 ukyp = ubp(2,kk,j) 5251 ukzp = ubp(3,kk,j) 5252 uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr 5253 ukrt = ukx*xr + uky*yr + ukz*zr 5254 term1 = dmpe(5) - usc3*rr5 5255 term2 = dmpe(7) - usc5*rr7 5256 term3 = usr5 + term1 5257 term4 = rr3 * uscale(k) 5258 term5 = -xr*term3 + rc3(1)*term4 5259 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 5260 tixx = uax(j)*term5 + uirt*term6 5261 tkxx = ukx*term5 + ukrt*term6 5262 term5 = -yr*term3 + rc3(2)*term4 5263 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 5264 tiyy = uay(j)*term5 + uirt*term6 5265 tkyy = uky*term5 + ukrt*term6 5266 term5 = -zr*term3 + rc3(3)*term4 5267 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 5268 tizz = uaz(j)*term5 + uirt*term6 5269 tkzz = ukz*term5 + ukrt*term6 5270 term4 = -usr5 * yr 5271 term5 = -xr*term1 + rr3*urc3(1) 5272 term6 = xr*yr*term2 - rr5*yr*urc5(1) 5273 tixy = uax(j)*term4 + uay(j)*term5 + uirt*term6 5274 tkxy = ukx*term4 + uky*term5 + ukrt*term6 5275 term4 = -usr5 * zr 5276 term6 = xr*zr*term2 - rr5*zr*urc5(1) 5277 tixz = uax(j)*term4 + uaz(j)*term5 + uirt*term6 5278 tkxz = ukx*term4 + ukz*term5 + ukrt*term6 5279 term5 = -yr*term1 + rr3*urc3(2) 5280 term6 = yr*zr*term2 - rr5*zr*urc5(2) 5281 tiyz = uay(j)*term4 + uaz(j)*term5 + uirt*term6 5282 tkyz = uky*term4 + ukz*term5 + ukrt*term6 5283 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 5284 & + tkxx*uaxp(j) + tkxy*uayp(j) 5285 & + tkxz*uazp(j) 5286 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 5287 & + tkxy*uaxp(j) + tkyy*uayp(j) 5288 & + tkyz*uazp(j) 5289 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 5290 & + tkxz*uaxp(j) + tkyz*uayp(j) 5291 & + tkzz*uazp(j) 5292 frcx = frcx + depx 5293 frcy = frcy + depy 5294 frcz = frcz + depz 5295 ukx = uad(1,kk,j) 5296 uky = uad(2,kk,j) 5297 ukz = uad(3,kk,j) 5298 ukxp = uap(1,kk,j) 5299 ukyp = uap(2,kk,j) 5300 ukzp = uap(3,kk,j) 5301 uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr 5302 ukrt = ukx*xr + uky*yr + ukz*zr 5303 term1 = dmpe(5) - usc3*rr5 5304 term2 = dmpe(7) - usc5*rr7 5305 term3 = usr5 + term1 5306 term4 = rr3 * uscale(k) 5307 term5 = -xr*term3 + rc3(1)*term4 5308 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 5309 tixx = ubx(j)*term5 + uirt*term6 5310 tkxx = ukx*term5 + ukrt*term6 5311 term5 = -yr*term3 + rc3(2)*term4 5312 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 5313 tiyy = uby(j)*term5 + uirt*term6 5314 tkyy = uky*term5 + ukrt*term6 5315 term5 = -zr*term3 + rc3(3)*term4 5316 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 5317 tizz = ubz(j)*term5 + uirt*term6 5318 tkzz = ukz*term5 + ukrt*term6 5319 term4 = -usr5 * yr 5320 term5 = -xr*term1 + rr3*urc3(1) 5321 term6 = xr*yr*term2 - rr5*yr*urc5(1) 5322 tixy = ubx(j)*term4 + uby(j)*term5 + uirt*term6 5323 tkxy = ukx*term4 + uky*term5 + ukrt*term6 5324 term4 = -usr5 * zr 5325 term6 = xr*zr*term2 - rr5*zr*urc5(1) 5326 tixz = ubx(j)*term4 + ubz(j)*term5 + uirt*term6 5327 tkxz = ukx*term4 + ukz*term5 + ukrt*term6 5328 term5 = -yr*term1 + rr3*urc3(2) 5329 term6 = yr*zr*term2 - rr5*zr*urc5(2) 5330 tiyz = uby(j)*term4 + ubz(j)*term5 + uirt*term6 5331 tkyz = uky*term4 + ukz*term5 + ukrt*term6 5332 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 5333 & + tkxx*ubxp(j) + tkxy*ubyp(j) 5334 & + tkxz*ubzp(j) 5335 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 5336 & + tkxy*ubxp(j) + tkyy*ubyp(j) 5337 & + tkyz*ubzp(j) 5338 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 5339 & + tkxz*ubxp(j) + tkyz*ubyp(j) 5340 & + tkzz*ubzp(j) 5341 frcx = frcx + depx 5342 frcy = frcy + depy 5343 frcz = frcz + depz 5344 end do 5345 end if 5346c 5347c increment force-based gradient on the interaction sites 5348c 5349 dep(1,i) = dep(1,i) - frcx 5350 dep(2,i) = dep(2,i) - frcy 5351 dep(3,i) = dep(3,i) - frcz 5352 dep(1,k) = dep(1,k) + frcx 5353 dep(2,k) = dep(2,k) + frcy 5354 dep(3,k) = dep(3,k) + frcz 5355c 5356c increment the virial due to pairwise Cartesian forces 5357c 5358 vxx = xr * frcx 5359 vxy = 0.5d0 * (yr*frcx+xr*frcy) 5360 vxz = 0.5d0 * (zr*frcx+xr*frcz) 5361 vyy = yr * frcy 5362 vyz = 0.5d0 * (zr*frcy+yr*frcz) 5363 vzz = zr * frcz 5364 vir(1,1) = vir(1,1) + vxx 5365 vir(2,1) = vir(2,1) + vxy 5366 vir(3,1) = vir(3,1) + vxz 5367 vir(1,2) = vir(1,2) + vxy 5368 vir(2,2) = vir(2,2) + vyy 5369 vir(3,2) = vir(3,2) + vyz 5370 vir(1,3) = vir(1,3) + vxz 5371 vir(2,3) = vir(2,3) + vyz 5372 vir(3,3) = vir(3,3) + vzz 5373 end if 5374 end do 5375c 5376c reset exclusion coefficients for connected atoms 5377c 5378 if (dpequal) then 5379 do j = 1, n12(i) 5380 pscale(i12(j,i)) = 1.0d0 5381 dscale(i12(j,i)) = 1.0d0 5382 wscale(i12(j,i)) = 1.0d0 5383 end do 5384 do j = 1, n13(i) 5385 pscale(i13(j,i)) = 1.0d0 5386 dscale(i13(j,i)) = 1.0d0 5387 wscale(i13(j,i)) = 1.0d0 5388 end do 5389 do j = 1, n14(i) 5390 pscale(i14(j,i)) = 1.0d0 5391 dscale(i14(j,i)) = 1.0d0 5392 wscale(i14(j,i)) = 1.0d0 5393 end do 5394 do j = 1, n15(i) 5395 pscale(i15(j,i)) = 1.0d0 5396 dscale(i15(j,i)) = 1.0d0 5397 wscale(i15(j,i)) = 1.0d0 5398 end do 5399 do j = 1, np11(i) 5400 uscale(ip11(j,i)) = 1.0d0 5401 end do 5402 do j = 1, np12(i) 5403 uscale(ip12(j,i)) = 1.0d0 5404 end do 5405 do j = 1, np13(i) 5406 uscale(ip13(j,i)) = 1.0d0 5407 end do 5408 do j = 1, np14(i) 5409 uscale(ip14(j,i)) = 1.0d0 5410 end do 5411 else 5412 do j = 1, n12(i) 5413 pscale(i12(j,i)) = 1.0d0 5414 wscale(i12(j,i)) = 1.0d0 5415 end do 5416 do j = 1, n13(i) 5417 pscale(i13(j,i)) = 1.0d0 5418 wscale(i13(j,i)) = 1.0d0 5419 end do 5420 do j = 1, n14(i) 5421 pscale(i14(j,i)) = 1.0d0 5422 wscale(i14(j,i)) = 1.0d0 5423 end do 5424 do j = 1, n15(i) 5425 pscale(i15(j,i)) = 1.0d0 5426 wscale(i15(j,i)) = 1.0d0 5427 end do 5428 do j = 1, np11(i) 5429 dscale(ip11(j,i)) = 1.0d0 5430 uscale(ip11(j,i)) = 1.0d0 5431 end do 5432 do j = 1, np12(i) 5433 dscale(ip12(j,i)) = 1.0d0 5434 uscale(ip12(j,i)) = 1.0d0 5435 end do 5436 do j = 1, np13(i) 5437 dscale(ip13(j,i)) = 1.0d0 5438 uscale(ip13(j,i)) = 1.0d0 5439 end do 5440 do j = 1, np14(i) 5441 dscale(ip14(j,i)) = 1.0d0 5442 uscale(ip14(j,i)) = 1.0d0 5443 end do 5444 end if 5445 end do 5446c 5447c for periodic boundary conditions with large cutoffs 5448c neighbors must be found by the replicates method 5449c 5450 if (use_replica) then 5451c 5452c calculate interaction with other unit cells 5453c 5454 do ii = 1, npole 5455 i = ipole(ii) 5456 xi = x(i) 5457 yi = y(i) 5458 zi = z(i) 5459 ci = rpole(1,ii) 5460 dix = rpole(2,ii) 5461 diy = rpole(3,ii) 5462 diz = rpole(4,ii) 5463 qixx = rpole(5,ii) 5464 qixy = rpole(6,ii) 5465 qixz = rpole(7,ii) 5466 qiyy = rpole(9,ii) 5467 qiyz = rpole(10,ii) 5468 qizz = rpole(13,ii) 5469 uix = uind(1,ii) 5470 uiy = uind(2,ii) 5471 uiz = uind(3,ii) 5472 uixp = uinp(1,ii) 5473 uiyp = uinp(2,ii) 5474 uizp = uinp(3,ii) 5475 do j = 1, tcgnab 5476 uax(j) = uad(1,ii,j) 5477 uay(j) = uad(2,ii,j) 5478 uaz(j) = uad(3,ii,j) 5479 uaxp(j) = uap(1,ii,j) 5480 uayp(j) = uap(2,ii,j) 5481 uazp(j) = uap(3,ii,j) 5482 ubx(j) = ubd(1,ii,j) 5483 uby(j) = ubd(2,ii,j) 5484 ubz(j) = ubd(3,ii,j) 5485 ubxp(j) = ubp(1,ii,j) 5486 ubyp(j) = ubp(2,ii,j) 5487 ubzp(j) = ubp(3,ii,j) 5488 end do 5489 if (use_thole) then 5490 pdi = pdamp(ii) 5491 pti = thole(ii) 5492 ddi = dirdamp(ii) 5493 else if (use_chgpen) then 5494 corei = pcore(ii) 5495 vali = pval(ii) 5496 alphai = palpha(ii) 5497 end if 5498c 5499c set exclusion coefficients for connected atoms 5500c 5501 if (dpequal) then 5502 do j = 1, n12(i) 5503 pscale(i12(j,i)) = p2scale 5504 do k = 1, np11(i) 5505 if (i12(j,i) .eq. ip11(k,i)) 5506 & pscale(i12(j,i)) = p2iscale 5507 end do 5508 dscale(i12(j,i)) = pscale(i12(j,i)) 5509 wscale(i12(j,i)) = w2scale 5510 end do 5511 do j = 1, n13(i) 5512 pscale(i13(j,i)) = p3scale 5513 do k = 1, np11(i) 5514 if (i13(j,i) .eq. ip11(k,i)) 5515 & pscale(i13(j,i)) = p3iscale 5516 end do 5517 dscale(i13(j,i)) = pscale(i13(j,i)) 5518 wscale(i13(j,i)) = w3scale 5519 end do 5520 do j = 1, n14(i) 5521 pscale(i14(j,i)) = p4scale 5522 do k = 1, np11(i) 5523 if (i14(j,i) .eq. ip11(k,i)) 5524 & pscale(i14(j,i)) = p4iscale 5525 end do 5526 dscale(i14(j,i)) = pscale(i14(j,i)) 5527 wscale(i14(j,i)) = w4scale 5528 end do 5529 do j = 1, n15(i) 5530 pscale(i15(j,i)) = p5scale 5531 do k = 1, np11(i) 5532 if (i15(j,i) .eq. ip11(k,i)) 5533 & pscale(i15(j,i)) = p5iscale 5534 end do 5535 dscale(i15(j,i)) = pscale(i15(j,i)) 5536 wscale(i15(j,i)) = w5scale 5537 end do 5538 do j = 1, np11(i) 5539 uscale(ip11(j,i)) = u1scale 5540 end do 5541 do j = 1, np12(i) 5542 uscale(ip12(j,i)) = u2scale 5543 end do 5544 do j = 1, np13(i) 5545 uscale(ip13(j,i)) = u3scale 5546 end do 5547 do j = 1, np14(i) 5548 uscale(ip14(j,i)) = u4scale 5549 end do 5550 else 5551 do j = 1, n12(i) 5552 pscale(i12(j,i)) = p2scale 5553 do k = 1, np11(i) 5554 if (i12(j,i) .eq. ip11(k,i)) 5555 & pscale(i12(j,i)) = p2iscale 5556 end do 5557 wscale(i12(j,i)) = w2scale 5558 end do 5559 do j = 1, n13(i) 5560 pscale(i13(j,i)) = p3scale 5561 do k = 1, np11(i) 5562 if (i13(j,i) .eq. ip11(k,i)) 5563 & pscale(i13(j,i)) = p3iscale 5564 end do 5565 wscale(i13(j,i)) = w3scale 5566 end do 5567 do j = 1, n14(i) 5568 pscale(i14(j,i)) = p4scale 5569 do k = 1, np11(i) 5570 if (i14(j,i) .eq. ip11(k,i)) 5571 & pscale(i14(j,i)) = p4iscale 5572 end do 5573 wscale(i14(j,i)) = w4scale 5574 end do 5575 do j = 1, n15(i) 5576 pscale(i15(j,i)) = p5scale 5577 do k = 1, np11(i) 5578 if (i15(j,i) .eq. ip11(k,i)) 5579 & pscale(i15(j,i)) = p5iscale 5580 end do 5581 wscale(i15(j,i)) = w5scale 5582 end do 5583 do j = 1, np11(i) 5584 dscale(ip11(j,i)) = d1scale 5585 uscale(ip11(j,i)) = u1scale 5586 end do 5587 do j = 1, np12(i) 5588 dscale(ip12(j,i)) = d2scale 5589 uscale(ip12(j,i)) = u2scale 5590 end do 5591 do j = 1, np13(i) 5592 dscale(ip13(j,i)) = d3scale 5593 uscale(ip13(j,i)) = u3scale 5594 end do 5595 do j = 1, np14(i) 5596 dscale(ip14(j,i)) = d4scale 5597 uscale(ip14(j,i)) = u4scale 5598 end do 5599 end if 5600c 5601c evaluate all sites within the cutoff distance 5602c 5603 do kk = ii, npole 5604 k = ipole(kk) 5605 do jcell = 2, ncell 5606 xr = x(k) - xi 5607 yr = y(k) - yi 5608 zr = z(k) - zi 5609 call imager (xr,yr,zr,jcell) 5610 r2 = xr*xr + yr*yr + zr*zr 5611 if (.not. (use_polymer .and. r2.le.polycut2)) then 5612 pscale(k) = 1.0d0 5613 dscale(k) = 1.0d0 5614 uscale(k) = 1.0d0 5615 end if 5616 if (r2 .le. off2) then 5617 r = sqrt(r2) 5618 ck = rpole(1,kk) 5619 dkx = rpole(2,kk) 5620 dky = rpole(3,kk) 5621 dkz = rpole(4,kk) 5622 qkxx = rpole(5,kk) 5623 qkxy = rpole(6,kk) 5624 qkxz = rpole(7,kk) 5625 qkyy = rpole(9,kk) 5626 qkyz = rpole(10,kk) 5627 qkzz = rpole(13,kk) 5628 ukx = uind(1,kk) 5629 uky = uind(2,kk) 5630 ukz = uind(3,kk) 5631 ukxp = uinp(1,kk) 5632 ukyp = uinp(2,kk) 5633 ukzp = uinp(3,kk) 5634c 5635c intermediates involving moments and separation distance 5636c 5637 dir = dix*xr + diy*yr + diz*zr 5638 qix = qixx*xr + qixy*yr + qixz*zr 5639 qiy = qixy*xr + qiyy*yr + qiyz*zr 5640 qiz = qixz*xr + qiyz*yr + qizz*zr 5641 qir = qix*xr + qiy*yr + qiz*zr 5642 dkr = dkx*xr + dky*yr + dkz*zr 5643 qkx = qkxx*xr + qkxy*yr + qkxz*zr 5644 qky = qkxy*xr + qkyy*yr + qkyz*zr 5645 qkz = qkxz*xr + qkyz*yr + qkzz*zr 5646 qkr = qkx*xr + qky*yr + qkz*zr 5647 uir = uix*xr + uiy*yr + uiz*zr 5648 uirp = uixp*xr + uiyp*yr + uizp*zr 5649 ukr = ukx*xr + uky*yr + ukz*zr 5650 ukrp = ukxp*xr + ukyp*yr + ukzp*zr 5651c 5652c get reciprocal distance terms for this interaction 5653c 5654 rr1 = f / r 5655 rr3 = rr1 / r2 5656 rr5 = 3.0d0 * rr3 / r2 5657 rr7 = 5.0d0 * rr5 / r2 5658 rr9 = 7.0d0 * rr7 / r2 5659c 5660c calculate real space Ewald error function damping 5661c 5662 call dampewald (9,r,r2,f,dmpe) 5663c 5664c apply Thole polarization damping to scale factors 5665c 5666 sc3 = 1.0d0 5667 sc5 = 1.0d0 5668 sc7 = 1.0d0 5669 do j = 1, 3 5670 rc3(j) = 0.0d0 5671 rc5(j) = 0.0d0 5672 rc7(j) = 0.0d0 5673 end do 5674c 5675c apply Thole polarization damping to scale factors 5676c 5677 if (use_thole) then 5678 damp = pdi * pdamp(kk) 5679 if (use_dirdamp) then 5680 pgamma = min(ddi,dirdamp(kk)) 5681 if (pgamma .eq. 0.0d0) then 5682 pgamma = max(ddi,dirdamp(kk)) 5683 end if 5684 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 5685 damp = pgamma * (r/damp)**(1.5d0) 5686 if (damp .lt. 50.0d0) then 5687 expdamp = exp(-damp) 5688 sc3 = 1.0d0 - expdamp 5689 sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp) 5690 sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp 5691 & +0.15d0*damp**2) 5692 temp3 = 1.5d0 * damp * expdamp / r2 5693 temp5 = 0.5d0 * (1.0d0+damp) 5694 temp7 = 0.7d0 + 0.15d0*damp**2/temp5 5695 rc3(1) = xr * temp3 5696 rc3(2) = yr * temp3 5697 rc3(3) = zr * temp3 5698 rc5(1) = rc3(1) * temp5 5699 rc5(2) = rc3(2) * temp5 5700 rc5(3) = rc3(3) * temp5 5701 rc7(1) = rc5(1) * temp7 5702 rc7(2) = rc5(2) * temp7 5703 rc7(3) = rc5(3) * temp7 5704 end if 5705 end if 5706 else 5707 pgamma = min(pti,thole(kk)) 5708 if (pgamma .eq. 0.0d0) then 5709 pgamma = max(pti,thole(kk)) 5710 end if 5711 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 5712 damp = pgamma * (r/damp)**3 5713 if (damp .lt. 50.0d0) then 5714 expdamp = exp(-damp) 5715 sc3 = 1.0d0 - expdamp 5716 sc5 = 1.0d0 - (1.0d0+damp)*expdamp 5717 sc7 = 1.0d0 - (1.0d0+damp+0.6d0*damp**2) 5718 & *expdamp 5719 temp3 = 3.0d0 * damp * expdamp / r2 5720 temp5 = damp 5721 temp7 = -0.2d0 + 0.6d0*damp 5722 rc3(1) = xr * temp3 5723 rc3(2) = yr * temp3 5724 rc3(3) = zr * temp3 5725 rc5(1) = rc3(1) * temp5 5726 rc5(2) = rc3(2) * temp5 5727 rc5(3) = rc3(3) * temp5 5728 rc7(1) = rc5(1) * temp7 5729 rc7(2) = rc5(2) * temp7 5730 rc7(3) = rc5(3) * temp7 5731 end if 5732 end if 5733 end if 5734 psc3 = 1.0d0 - sc3*pscale(k) 5735 psc5 = 1.0d0 - sc5*pscale(k) 5736 psc7 = 1.0d0 - sc7*pscale(k) 5737 dsc3 = 1.0d0 - sc3*dscale(k) 5738 dsc5 = 1.0d0 - sc5*dscale(k) 5739 dsc7 = 1.0d0 - sc7*dscale(k) 5740 usc3 = 1.0d0 - sc3*uscale(k) 5741 usc5 = 1.0d0 - sc5*uscale(k) 5742 psr3 = dmpe(3) - psc3*rr3 5743 psr5 = dmpe(5) - psc5*rr5 5744 psr7 = dmpe(7) - psc7*rr7 5745 dsr3 = dmpe(3) - dsc3*rr3 5746 dsr5 = dmpe(5) - dsc5*rr5 5747 dsr7 = dmpe(7) - dsc7*rr7 5748 usr3 = dmpe(3) - usc3*rr3 5749 usr5 = dmpe(5) - usc5*rr5 5750 do j = 1, 3 5751 prc3(j) = rc3(j) * pscale(k) 5752 prc5(j) = rc5(j) * pscale(k) 5753 prc7(j) = rc7(j) * pscale(k) 5754 drc3(j) = rc3(j) * dscale(k) 5755 drc5(j) = rc5(j) * dscale(k) 5756 drc7(j) = rc7(j) * dscale(k) 5757 urc3(j) = rc3(j) * uscale(k) 5758 urc5(j) = rc5(j) * uscale(k) 5759 end do 5760c 5761c apply charge penetration damping to scale factors 5762c 5763 else if (use_chgpen) then 5764 corek = pcore(kk) 5765 valk = pval(kk) 5766 alphak = palpha(kk) 5767 call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik) 5768 rr3core = dmpe(3) - (1.0d0-dscale(k))*rr3 5769 rr5core = dmpe(5) - (1.0d0-dscale(k))*rr5 5770 rr3i = dmpe(3) - (1.0d0-dscale(k)*dmpi(3))*rr3 5771 rr5i = dmpe(5) - (1.0d0-dscale(k)*dmpi(5))*rr5 5772 rr7i = dmpe(7) - (1.0d0-dscale(k)*dmpi(7))*rr7 5773 rr9i = dmpe(9) - (1.0d0-dscale(k)*dmpi(9))*rr9 5774 rr3k = dmpe(3) - (1.0d0-dscale(k)*dmpk(3))*rr3 5775 rr5k = dmpe(5) - (1.0d0-dscale(k)*dmpk(5))*rr5 5776 rr7k = dmpe(7) - (1.0d0-dscale(k)*dmpk(7))*rr7 5777 rr9k = dmpe(9) - (1.0d0-dscale(k)*dmpk(9))*rr9 5778 rr5ik = dmpe(5) - (1.0d0-wscale(k)*dmpik(5))*rr5 5779 rr7ik = dmpe(7) - (1.0d0-wscale(k)*dmpik(7))*rr7 5780 end if 5781c 5782c store the potential at each site for use in charge flux 5783c 5784 if (use_chgflx) then 5785 if (use_thole) then 5786 poti = -ukr*psr3 - ukrp*dsr3 5787 potk = uir*psr3 + uirp*dsr3 5788 else if (use_chgpen) then 5789 poti = -2.0d0 * ukr * rr3i 5790 potk = 2.0d0 * uir * rr3k 5791 end if 5792 pot(i) = pot(i) + poti 5793 pot(k) = pot(k) + potk 5794 end if 5795c 5796c get the induced dipole field used for dipole torques 5797c 5798 if (use_thole) then 5799 tix3 = psr3*ukx + dsr3*ukxp 5800 tiy3 = psr3*uky + dsr3*ukyp 5801 tiz3 = psr3*ukz + dsr3*ukzp 5802 tkx3 = psr3*uix + dsr3*uixp 5803 tky3 = psr3*uiy + dsr3*uiyp 5804 tkz3 = psr3*uiz + dsr3*uizp 5805 tuir = -psr5*ukr - dsr5*ukrp 5806 tukr = -psr5*uir - dsr5*uirp 5807 else if (use_chgpen) then 5808 tix3 = 2.0d0*rr3i*ukx 5809 tiy3 = 2.0d0*rr3i*uky 5810 tiz3 = 2.0d0*rr3i*ukz 5811 tkx3 = 2.0d0*rr3k*uix 5812 tky3 = 2.0d0*rr3k*uiy 5813 tkz3 = 2.0d0*rr3k*uiz 5814 tuir = -2.0d0*rr5i*ukr 5815 tukr = -2.0d0*rr5k*uir 5816 end if 5817 ufld(1,i) = ufld(1,i) + tix3 + xr*tuir 5818 ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir 5819 ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir 5820 ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr 5821 ufld(2,k) = ufld(2,k) + tky3 + yr*tukr 5822 ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr 5823c 5824c get induced dipole field gradient used for quadrupole torques 5825c 5826 if (use_thole) then 5827 tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp) 5828 tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp) 5829 tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp) 5830 tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp) 5831 tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp) 5832 tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp) 5833 tuir = -psr7*ukr - dsr7*ukrp 5834 tukr = -psr7*uir - dsr7*uirp 5835 else if (use_chgpen) then 5836 tix5 = 4.0d0 * (rr5i*ukx) 5837 tiy5 = 4.0d0 * (rr5i*uky) 5838 tiz5 = 4.0d0 * (rr5i*ukz) 5839 tkx5 = 4.0d0 * (rr5k*uix) 5840 tky5 = 4.0d0 * (rr5k*uiy) 5841 tkz5 = 4.0d0 * (rr5k*uiz) 5842 tuir = -2.0d0*rr7i*ukr 5843 tukr = -2.0d0*rr7k*uir 5844 end if 5845 dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir 5846 dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5 5847 & + 2.0d0*xr*yr*tuir 5848 dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir 5849 dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5 5850 & + 2.0d0*xr*zr*tuir 5851 dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5 5852 & + 2.0d0*yr*zr*tuir 5853 dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir 5854 dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr 5855 dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5 5856 & - 2.0d0*xr*yr*tukr 5857 dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr 5858 dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5 5859 & - 2.0d0*xr*zr*tukr 5860 dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5 5861 & - 2.0d0*yr*zr*tukr 5862 dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr 5863c 5864c get the dEd/dR terms used for direct polarization force 5865c 5866 if (use_thole) then 5867 term1 = dmpe(5) - dsc3*rr5 5868 term2 = dmpe(7) - dsc5*rr7 5869 term3 = -dsr3 + term1*xr*xr - rr3*xr*drc3(1) 5870 term4 = rr3*drc3(1) - term1*xr - dsr5*xr 5871 term5 = term2*xr*xr - dsr5 - rr5*xr*drc5(1) 5872 term6 = (dmpe(9)-dsc7*rr9)*xr*xr - dmpe(7) 5873 & - rr7*xr*drc7(1) 5874 term7 = rr5*drc5(1) - 2.0d0*dmpe(7)*xr 5875 & + (dsc5+1.5d0*dsc7)*rr7*xr 5876 tixx = ci*term3 + dix*term4 + dir*term5 5877 & + 2.0d0*dsr5*qixx + (qiy*yr+qiz*zr)*dsc7*rr7 5878 & + 2.0d0*qix*term7 + qir*term6 5879 tkxx = ck*term3 - dkx*term4 - dkr*term5 5880 & + 2.0d0*dsr5*qkxx + (qky*yr+qkz*zr)*dsc7*rr7 5881 & + 2.0d0*qkx*term7 + qkr*term6 5882 term3 = -dsr3 + term1*yr*yr - rr3*yr*drc3(2) 5883 term4 = rr3*drc3(2) - term1*yr - dsr5*yr 5884 term5 = term2*yr*yr - dsr5 - rr5*yr*drc5(2) 5885 term6 = (dmpe(9)-dsc7*rr9)*yr*yr - dmpe(7) 5886 & - rr7*yr*drc7(2) 5887 term7 = rr5*drc5(2) - 2.0d0*dmpe(7)*yr 5888 & + (dsc5+1.5d0*dsc7)*rr7*yr 5889 tiyy = ci*term3 + diy*term4 + dir*term5 5890 & + 2.0d0*dsr5*qiyy + (qix*xr+qiz*zr)*dsc7*rr7 5891 & + 2.0d0*qiy*term7 + qir*term6 5892 tkyy = ck*term3 - dky*term4 - dkr*term5 5893 & + 2.0d0*dsr5*qkyy + (qkx*xr+qkz*zr)*dsc7*rr7 5894 & + 2.0d0*qky*term7 + qkr*term6 5895 term3 = -dsr3 + term1*zr*zr - rr3*zr*drc3(3) 5896 term4 = rr3*drc3(3) - term1*zr - dsr5*zr 5897 term5 = term2*zr*zr - dsr5 - rr5*zr*drc5(3) 5898 term6 = (dmpe(9)-dsc7*rr9)*zr*zr - dmpe(7) 5899 & - rr7*zr*drc7(3) 5900 term7 = rr5*drc5(3) - 2.0d0*dmpe(7)*zr 5901 & + (dsc5+1.5d0*dsc7)*rr7*zr 5902 tizz = ci*term3 + diz*term4 + dir*term5 5903 & + 2.0d0*dsr5*qizz + (qix*xr+qiy*yr)*dsc7*rr7 5904 & + 2.0d0*qiz*term7 + qir*term6 5905 tkzz = ck*term3 - dkz*term4 - dkr*term5 5906 & + 2.0d0*dsr5*qkzz + (qkx*xr+qky*yr)*dsc7*rr7 5907 & + 2.0d0*qkz*term7 + qkr*term6 5908 term3 = term1*xr*yr - rr3*yr*drc3(1) 5909 term4 = rr3*drc3(1) - term1*xr 5910 term5 = term2*xr*yr - rr5*yr*drc5(1) 5911 term6 = (dmpe(9)-dsc7*rr9)*xr*yr - rr7*yr*drc7(1) 5912 term7 = rr5*drc5(1) - term2*xr 5913 tixy = ci*term3 - dsr5*dix*yr + diy*term4 + dir*term5 5914 & + 2.0d0*dsr5*qixy - 2.0d0*dsr7*yr*qix 5915 & + 2.0d0*qiy*term7 + qir*term6 5916 tkxy = ck*term3 + dsr5*dkx*yr - dky*term4 - dkr*term5 5917 & + 2.0d0*dsr5*qkxy - 2.0d0*dsr7*yr*qkx 5918 & + 2.0d0*qky*term7 + qkr*term6 5919 term3 = term1*xr*zr - rr3*zr*drc3(1) 5920 term5 = term2*xr*zr - rr5*zr*drc5(1) 5921 term6 = (dmpe(9)-dsc7*rr9)*xr*zr - rr7*zr*drc7(1) 5922 tixz = ci*term3 - dsr5*dix*zr + diz*term4 + dir*term5 5923 & + 2.0d0*dsr5*qixz - 2.0d0*dsr7*zr*qix 5924 & + 2.0d0*qiz*term7 + qir*term6 5925 tkxz = ck*term3 + dsr5*dkx*zr - dkz*term4 - dkr*term5 5926 & + 2.0d0*dsr5*qkxz - 2.0d0*dsr7*zr*qkx 5927 & + 2.0d0*qkz*term7 + qkr*term6 5928 term3 = term1*yr*zr - rr3*zr*drc3(2) 5929 term4 = rr3*drc3(2) - term1*yr 5930 term5 = term2*yr*zr - rr5*zr*drc5(2) 5931 term6 = (dmpe(9)-dsc7*rr9)*yr*zr - rr7*zr*drc7(2) 5932 term7 = rr5*drc5(2) - term2*yr 5933 tiyz = ci*term3 - dsr5*diy*zr + diz*term4 + dir*term5 5934 & + 2.0d0*dsr5*qiyz - 2.0d0*dsr7*zr*qiy 5935 & + 2.0d0*qiz*term7 + qir*term6 5936 tkyz = ck*term3 + dsr5*dky*zr - dkz*term4 - dkr*term5 5937 & + 2.0d0*dsr5*qkyz - 2.0d0*dsr7*zr*qky 5938 & + 2.0d0*qkz*term7 + qkr*term6 5939 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 5940 & - tkxx*uixp - tkxy*uiyp - tkxz*uizp 5941 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 5942 & - tkxy*uixp - tkyy*uiyp - tkyz*uizp 5943 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 5944 & - tkxz*uixp - tkyz*uiyp - tkzz*uizp 5945 frcx = depx 5946 frcy = depy 5947 frcz = depz 5948c 5949c get the dEp/dR terms used for direct polarization force 5950c 5951 term1 = dmpe(5) - psc3*rr5 5952 term2 = dmpe(7) - psc5*rr7 5953 term3 = -psr3 + term1*xr*xr - rr3*xr*prc3(1) 5954 term4 = rr3*prc3(1) - term1*xr - psr5*xr 5955 term5 = term2*xr*xr - psr5 - rr5*xr*prc5(1) 5956 term6 = (dmpe(9)-psc7*rr9)*xr*xr - dmpe(7) 5957 & - rr7*xr*prc7(1) 5958 term7 = rr5*prc5(1) - 2.0d0*dmpe(7)*xr 5959 & + (psc5+1.5d0*psc7)*rr7*xr 5960 tixx = ci*term3 + dix*term4 + dir*term5 5961 & + 2.0d0*psr5*qixx + (qiy*yr+qiz*zr)*psc7*rr7 5962 & + 2.0d0*qix*term7 + qir*term6 5963 tkxx = ck*term3 - dkx*term4 - dkr*term5 5964 & + 2.0d0*psr5*qkxx + (qky*yr+qkz*zr)*psc7*rr7 5965 & + 2.0d0*qkx*term7 + qkr*term6 5966 term3 = -psr3 + term1*yr*yr - rr3*yr*prc3(2) 5967 term4 = rr3*prc3(2) - term1*yr - psr5*yr 5968 term5 = term2*yr*yr - psr5 - rr5*yr*prc5(2) 5969 term6 = (dmpe(9)-psc7*rr9)*yr*yr - dmpe(7) 5970 & - rr7*yr*prc7(2) 5971 term7 = rr5*prc5(2) - 2.0d0*dmpe(7)*yr 5972 & + (psc5+1.5d0*psc7)*rr7*yr 5973 tiyy = ci*term3 + diy*term4 + dir*term5 5974 & + 2.0d0*psr5*qiyy + (qix*xr+qiz*zr)*psc7*rr7 5975 & + 2.0d0*qiy*term7 + qir*term6 5976 tkyy = ck*term3 - dky*term4 - dkr*term5 5977 & + 2.0d0*psr5*qkyy + (qkx*xr+qkz*zr)*psc7*rr7 5978 & + 2.0d0*qky*term7 + qkr*term6 5979 term3 = -psr3 + term1*zr*zr - rr3*zr*prc3(3) 5980 term4 = rr3*prc3(3) - term1*zr - psr5*zr 5981 term5 = term2*zr*zr - psr5 - rr5*zr*prc5(3) 5982 term6 = (dmpe(9)-psc7*rr9)*zr*zr - dmpe(7) 5983 & - rr7*zr*prc7(3) 5984 term7 = rr5*prc5(3) - 2.0d0*dmpe(7)*zr 5985 & + (psc5+1.5d0*psc7)*rr7*zr 5986 tizz = ci*term3 + diz*term4 + dir*term5 5987 & + 2.0d0*psr5*qizz + (qix*xr+qiy*yr)*psc7*rr7 5988 & + 2.0d0*qiz*term7 + qir*term6 5989 tkzz = ck*term3 - dkz*term4 - dkr*term5 5990 & + 2.0d0*psr5*qkzz + (qkx*xr+qky*yr)*psc7*rr7 5991 & + 2.0d0*qkz*term7 + qkr*term6 5992 term3 = term1*xr*yr - rr3*yr*prc3(1) 5993 term4 = rr3*prc3(1) - term1*xr 5994 term5 = term2*xr*yr - rr5*yr*prc5(1) 5995 term6 = (dmpe(9)-psc7*rr9)*xr*yr - rr7*yr*prc7(1) 5996 term7 = rr5*prc5(1) - term2*xr 5997 tixy = ci*term3 - psr5*dix*yr + diy*term4 + dir*term5 5998 & + 2.0d0*psr5*qixy - 2.0d0*psr7*yr*qix 5999 & + 2.0d0*qiy*term7 + qir*term6 6000 tkxy = ck*term3 + psr5*dkx*yr - dky*term4 - dkr*term5 6001 & + 2.0d0*psr5*qkxy - 2.0d0*psr7*yr*qkx 6002 & + 2.0d0*qky*term7 + qkr*term6 6003 term3 = term1*xr*zr - rr3*zr*prc3(1) 6004 term5 = term2*xr*zr - rr5*zr*prc5(1) 6005 term6 = (dmpe(9)-psc7*rr9)*xr*zr - rr7*zr*prc7(1) 6006 tixz = ci*term3 - psr5*dix*zr + diz*term4 + dir*term5 6007 & + 2.0d0*psr5*qixz - 2.0d0*psr7*zr*qix 6008 & + 2.0d0*qiz*term7 + qir*term6 6009 tkxz = ck*term3 + psr5*dkx*zr - dkz*term4 - dkr*term5 6010 & + 2.0d0*psr5*qkxz - 2.0d0*psr7*zr*qkx 6011 & + 2.0d0*qkz*term7 + qkr*term6 6012 term3 = term1*yr*zr - rr3*zr*prc3(2) 6013 term4 = rr3*prc3(2) - term1*yr 6014 term5 = term2*yr*zr - rr5*zr*prc5(2) 6015 term6 = (dmpe(9)-psc7*rr9)*yr*zr - rr7*zr*prc7(2) 6016 term7 = rr5*prc5(2) - term2*yr 6017 tiyz = ci*term3 - psr5*diy*zr + diz*term4 + dir*term5 6018 & + 2.0d0*psr5*qiyz - 2.0d0*psr7*zr*qiy 6019 & + 2.0d0*qiz*term7 + qir*term6 6020 tkyz = ck*term3 + psr5*dky*zr - dkz*term4 - dkr*term5 6021 & + 2.0d0*psr5*qkyz - 2.0d0*psr7*zr*qky 6022 & + 2.0d0*qkz*term7 + qkr*term6 6023 depx = tixx*ukx + tixy*uky + tixz*ukz 6024 & - tkxx*uix - tkxy*uiy - tkxz*uiz 6025 depy = tixy*ukx + tiyy*uky + tiyz*ukz 6026 & - tkxy*uix - tkyy*uiy - tkyz*uiz 6027 depz = tixz*ukx + tiyz*uky + tizz*ukz 6028 & - tkxz*uix - tkyz*uiy - tkzz*uiz 6029 frcx = frcx + depx 6030 frcy = frcy + depy 6031 frcz = frcz + depz 6032c 6033c get the field gradient for direct polarization force 6034c 6035 else if (use_chgpen) then 6036 term1i = rr3i - rr5i*xr*xr 6037 term1core = rr3core - rr5core*xr*xr 6038 term2i = 2.0d0*rr5i*xr 6039 term3i = rr7i*xr*xr - rr5i 6040 term4i = 2.0d0*rr5i 6041 term5i = 5.0d0*rr7i*xr 6042 term6i = rr9i*xr*xr 6043 term1k = rr3k - rr5k*xr*xr 6044 term2k = 2.0d0*rr5k*xr 6045 term3k = rr7k*xr*xr - rr5k 6046 term4k = 2.0d0*rr5k 6047 term5k = 5.0d0*rr7k*xr 6048 term6k = rr9k*xr*xr 6049 tixx = vali*term1i + corei*term1core 6050 & + dix*term2i - dir*term3i 6051 & - qixx*term4i + qix*term5i - qir*term6i 6052 & + (qiy*yr+qiz*zr)*rr7i 6053 tkxx = valk*term1k + corek*term1core 6054 & - dkx*term2k + dkr*term3k 6055 & - qkxx*term4k + qkx*term5k - qkr*term6k 6056 & + (qky*yr+qkz*zr)*rr7k 6057 term1i = rr3i - rr5i*yr*yr 6058 term1core = rr3core - rr5core*yr*yr 6059 term2i = 2.0d0*rr5i*yr 6060 term3i = rr7i*yr*yr - rr5i 6061 term4i = 2.0d0*rr5i 6062 term5i = 5.0d0*rr7i*yr 6063 term6i = rr9i*yr*yr 6064 term1k = rr3k - rr5k*yr*yr 6065 term2k = 2.0d0*rr5k*yr 6066 term3k = rr7k*yr*yr - rr5k 6067 term4k = 2.0d0*rr5k 6068 term5k = 5.0d0*rr7k*yr 6069 term6k = rr9k*yr*yr 6070 tiyy = vali*term1i + corei*term1core 6071 & + diy*term2i - dir*term3i 6072 & - qiyy*term4i + qiy*term5i - qir*term6i 6073 & + (qix*xr+qiz*zr)*rr7i 6074 tkyy = valk*term1k + corek*term1core 6075 & - dky*term2k + dkr*term3k 6076 & - qkyy*term4k + qky*term5k - qkr*term6k 6077 & + (qkx*xr+qkz*zr)*rr7k 6078 term1i = rr3i - rr5i*zr*zr 6079 term1core = rr3core - rr5core*zr*zr 6080 term2i = 2.0d0*rr5i*zr 6081 term3i = rr7i*zr*zr - rr5i 6082 term4i = 2.0d0*rr5i 6083 term5i = 5.0d0*rr7i*zr 6084 term6i = rr9i*zr*zr 6085 term1k = rr3k - rr5k*zr*zr 6086 term2k = 2.0d0*rr5k*zr 6087 term3k = rr7k*zr*zr - rr5k 6088 term4k = 2.0d0*rr5k 6089 term5k = 5.0d0*rr7k*zr 6090 term6k = rr9k*zr*zr 6091 tizz = vali*term1i + corei*term1core 6092 & + diz*term2i - dir*term3i 6093 & - qizz*term4i + qiz*term5i - qir*term6i 6094 & + (qix*xr+qiy*yr)*rr7i 6095 tkzz = valk*term1k + corek*term1core 6096 & - dkz*term2k + dkr*term3k 6097 & - qkzz*term4k + qkz*term5k - qkr*term6k 6098 & + (qkx*xr+qky*yr)*rr7k 6099 term2i = rr5i*xr 6100 term1i = yr * term2i 6101 term1core = rr5core*xr*yr 6102 term3i = rr5i*yr 6103 term4i = yr * (rr7i*xr) 6104 term5i = 2.0d0*rr5i 6105 term6i = 2.0d0*rr7i*xr 6106 term7i = 2.0d0*rr7i*yr 6107 term8i = yr*rr9i*xr 6108 term2k = rr5k*xr 6109 term1k = yr * term2k 6110 term3k = rr5k*yr 6111 term4k = yr * (rr7k*xr) 6112 term5k = 2.0d0*rr5k 6113 term6k = 2.0d0*rr7k*xr 6114 term7k = 2.0d0*rr7k*yr 6115 term8k = yr*rr9k*xr 6116 tixy = -vali*term1i - corei*term1core 6117 & + diy*term2i + dix*term3i 6118 & - dir*term4i - qixy*term5i + qiy*term6i 6119 & + qix*term7i - qir*term8i 6120 tkxy = -valk*term1k - corek*term1core 6121 & - dky*term2k - dkx*term3k 6122 & + dkr*term4k - qkxy*term5k + qky*term6k 6123 & + qkx*term7k - qkr*term8k 6124 term2i = rr5i*xr 6125 term1i = zr * term2i 6126 term1core = rr5core*xr*zr 6127 term3i = rr5i*zr 6128 term4i = zr * (rr7i*xr) 6129 term5i = 2.0d0*rr5i 6130 term6i = 2.0d0*rr7i*xr 6131 term7i = 2.0d0*rr7i*zr 6132 term8i = zr*rr9i*xr 6133 term2k = rr5k*xr 6134 term1k = zr * term2k 6135 term3k = rr5k*zr 6136 term4k = zr * (rr7k*xr) 6137 term5k = 2.0d0*rr5k 6138 term6k = 2.0d0*rr7k*xr 6139 term7k = 2.0d0*rr7k*zr 6140 term8k = zr*rr9k*xr 6141 tixz = -vali*term1i - corei*term1core 6142 & + diz*term2i + dix*term3i 6143 & - dir*term4i - qixz*term5i + qiz*term6i 6144 & + qix*term7i - qir*term8i 6145 tkxz = -valk*term1k - corek*term1core 6146 & - dkz*term2k - dkx*term3k 6147 & + dkr*term4k - qkxz*term5k + qkz*term6k 6148 & + qkx*term7k - qkr*term8k 6149 term2i = rr5i*yr 6150 term1i = zr * term2i 6151 term1core = rr5core*yr*zr 6152 term3i = rr5i*zr 6153 term4i = zr * (rr7i*yr) 6154 term5i = 2.0d0*rr5i 6155 term6i = 2.0d0*rr7i*yr 6156 term7i = 2.0d0*rr7i*zr 6157 term8i = zr*rr9i*yr 6158 term2k = rr5k*yr 6159 term1k = zr * term2k 6160 term3k = rr5k*zr 6161 term4k = zr * (rr7k*yr) 6162 term5k = 2.0d0*rr5k 6163 term6k = 2.0d0*rr7k*yr 6164 term7k = 2.0d0*rr7k*zr 6165 term8k = zr*rr9k*yr 6166 tiyz = -vali*term1i - corei*term1core 6167 & + diz*term2i + diy*term3i 6168 & - dir*term4i - qiyz*term5i + qiz*term6i 6169 & + qiy*term7i - qir*term8i 6170 tkyz = -valk*term1k - corek*term1core 6171 & - dkz*term2k - dky*term3k 6172 & + dkr*term4k - qkyz*term5k + qkz*term6k 6173 & + qky*term7k - qkr*term8k 6174 depx = tixx*ukx + tixy*uky + tixz*ukz 6175 & - tkxx*uix - tkxy*uiy - tkxz*uiz 6176 depy = tixy*ukx + tiyy*uky + tiyz*ukz 6177 & - tkxy*uix - tkyy*uiy - tkyz*uiz 6178 depz = tixz*ukx + tiyz*uky + tizz*ukz 6179 & - tkxz*uix - tkyz*uiy - tkzz*uiz 6180 frcx = -2.0d0 * depx 6181 frcy = -2.0d0 * depy 6182 frcz = -2.0d0 * depz 6183 end if 6184c 6185c reset Thole values if alternate direct damping was used 6186c 6187 if (use_dirdamp) then 6188 sc3 = 1.0d0 6189 sc5 = 1.0d0 6190 do j = 1, 3 6191 rc3(j) = 0.0d0 6192 rc5(j) = 0.0d0 6193 end do 6194 damp = pdi * pdamp(kk) 6195 if (damp .ne. 0.0d0) then 6196 pgamma = min(pti,thole(kk)) 6197 damp = pgamma * (r/damp)**3 6198 if (damp .lt. 50.0d0) then 6199 expdamp = exp(-damp) 6200 sc3 = 1.0d0 - expdamp 6201 sc5 = 1.0d0 - expdamp*(1.0d0+damp) 6202 temp3 = 3.0d0 * damp * expdamp / r2 6203 temp5 = damp 6204 rc3(1) = xr * temp3 6205 rc3(2) = yr * temp3 6206 rc3(3) = zr * temp3 6207 rc5(1) = rc3(1) * temp5 6208 rc5(2) = rc3(2) * temp5 6209 rc5(3) = rc3(3) * temp5 6210 end if 6211 end if 6212 usc3 = 1.0d0 - sc3*uscale(k) 6213 usc5 = 1.0d0 - sc5*uscale(k) 6214 usr3 = dmpe(3) - usc3*rr3 6215 usr5 = dmpe(5) - usc5*rr5 6216 do j = 1, 3 6217 urc3(j) = rc3(j) * uscale(k) 6218 urc5(j) = rc5(j) * uscale(k) 6219 end do 6220 end if 6221c 6222c get the dtau/dr terms used for mutual polarization force 6223c 6224 if (poltyp.eq.'MUTUAL' .and. use_thole) then 6225 term1 = dmpe(5) - usc3*rr5 6226 term2 = dmpe(7) - usc5*rr7 6227 term3 = usr5 + term1 6228 term4 = rr3 * uscale(k) 6229 term5 = -xr*term3 + rc3(1)*term4 6230 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 6231 tixx = uix*term5 + uir*term6 6232 tkxx = ukx*term5 + ukr*term6 6233 term5 = -yr*term3 + rc3(2)*term4 6234 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 6235 tiyy = uiy*term5 + uir*term6 6236 tkyy = uky*term5 + ukr*term6 6237 term5 = -zr*term3 + rc3(3)*term4 6238 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 6239 tizz = uiz*term5 + uir*term6 6240 tkzz = ukz*term5 + ukr*term6 6241 term4 = -usr5 * yr 6242 term5 = -xr*term1 + rr3*urc3(1) 6243 term6 = xr*yr*term2 - rr5*yr*urc5(1) 6244 tixy = uix*term4 + uiy*term5 + uir*term6 6245 tkxy = ukx*term4 + uky*term5 + ukr*term6 6246 term4 = -usr5 * zr 6247 term6 = xr*zr*term2 - rr5*zr*urc5(1) 6248 tixz = uix*term4 + uiz*term5 + uir*term6 6249 tkxz = ukx*term4 + ukz*term5 + ukr*term6 6250 term5 = -yr*term1 + rr3*urc3(2) 6251 term6 = yr*zr*term2 - rr5*zr*urc5(2) 6252 tiyz = uiy*term4 + uiz*term5 + uir*term6 6253 tkyz = uky*term4 + ukz*term5 + ukr*term6 6254 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 6255 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 6256 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 6257 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 6258 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 6259 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 6260 frcx = frcx + depx 6261 frcy = frcy + depy 6262 frcz = frcz + depz 6263c 6264c get the dtau/dr terms used for mutual polarization force 6265c 6266 else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then 6267 term1 = 2.0d0 * rr5ik 6268 term2 = term1*xr 6269 term3 = rr5ik - rr7ik*xr*xr 6270 tixx = uix*term2 + uir*term3 6271 tkxx = ukx*term2 + ukr*term3 6272 term2 = term1*yr 6273 term3 = rr5ik - rr7ik*yr*yr 6274 tiyy = uiy*term2 + uir*term3 6275 tkyy = uky*term2 + ukr*term3 6276 term2 = term1*zr 6277 term3 = rr5ik - rr7ik*zr*zr 6278 tizz = uiz*term2 + uir*term3 6279 tkzz = ukz*term2 + ukr*term3 6280 term1 = rr5ik*yr 6281 term2 = rr5ik*xr 6282 term3 = yr * (rr7ik*xr) 6283 tixy = uix*term1 + uiy*term2 - uir*term3 6284 tkxy = ukx*term1 + uky*term2 - ukr*term3 6285 term1 = rr5ik * zr 6286 term3 = zr * (rr7ik*xr) 6287 tixz = uix*term1 + uiz*term2 - uir*term3 6288 tkxz = ukx*term1 + ukz*term2 - ukr*term3 6289 term2 = rr5ik*yr 6290 term3 = zr * (rr7ik*yr) 6291 tiyz = uiy*term1 + uiz*term2 - uir*term3 6292 tkyz = uky*term1 + ukz*term2 - ukr*term3 6293 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 6294 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 6295 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 6296 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 6297 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 6298 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 6299 frcx = frcx - depx 6300 frcy = frcy - depy 6301 frcz = frcz - depz 6302c 6303c get the dtau/dr terms used for OPT polarization force 6304c 6305 else if (poltyp.eq.'OPT' .and. use_thole) then 6306 do j = 0, optorder-1 6307 uirm = uopt(j,1,ii)*xr + uopt(j,2,ii)*yr 6308 & + uopt(j,3,ii)*zr 6309 do m = 0, optorder-j-1 6310 ukrm = uopt(m,1,kk)*xr + uopt(m,2,kk)*yr 6311 & + uopt(m,3,kk)*zr 6312 term1 = dmpe(5) - usc3*rr5 6313 term2 = dmpe(7) - usc5*rr7 6314 term3 = usr5 + term1 6315 term4 = rr3 * uscale(k) 6316 term5 = -xr*term3 + rc3(1)*term4 6317 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 6318 tixx = uopt(j,1,ii)*term5 + uirm*term6 6319 tkxx = uopt(m,1,kk)*term5 + ukrm*term6 6320 term5 = -yr*term3 + rc3(2)*term4 6321 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 6322 tiyy = uopt(j,2,ii)*term5 + uirm*term6 6323 tkyy = uopt(m,2,kk)*term5 + ukrm*term6 6324 term5 = -zr*term3 + rc3(3)*term4 6325 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 6326 tizz = uopt(j,3,ii)*term5 + uirm*term6 6327 tkzz = uopt(m,3,kk)*term5 + ukrm*term6 6328 term4 = -usr5 * yr 6329 term5 = -xr*term1 + rr3*urc3(1) 6330 term6 = xr*yr*term2 - rr5*yr*urc5(1) 6331 tixy = uopt(j,1,ii)*term4 + uopt(j,2,ii)*term5 6332 & + uirm*term6 6333 tkxy = uopt(m,1,kk)*term4 + uopt(m,2,kk)*term5 6334 & + ukrm*term6 6335 term4 = -usr5 * zr 6336 term6 = xr*zr*term2 - rr5*zr*urc5(1) 6337 tixz = uopt(j,1,ii)*term4 + uopt(j,3,ii)*term5 6338 & + uirm*term6 6339 tkxz = uopt(m,1,kk)*term4 + uopt(m,3,kk)*term5 6340 & + ukrm*term6 6341 term5 = -yr*term1 + rr3*urc3(2) 6342 term6 = yr*zr*term2 - rr5*zr*urc5(2) 6343 tiyz = uopt(j,2,ii)*term4 + uopt(j,3,ii)*term5 6344 & + uirm*term6 6345 tkyz = uopt(m,2,kk)*term4 + uopt(m,3,kk)*term5 6346 & + ukrm*term6 6347 depx = tixx*uoptp(m,1,kk) + tkxx*uoptp(j,1,ii) 6348 & + tixy*uoptp(m,2,kk) + tkxy*uoptp(j,2,ii) 6349 & + tixz*uoptp(m,3,kk) + tkxz*uoptp(j,3,ii) 6350 depy = tixy*uoptp(m,1,kk) + tkxy*uoptp(j,1,ii) 6351 & + tiyy*uoptp(m,2,kk) + tkyy*uoptp(j,2,ii) 6352 & + tiyz*uoptp(m,3,kk) + tkyz*uoptp(j,3,ii) 6353 depz = tixz*uoptp(m,1,kk) + tkxz*uoptp(j,1,ii) 6354 & + tiyz*uoptp(m,2,kk) + tkyz*uoptp(j,2,ii) 6355 & + tizz*uoptp(m,3,kk) + tkzz*uoptp(j,3,ii) 6356 frcx = frcx + copm(j+m+1)*depx 6357 frcy = frcy + copm(j+m+1)*depy 6358 frcz = frcz + copm(j+m+1)*depz 6359 end do 6360 end do 6361c 6362c get the dtau/dr terms used for OPT polarization force 6363c 6364 else if (poltyp.eq.'OPT' .and. use_chgpen) then 6365 do j = 0, optorder-1 6366 uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr 6367 & + uopt(j,3,i)*zr 6368 do m = 0, optorder-j-1 6369 ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr 6370 & + uopt(m,3,k)*zr 6371 term1 = 2.0d0 * rr5ik 6372 term2 = term1*xr 6373 term3 = rr5ik - rr7ik*xr*xr 6374 tixx = uopt(j,1,i)*term2 + uirm*term3 6375 tkxx = uopt(m,1,k)*term2 + ukrm*term3 6376 term2 = term1*yr 6377 term3 = rr5ik - rr7ik*yr*yr 6378 tiyy = uopt(j,2,i)*term2 + uirm*term3 6379 tkyy = uopt(m,2,k)*term2 + ukrm*term3 6380 term2 = term1*zr 6381 term3 = rr5ik - rr7ik*zr*zr 6382 tizz = uopt(j,3,i)*term2 + uirm*term3 6383 tkzz = uopt(m,3,k)*term2 + ukrm*term3 6384 term1 = rr5ik*yr 6385 term2 = rr5ik*xr 6386 term3 = yr * (rr7ik*xr) 6387 tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2 6388 & - uirm*term3 6389 tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2 6390 & - ukrm*term3 6391 term1 = rr5ik * zr 6392 term3 = zr * (rr7ik*xr) 6393 tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2 6394 & - uirm*term3 6395 tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2 6396 & - ukrm*term3 6397 term2 = rr5ik*yr 6398 term3 = zr * (rr7ik*yr) 6399 tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2 6400 & - uirm*term3 6401 tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2 6402 & - ukrm*term3 6403 depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i) 6404 & + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i) 6405 & + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i) 6406 depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i) 6407 & + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i) 6408 & + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i) 6409 depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i) 6410 & + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i) 6411 & + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i) 6412 frcx = frcx - copm(j+m+1)*depx 6413 frcy = frcy - copm(j+m+1)*depy 6414 frcz = frcz - copm(j+m+1)*depz 6415 end do 6416 end do 6417c 6418c get the dtau/dr terms used for TCG polarization force 6419c 6420 else if (poltyp.eq.'TCG' .and. use_thole) then 6421 do j = 1, tcgnab 6422 ukx = ubd(1,kk,j) 6423 uky = ubd(2,kk,j) 6424 ukz = ubd(3,kk,j) 6425 ukxp = ubp(1,kk,j) 6426 ukyp = ubp(2,kk,j) 6427 ukzp = ubp(3,kk,j) 6428 uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr 6429 ukrt = ukx*xr + uky*yr + ukz*zr 6430 term1 = dmpe(5) - usc3*rr5 6431 term2 = dmpe(7) - usc5*rr7 6432 term3 = usr5 + term1 6433 term4 = rr3 * uscale(k) 6434 term5 = -xr*term3 + rc3(1)*term4 6435 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 6436 tixx = uax(j)*term5 + uirt*term6 6437 tkxx = ukx*term5 + ukrt*term6 6438 term5 = -yr*term3 + rc3(2)*term4 6439 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 6440 tiyy = uay(j)*term5 + uirt*term6 6441 tkyy = uky*term5 + ukrt*term6 6442 term5 = -zr*term3 + rc3(3)*term4 6443 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 6444 tizz = uaz(j)*term5 + uirt*term6 6445 tkzz = ukz*term5 + ukrt*term6 6446 term4 = -usr5 * yr 6447 term5 = -xr*term1 + rr3*urc3(1) 6448 term6 = xr*yr*term2 - rr5*yr*urc5(1) 6449 tixy = uax(j)*term4 + uay(j)*term5 + uirt*term6 6450 tkxy = ukx*term4 + uky*term5 + ukrt*term6 6451 term4 = -usr5 * zr 6452 term6 = xr*zr*term2 - rr5*zr*urc5(1) 6453 tixz = uax(j)*term4 + uaz(j)*term5 + uirt*term6 6454 tkxz = ukx*term4 + ukz*term5 + ukrt*term6 6455 term5 = -yr*term1 + rr3*urc3(2) 6456 term6 = yr*zr*term2 - rr5*zr*urc5(2) 6457 tiyz = uay(j)*term4 + uaz(j)*term5 + uirt*term6 6458 tkyz = uky*term4 + ukz*term5 + ukrt*term6 6459 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 6460 & + tkxx*uaxp(j) + tkxy*uayp(j) 6461 & + tkxz*uazp(j) 6462 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 6463 & + tkxy*uaxp(j) + tkyy*uayp(j) 6464 & + tkyz*uazp(j) 6465 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 6466 & + tkxz*uaxp(j) + tkyz*uayp(j) 6467 & + tkzz*uazp(j) 6468 frcx = frcx + depx 6469 frcy = frcy + depy 6470 frcz = frcz + depz 6471 ukx = uad(1,kk,j) 6472 uky = uad(2,kk,j) 6473 ukz = uad(3,kk,j) 6474 ukxp = uap(1,kk,j) 6475 ukyp = uap(2,kk,j) 6476 ukzp = uap(3,kk,j) 6477 uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr 6478 ukrt = ukx*xr + uky*yr + ukz*zr 6479 term1 = dmpe(5) - usc3*rr5 6480 term2 = dmpe(7) - usc5*rr7 6481 term3 = usr5 + term1 6482 term4 = rr3 * uscale(k) 6483 term5 = -xr*term3 + rc3(1)*term4 6484 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 6485 tixx = ubx(j)*term5 + uirt*term6 6486 tkxx = ukx*term5 + ukrt*term6 6487 term5 = -yr*term3 + rc3(2)*term4 6488 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 6489 tiyy = uby(j)*term5 + uirt*term6 6490 tkyy = uky*term5 + ukrt*term6 6491 term5 = -zr*term3 + rc3(3)*term4 6492 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 6493 tizz = ubz(j)*term5 + uirt*term6 6494 tkzz = ukz*term5 + ukrt*term6 6495 term4 = -usr5 * yr 6496 term5 = -xr*term1 + rr3*urc3(1) 6497 term6 = xr*yr*term2 - rr5*yr*urc5(1) 6498 tixy = ubx(j)*term4 + uby(j)*term5 + uirt*term6 6499 tkxy = ukx*term4 + uky*term5 + ukrt*term6 6500 term4 = -usr5 * zr 6501 term6 = xr*zr*term2 - rr5*zr*urc5(1) 6502 tixz = ubx(j)*term4 + ubz(j)*term5 + uirt*term6 6503 tkxz = ukx*term4 + ukz*term5 + ukrt*term6 6504 term5 = -yr*term1 + rr3*urc3(2) 6505 term6 = yr*zr*term2 - rr5*zr*urc5(2) 6506 tiyz = uby(j)*term4 + ubz(j)*term5 + uirt*term6 6507 tkyz = uky*term4 + ukz*term5 + ukrt*term6 6508 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 6509 & + tkxx*ubxp(j) + tkxy*ubyp(j) 6510 & + tkxz*ubzp(j) 6511 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 6512 & + tkxy*ubxp(j) + tkyy*ubyp(j) 6513 & + tkyz*ubzp(j) 6514 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 6515 & + tkxz*ubxp(j) + tkyz*ubyp(j) 6516 & + tkzz*ubzp(j) 6517 frcx = frcx + depx 6518 frcy = frcy + depy 6519 frcz = frcz + depz 6520 end do 6521 end if 6522c 6523c force and torque components scaled for self-interactions 6524c 6525 if (i .eq. k) then 6526 frcx = 0.5d0 * frcx 6527 frcy = 0.5d0 * frcy 6528 frcz = 0.5d0 * frcz 6529 do j = 1, 3 6530 psr3 = 0.5d0 * psr3 6531 psr5 = 0.5d0 * psr5 6532 psr7 = 0.5d0 * psr7 6533 dsr3 = 0.5d0 * dsr3 6534 dsr5 = 0.5d0 * dsr5 6535 dsr7 = 0.5d0 * dsr7 6536 end do 6537 end if 6538c 6539c increment force-based gradient on the interaction sites 6540c 6541 dep(1,i) = dep(1,i) - frcx 6542 dep(2,i) = dep(2,i) - frcy 6543 dep(3,i) = dep(3,i) - frcz 6544 dep(1,k) = dep(1,k) + frcx 6545 dep(2,k) = dep(2,k) + frcy 6546 dep(3,k) = dep(3,k) + frcz 6547c 6548c increment the virial due to pairwise Cartesian forces 6549c 6550 vxx = xr * frcx 6551 vxy = 0.5d0 * (yr*frcx+xr*frcy) 6552 vxz = 0.5d0 * (zr*frcx+xr*frcz) 6553 vyy = yr * frcy 6554 vyz = 0.5d0 * (zr*frcy+yr*frcz) 6555 vzz = zr * frcz 6556 vir(1,1) = vir(1,1) + vxx 6557 vir(2,1) = vir(2,1) + vxy 6558 vir(3,1) = vir(3,1) + vxz 6559 vir(1,2) = vir(1,2) + vxy 6560 vir(2,2) = vir(2,2) + vyy 6561 vir(3,2) = vir(3,2) + vyz 6562 vir(1,3) = vir(1,3) + vxz 6563 vir(2,3) = vir(2,3) + vyz 6564 vir(3,3) = vir(3,3) + vzz 6565 end if 6566 end do 6567 end do 6568c 6569c reset exclusion coefficients for connected atoms 6570c 6571 if (dpequal) then 6572 do j = 1, n12(i) 6573 pscale(i12(j,i)) = 1.0d0 6574 dscale(i12(j,i)) = 1.0d0 6575 wscale(i12(j,i)) = 1.0d0 6576 end do 6577 do j = 1, n13(i) 6578 pscale(i13(j,i)) = 1.0d0 6579 dscale(i13(j,i)) = 1.0d0 6580 wscale(i13(j,i)) = 1.0d0 6581 end do 6582 do j = 1, n14(i) 6583 pscale(i14(j,i)) = 1.0d0 6584 dscale(i14(j,i)) = 1.0d0 6585 wscale(i14(j,i)) = 1.0d0 6586 end do 6587 do j = 1, n15(i) 6588 pscale(i15(j,i)) = 1.0d0 6589 dscale(i15(j,i)) = 1.0d0 6590 wscale(i15(j,i)) = 1.0d0 6591 end do 6592 do j = 1, np11(i) 6593 uscale(ip11(j,i)) = 1.0d0 6594 end do 6595 do j = 1, np12(i) 6596 uscale(ip12(j,i)) = 1.0d0 6597 end do 6598 do j = 1, np13(i) 6599 uscale(ip13(j,i)) = 1.0d0 6600 end do 6601 do j = 1, np14(i) 6602 uscale(ip14(j,i)) = 1.0d0 6603 end do 6604 else 6605 do j = 1, n12(i) 6606 pscale(i12(j,i)) = 1.0d0 6607 wscale(i12(j,i)) = 1.0d0 6608 end do 6609 do j = 1, n13(i) 6610 pscale(i13(j,i)) = 1.0d0 6611 wscale(i13(j,i)) = 1.0d0 6612 end do 6613 do j = 1, n14(i) 6614 pscale(i14(j,i)) = 1.0d0 6615 wscale(i14(j,i)) = 1.0d0 6616 end do 6617 do j = 1, n15(i) 6618 pscale(i15(j,i)) = 1.0d0 6619 wscale(i15(j,i)) = 1.0d0 6620 end do 6621 do j = 1, np11(i) 6622 dscale(ip11(j,i)) = 1.0d0 6623 uscale(ip11(j,i)) = 1.0d0 6624 end do 6625 do j = 1, np12(i) 6626 dscale(ip12(j,i)) = 1.0d0 6627 uscale(ip12(j,i)) = 1.0d0 6628 end do 6629 do j = 1, np13(i) 6630 dscale(ip13(j,i)) = 1.0d0 6631 uscale(ip13(j,i)) = 1.0d0 6632 end do 6633 do j = 1, np14(i) 6634 dscale(ip14(j,i)) = 1.0d0 6635 uscale(ip14(j,i)) = 1.0d0 6636 end do 6637 end if 6638 end do 6639 end if 6640c 6641c torque is induced field and gradient cross permanent moments 6642c 6643 do ii = 1, npole 6644 i = ipole(ii) 6645 dix = rpole(2,ii) 6646 diy = rpole(3,ii) 6647 diz = rpole(4,ii) 6648 qixx = rpole(5,ii) 6649 qixy = rpole(6,ii) 6650 qixz = rpole(7,ii) 6651 qiyy = rpole(9,ii) 6652 qiyz = rpole(10,ii) 6653 qizz = rpole(13,ii) 6654 tep(1) = diz*ufld(2,i) - diy*ufld(3,i) 6655 & + qixz*dufld(2,i) - qixy*dufld(4,i) 6656 & + 2.0d0*qiyz*(dufld(3,i)-dufld(6,i)) 6657 & + (qizz-qiyy)*dufld(5,i) 6658 tep(2) = dix*ufld(3,i) - diz*ufld(1,i) 6659 & - qiyz*dufld(2,i) + qixy*dufld(5,i) 6660 & + 2.0d0*qixz*(dufld(6,i)-dufld(1,i)) 6661 & + (qixx-qizz)*dufld(4,i) 6662 tep(3) = diy*ufld(1,i) - dix*ufld(2,i) 6663 & + qiyz*dufld(4,i) - qixz*dufld(5,i) 6664 & + 2.0d0*qixy*(dufld(1,i)-dufld(3,i)) 6665 & + (qiyy-qixx)*dufld(2,i) 6666 call torque (ii,tep,fix,fiy,fiz,dep) 6667 iz = zaxis(ii) 6668 ix = xaxis(ii) 6669 iy = abs(yaxis(ii)) 6670 if (iz .eq. 0) iz = i 6671 if (ix .eq. 0) ix = i 6672 if (iy .eq. 0) iy = i 6673 xiz = x(iz) - x(i) 6674 yiz = y(iz) - y(i) 6675 ziz = z(iz) - z(i) 6676 xix = x(ix) - x(i) 6677 yix = y(ix) - y(i) 6678 zix = z(ix) - z(i) 6679 xiy = x(iy) - x(i) 6680 yiy = y(iy) - y(i) 6681 ziy = z(iy) - z(i) 6682 vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1) 6683 vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1) 6684 & + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2)) 6685 vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1) 6686 & + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 6687 vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2) 6688 vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2) 6689 & + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3)) 6690 vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3) 6691 vir(1,1) = vir(1,1) + vxx 6692 vir(2,1) = vir(2,1) + vxy 6693 vir(3,1) = vir(3,1) + vxz 6694 vir(1,2) = vir(1,2) + vxy 6695 vir(2,2) = vir(2,2) + vyy 6696 vir(3,2) = vir(3,2) + vyz 6697 vir(1,3) = vir(1,3) + vxz 6698 vir(2,3) = vir(2,3) + vyz 6699 vir(3,3) = vir(3,3) + vzz 6700 end do 6701c 6702c modify the gradient and virial for charge flux 6703c 6704 if (use_chgflx) then 6705 call dcflux (pot,decfx,decfy,decfz) 6706 do ii = 1, npole 6707 i = ipole(ii) 6708 xi = x(i) 6709 yi = y(i) 6710 zi = z(i) 6711 frcx = decfx(i) 6712 frcy = decfy(i) 6713 frcz = decfz(i) 6714 dep(1,i) = dep(1,i) + frcx 6715 dep(2,i) = dep(2,i) + frcy 6716 dep(3,i) = dep(3,i) + frcz 6717 vxx = xi * frcx 6718 vxy = yi * frcx 6719 vxz = zi * frcx 6720 vyy = yi * frcy 6721 vyz = zi * frcy 6722 vzz = zi * frcz 6723 vir(1,1) = vir(1,1) + vxx 6724 vir(2,1) = vir(2,1) + vxy 6725 vir(3,1) = vir(3,1) + vxz 6726 vir(1,2) = vir(1,2) + vxy 6727 vir(2,2) = vir(2,2) + vyy 6728 vir(3,2) = vir(3,2) + vyz 6729 vir(1,3) = vir(1,3) + vxz 6730 vir(2,3) = vir(2,3) + vyz 6731 vir(3,3) = vir(3,3) + vzz 6732 end do 6733 end if 6734c 6735c perform deallocation of some local arrays 6736c 6737 deallocate (pscale) 6738 deallocate (dscale) 6739 deallocate (uscale) 6740 deallocate (wscale) 6741 deallocate (ufld) 6742 deallocate (dufld) 6743 deallocate (pot) 6744 deallocate (decfx) 6745 deallocate (decfy) 6746 deallocate (decfz) 6747 return 6748 end 6749c 6750c 6751c ################################################################### 6752c ## ## 6753c ## subroutine epolar1d -- Ewald polarization derivs via list ## 6754c ## ## 6755c ################################################################### 6756c 6757c 6758c "epolar1d" calculates the dipole polarization energy and 6759c derivatives with respect to Cartesian coordinates using 6760c particle mesh Ewald summation and a neighbor list 6761c 6762c 6763 subroutine epolar1d 6764 use atoms 6765 use boxes 6766 use chgpot 6767 use deriv 6768 use energi 6769 use ewald 6770 use math 6771 use mpole 6772 use pme 6773 use polar 6774 use polpot 6775 use poltcg 6776 use potent 6777 use virial 6778 implicit none 6779 integer i,j,ii 6780 integer ix,iy,iz 6781 real*8 f,term 6782 real*8 dix,diy,diz 6783 real*8 uix,uiy,uiz 6784 real*8 xd,yd,zd 6785 real*8 xq,yq,zq 6786 real*8 xu,yu,zu 6787 real*8 xup,yup,zup 6788 real*8 xv,yv,zv,vterm 6789 real*8 xufield,yufield 6790 real*8 zufield 6791 real*8 xix,yix,zix 6792 real*8 xiy,yiy,ziy 6793 real*8 xiz,yiz,ziz 6794 real*8 vxx,vyy,vzz 6795 real*8 vxy,vxz,vyz 6796 real*8 fix(3),fiy(3),fiz(3) 6797 real*8 tep(3) 6798c 6799c 6800c zero out the polarization energy and derivatives 6801c 6802 ep = 0.0d0 6803 do i = 1, n 6804 do j = 1, 3 6805 dep(j,i) = 0.0d0 6806 end do 6807 end do 6808 if (npole .eq. 0) return 6809c 6810c set grid size, spline order and Ewald coefficient 6811c 6812 nfft1 = nefft1 6813 nfft2 = nefft2 6814 nfft3 = nefft3 6815 bsorder = bsporder 6816 aewald = apewald 6817c 6818c set the energy unit conversion factor 6819c 6820 f = electric / dielec 6821c 6822c check the sign of multipole components at chiral sites 6823c 6824 if (.not. use_mpole) call chkpole 6825c 6826c rotate the multipole components into the global frame 6827c 6828 if (.not. use_mpole) call rotpole 6829c 6830c compute the induced dipoles at each polarizable atom 6831c 6832 call induce 6833c 6834c compute the total induced dipole polarization energy 6835c 6836 call epolar1e 6837c 6838c compute the real space part of the Ewald summation 6839c 6840 call epreal1d 6841c 6842c compute the reciprocal space part of the Ewald summation 6843c 6844 call eprecip1 6845c 6846c compute the Ewald self-energy torque and virial terms 6847c 6848 term = (4.0d0/3.0d0) * f * aewald**3 / rootpi 6849 do ii = 1, npole 6850 i = ipole(ii) 6851 dix = rpole(2,ii) 6852 diy = rpole(3,ii) 6853 diz = rpole(4,ii) 6854 uix = 0.5d0 * (uind(1,ii)+uinp(1,ii)) 6855 uiy = 0.5d0 * (uind(2,ii)+uinp(2,ii)) 6856 uiz = 0.5d0 * (uind(3,ii)+uinp(3,ii)) 6857 tep(1) = term * (diy*uiz-diz*uiy) 6858 tep(2) = term * (diz*uix-dix*uiz) 6859 tep(3) = term * (dix*uiy-diy*uix) 6860 call torque (ii,tep,fix,fiy,fiz,dep) 6861 iz = zaxis(ii) 6862 ix = xaxis(ii) 6863 iy = abs(yaxis(ii)) 6864 if (iz .eq. 0) iz = i 6865 if (ix .eq. 0) ix = i 6866 if (iy .eq. 0) iy = i 6867 xiz = x(iz) - x(i) 6868 yiz = y(iz) - y(i) 6869 ziz = z(iz) - z(i) 6870 xix = x(ix) - x(i) 6871 yix = y(ix) - y(i) 6872 zix = z(ix) - z(i) 6873 xiy = x(iy) - x(i) 6874 yiy = y(iy) - y(i) 6875 ziy = z(iy) - z(i) 6876 vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1) 6877 vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1) 6878 & + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2)) 6879 vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1) 6880 & + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 6881 vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2) 6882 vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2) 6883 & + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3)) 6884 vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3) 6885 vir(1,1) = vir(1,1) + vxx 6886 vir(2,1) = vir(2,1) + vxy 6887 vir(3,1) = vir(3,1) + vxz 6888 vir(1,2) = vir(1,2) + vxy 6889 vir(2,2) = vir(2,2) + vyy 6890 vir(3,2) = vir(3,2) + vyz 6891 vir(1,3) = vir(1,3) + vxz 6892 vir(2,3) = vir(2,3) + vyz 6893 vir(3,3) = vir(3,3) + vzz 6894 end do 6895c 6896c compute the cell dipole boundary correction term 6897c 6898 if (boundary .eq. 'VACUUM') then 6899 xd = 0.0d0 6900 yd = 0.0d0 6901 zd = 0.0d0 6902 xu = 0.0d0 6903 yu = 0.0d0 6904 zu = 0.0d0 6905 xup = 0.0d0 6906 yup = 0.0d0 6907 zup = 0.0d0 6908 do ii = 1, npole 6909 i = ipole(ii) 6910 xd = xd + rpole(2,ii) + rpole(1,ii)*x(ii) 6911 yd = yd + rpole(3,ii) + rpole(1,ii)*y(ii) 6912 zd = zd + rpole(4,ii) + rpole(1,ii)*z(ii) 6913 xu = xu + uind(1,ii) 6914 yu = yu + uind(2,ii) 6915 zu = zu + uind(3,ii) 6916 xup = xup + uinp(1,ii) 6917 yup = yup + uinp(2,ii) 6918 zup = zup + uinp(3,ii) 6919 end do 6920 term = (2.0d0/3.0d0) * f * (pi/volbox) 6921 do ii = 1, npole 6922 i = ipole(ii) 6923 dep(1,i) = dep(1,i) + term*rpole(1,ii)*(xu+xup) 6924 dep(2,i) = dep(2,i) + term*rpole(1,ii)*(yu+yup) 6925 dep(3,i) = dep(3,i) + term*rpole(1,ii)*(zu+zup) 6926 end do 6927 xufield = -term * (xu+xup) 6928 yufield = -term * (yu+yup) 6929 zufield = -term * (zu+zup) 6930 do ii = 1, npole 6931 tep(1) = rpole(3,ii)*zufield - rpole(4,ii)*yufield 6932 tep(2) = rpole(4,ii)*xufield - rpole(2,ii)*zufield 6933 tep(3) = rpole(2,ii)*yufield - rpole(3,ii)*xufield 6934 call torque (ii,tep,fix,fiy,fiz,dep) 6935 end do 6936c 6937c boundary correction to virial due to overall cell dipole 6938c 6939 xd = 0.0d0 6940 yd = 0.0d0 6941 zd = 0.0d0 6942 xq = 0.0d0 6943 yq = 0.0d0 6944 zq = 0.0d0 6945 do ii = 1, npole 6946 i = ipole(ii) 6947 xd = xd + rpole(2,ii) 6948 yd = yd + rpole(3,ii) 6949 zd = zd + rpole(4,ii) 6950 xq = xq + rpole(1,ii)*x(i) 6951 yq = yq + rpole(1,ii)*y(i) 6952 zq = zq + rpole(1,ii)*z(i) 6953 end do 6954 xv = xq * (xu+xup) 6955 yv = yq * (yu+yup) 6956 zv = zq * (zu+zup) 6957 vterm = xv + yv + zv + xu*xup + yu*yup + zu*zup 6958 & + xd*(xu+xup) + yd*(yu+yup) + zd*(zu+zup) 6959 vterm = term * vterm 6960 vir(1,1) = vir(1,1) + term*xv + vterm 6961 vir(2,1) = vir(2,1) + term*xv 6962 vir(3,1) = vir(3,1) + term*xv 6963 vir(1,2) = vir(1,2) + term*yv 6964 vir(2,2) = vir(2,2) + term*yv + vterm 6965 vir(3,2) = vir(3,2) + term*yv 6966 vir(1,3) = vir(1,3) + term*zv 6967 vir(2,3) = vir(2,3) + term*zv 6968 vir(3,3) = vir(3,3) + term*zv + vterm 6969 if (poltyp .eq. 'DIRECT') then 6970 vterm = term * (xu*xup+yu*yup+zu*zup) 6971 vir(1,1) = vir(1,1) + vterm 6972 vir(2,2) = vir(2,2) + vterm 6973 vir(3,3) = vir(3,3) + vterm 6974 end if 6975 end if 6976 return 6977 end 6978c 6979c 6980c ################################################################# 6981c ## ## 6982c ## subroutine epreal1d -- Ewald real space derivs via list ## 6983c ## ## 6984c ################################################################# 6985c 6986c 6987c "epreal1d" evaluates the real space portion of the Ewald 6988c summation energy and gradient due to dipole polarization 6989c via a neighbor list 6990c 6991c 6992 subroutine epreal1d 6993 use atoms 6994 use bound 6995 use chgpen 6996 use chgpot 6997 use couple 6998 use deriv 6999 use ewald 7000 use math 7001 use mplpot 7002 use mpole 7003 use neigh 7004 use polar 7005 use polgrp 7006 use polopt 7007 use polpot 7008 use poltcg 7009 use potent 7010 use shunt 7011 use virial 7012 implicit none 7013 integer i,j,k,m 7014 integer ii,kk,kkk 7015 integer ix,iy,iz 7016 real*8 f,pgamma 7017 real*8 pdi,pti,ddi 7018 real*8 damp,expdamp 7019 real*8 temp3,temp5,temp7 7020 real*8 sc3,sc5,sc7 7021 real*8 psc3,psc5,psc7 7022 real*8 dsc3,dsc5,dsc7 7023 real*8 usc3,usc5 7024 real*8 psr3,psr5,psr7 7025 real*8 dsr3,dsr5,dsr7 7026 real*8 usr3,usr5 7027 real*8 rr3core,rr5core 7028 real*8 rr3i,rr5i 7029 real*8 rr7i,rr9i 7030 real*8 rr3k,rr5k 7031 real*8 rr7k,rr9k 7032 real*8 rr5ik,rr7ik 7033 real*8 xi,yi,zi 7034 real*8 xr,yr,zr 7035 real*8 r,r2,rr1,rr3 7036 real*8 rr5,rr7,rr9 7037 real*8 ci,dix,diy,diz 7038 real*8 qixx,qixy,qixz 7039 real*8 qiyy,qiyz,qizz 7040 real*8 uix,uiy,uiz 7041 real*8 uixp,uiyp,uizp 7042 real*8 ck,dkx,dky,dkz 7043 real*8 qkxx,qkxy,qkxz 7044 real*8 qkyy,qkyz,qkzz 7045 real*8 ukx,uky,ukz 7046 real*8 ukxp,ukyp,ukzp 7047 real*8 dir,uir,uirp 7048 real*8 dkr,ukr,ukrp 7049 real*8 qix,qiy,qiz,qir 7050 real*8 qkx,qky,qkz,qkr 7051 real*8 corei,corek 7052 real*8 vali,valk 7053 real*8 alphai,alphak 7054 real*8 uirm,ukrm 7055 real*8 uirt,ukrt 7056 real*8 tuir,tukr 7057 real*8 tixx,tiyy,tizz 7058 real*8 tixy,tixz,tiyz 7059 real*8 tkxx,tkyy,tkzz 7060 real*8 tkxy,tkxz,tkyz 7061 real*8 tix3,tiy3,tiz3 7062 real*8 tix5,tiy5,tiz5 7063 real*8 tkx3,tky3,tkz3 7064 real*8 tkx5,tky5,tkz5 7065 real*8 term1,term2,term3 7066 real*8 term4,term5 7067 real*8 term6,term7 7068 real*8 term1core 7069 real*8 term1i,term2i,term3i 7070 real*8 term4i,term5i,term6i 7071 real*8 term7i,term8i 7072 real*8 term1k,term2k,term3k 7073 real*8 term4k,term5k,term6k 7074 real*8 term7k,term8k 7075 real*8 poti,potk 7076 real*8 depx,depy,depz 7077 real*8 frcx,frcy,frcz 7078 real*8 xix,yix,zix 7079 real*8 xiy,yiy,ziy 7080 real*8 xiz,yiz,ziz 7081 real*8 vxx,vyy,vzz 7082 real*8 vxy,vxz,vyz 7083 real*8 rc3(3),rc5(3),rc7(3) 7084 real*8 prc3(3),prc5(3),prc7(3) 7085 real*8 drc3(3),drc5(3),drc7(3) 7086 real*8 urc3(3),urc5(3),tep(3) 7087 real*8 fix(3),fiy(3),fiz(3) 7088 real*8 uax(3),uay(3),uaz(3) 7089 real*8 ubx(3),uby(3),ubz(3) 7090 real*8 uaxp(3),uayp(3),uazp(3) 7091 real*8 ubxp(3),ubyp(3),ubzp(3) 7092 real*8 dmpi(9),dmpk(9) 7093 real*8 dmpik(9),dmpe(9) 7094 real*8, allocatable :: pscale(:) 7095 real*8, allocatable :: dscale(:) 7096 real*8, allocatable :: uscale(:) 7097 real*8, allocatable :: wscale(:) 7098 real*8, allocatable :: ufld(:,:) 7099 real*8, allocatable :: dufld(:,:) 7100 real*8, allocatable :: pot(:) 7101 real*8, allocatable :: decfx(:) 7102 real*8, allocatable :: decfy(:) 7103 real*8, allocatable :: decfz(:) 7104 character*6 mode 7105c 7106c 7107c perform dynamic allocation of some local arrays 7108c 7109 allocate (pscale(n)) 7110 allocate (dscale(n)) 7111 allocate (uscale(n)) 7112 allocate (wscale(n)) 7113 allocate (ufld(3,n)) 7114 allocate (dufld(6,n)) 7115 allocate (pot(n)) 7116 allocate (decfx(n)) 7117 allocate (decfy(n)) 7118 allocate (decfz(n)) 7119c 7120c set exclusion coefficients and arrays to store fields 7121c 7122 do i = 1, n 7123 pscale(i) = 1.0d0 7124 dscale(i) = 1.0d0 7125 uscale(i) = 1.0d0 7126 wscale(i) = 1.0d0 7127 do j = 1, 3 7128 ufld(j,i) = 0.0d0 7129 end do 7130 do j = 1, 6 7131 dufld(j,i) = 0.0d0 7132 end do 7133 pot(i) = 0.0d0 7134 end do 7135c 7136c set conversion factor, cutoff and switching coefficients 7137c 7138 f = 0.5d0 * electric / dielec 7139 mode = 'EWALD' 7140 call switch (mode) 7141c 7142c OpenMP directives for the major loop structure 7143c 7144!$OMP PARALLEL default(private) shared(npole,ipole,x,y,z,rpole,uind, 7145!$OMP& uinp,pdamp,thole,dirdamp,pcore,pval,palpha,n12,i12,n13,i13,n14, 7146!$OMP& i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14,p2scale, 7147!$OMP& p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale,p5iscale, 7148!$OMP& d1scale,d2scale,d3scale,d4scale,u1scale,u2scale,u3scale,u4scale, 7149!$OMP& w2scale,w3scale,w4scale,w5scale,nelst,elst,dpequal,use_thole, 7150!$OMP& use_chgpen,use_chgflx,use_dirdamp,use_bounds,off2,f,aewald, 7151!$OMP& optorder,copm,uopt,uoptp,poltyp,tcgnab,uad,uap,ubd,ubp,xaxis, 7152!$OMP& yaxis,zaxis) 7153!$OMP& shared (dep,ufld,dufld,pot,vir) 7154!$OMP& firstprivate(pscale,dscale,uscale,wscale) 7155!$OMP DO reduction(+:dep,ufld,dufld,pot,vir) schedule(guided) 7156c 7157c compute the dipole polarization gradient components 7158c 7159 do ii = 1, npole 7160 i = ipole(ii) 7161 xi = x(i) 7162 yi = y(i) 7163 zi = z(i) 7164 ci = rpole(1,ii) 7165 dix = rpole(2,ii) 7166 diy = rpole(3,ii) 7167 diz = rpole(4,ii) 7168 qixx = rpole(5,ii) 7169 qixy = rpole(6,ii) 7170 qixz = rpole(7,ii) 7171 qiyy = rpole(9,ii) 7172 qiyz = rpole(10,ii) 7173 qizz = rpole(13,ii) 7174 uix = uind(1,ii) 7175 uiy = uind(2,ii) 7176 uiz = uind(3,ii) 7177 uixp = uinp(1,ii) 7178 uiyp = uinp(2,ii) 7179 uizp = uinp(3,ii) 7180 do j = 1, tcgnab 7181 uax(j) = uad(1,ii,j) 7182 uay(j) = uad(2,ii,j) 7183 uaz(j) = uad(3,ii,j) 7184 uaxp(j) = uap(1,ii,j) 7185 uayp(j) = uap(2,ii,j) 7186 uazp(j) = uap(3,ii,j) 7187 ubx(j) = ubd(1,ii,j) 7188 uby(j) = ubd(2,ii,j) 7189 ubz(j) = ubd(3,ii,j) 7190 ubxp(j) = ubp(1,ii,j) 7191 ubyp(j) = ubp(2,ii,j) 7192 ubzp(j) = ubp(3,ii,j) 7193 end do 7194 if (use_thole) then 7195 pdi = pdamp(ii) 7196 pti = thole(ii) 7197 ddi = dirdamp(ii) 7198 else if (use_chgpen) then 7199 corei = pcore(ii) 7200 vali = pval(ii) 7201 alphai = palpha(ii) 7202 end if 7203c 7204c set exclusion coefficients for connected atoms 7205c 7206 if (dpequal) then 7207 do j = 1, n12(i) 7208 pscale(i12(j,i)) = p2scale 7209 do k = 1, np11(i) 7210 if (i12(j,i) .eq. ip11(k,i)) 7211 & pscale(i12(j,i)) = p2iscale 7212 end do 7213 dscale(i12(j,i)) = pscale(i12(j,i)) 7214 wscale(i12(j,i)) = w2scale 7215 end do 7216 do j = 1, n13(i) 7217 pscale(i13(j,i)) = p3scale 7218 do k = 1, np11(i) 7219 if (i13(j,i) .eq. ip11(k,i)) 7220 & pscale(i13(j,i)) = p3iscale 7221 end do 7222 dscale(i13(j,i)) = pscale(i13(j,i)) 7223 wscale(i13(j,i)) = w3scale 7224 end do 7225 do j = 1, n14(i) 7226 pscale(i14(j,i)) = p4scale 7227 do k = 1, np11(i) 7228 if (i14(j,i) .eq. ip11(k,i)) 7229 & pscale(i14(j,i)) = p4iscale 7230 end do 7231 dscale(i14(j,i)) = pscale(i14(j,i)) 7232 wscale(i14(j,i)) = w4scale 7233 end do 7234 do j = 1, n15(i) 7235 pscale(i15(j,i)) = p5scale 7236 do k = 1, np11(i) 7237 if (i15(j,i) .eq. ip11(k,i)) 7238 & pscale(i15(j,i)) = p5iscale 7239 end do 7240 dscale(i15(j,i)) = pscale(i15(j,i)) 7241 wscale(i15(j,i)) = w5scale 7242 end do 7243 do j = 1, np11(i) 7244 uscale(ip11(j,i)) = u1scale 7245 end do 7246 do j = 1, np12(i) 7247 uscale(ip12(j,i)) = u2scale 7248 end do 7249 do j = 1, np13(i) 7250 uscale(ip13(j,i)) = u3scale 7251 end do 7252 do j = 1, np14(i) 7253 uscale(ip14(j,i)) = u4scale 7254 end do 7255 else 7256 do j = 1, n12(i) 7257 pscale(i12(j,i)) = p2scale 7258 do k = 1, np11(i) 7259 if (i12(j,i) .eq. ip11(k,i)) 7260 & pscale(i12(j,i)) = p2iscale 7261 end do 7262 wscale(i12(j,i)) = w2scale 7263 end do 7264 do j = 1, n13(i) 7265 pscale(i13(j,i)) = p3scale 7266 do k = 1, np11(i) 7267 if (i13(j,i) .eq. ip11(k,i)) 7268 & pscale(i13(j,i)) = p3iscale 7269 end do 7270 wscale(i13(j,i)) = w3scale 7271 end do 7272 do j = 1, n14(i) 7273 pscale(i14(j,i)) = p4scale 7274 do k = 1, np11(i) 7275 if (i14(j,i) .eq. ip11(k,i)) 7276 & pscale(i14(j,i)) = p4iscale 7277 end do 7278 wscale(i14(j,i)) = w4scale 7279 end do 7280 do j = 1, n15(i) 7281 pscale(i15(j,i)) = p5scale 7282 do k = 1, np11(i) 7283 if (i15(j,i) .eq. ip11(k,i)) 7284 & pscale(i15(j,i)) = p5iscale 7285 end do 7286 wscale(i15(j,i)) = w5scale 7287 end do 7288 do j = 1, np11(i) 7289 dscale(ip11(j,i)) = d1scale 7290 uscale(ip11(j,i)) = u1scale 7291 end do 7292 do j = 1, np12(i) 7293 dscale(ip12(j,i)) = d2scale 7294 uscale(ip12(j,i)) = u2scale 7295 end do 7296 do j = 1, np13(i) 7297 dscale(ip13(j,i)) = d3scale 7298 uscale(ip13(j,i)) = u3scale 7299 end do 7300 do j = 1, np14(i) 7301 dscale(ip14(j,i)) = d4scale 7302 uscale(ip14(j,i)) = u4scale 7303 end do 7304 end if 7305c 7306c evaluate all sites within the cutoff distance 7307c 7308 do kkk = 1, nelst(ii) 7309 kk = elst(kkk,ii) 7310 k = ipole(kk) 7311 xr = x(k) - xi 7312 yr = y(k) - yi 7313 zr = z(k) - zi 7314 if (use_bounds) call image (xr,yr,zr) 7315 r2 = xr*xr + yr*yr + zr*zr 7316 if (r2 .le. off2) then 7317 r = sqrt(r2) 7318 ck = rpole(1,kk) 7319 dkx = rpole(2,kk) 7320 dky = rpole(3,kk) 7321 dkz = rpole(4,kk) 7322 qkxx = rpole(5,kk) 7323 qkxy = rpole(6,kk) 7324 qkxz = rpole(7,kk) 7325 qkyy = rpole(9,kk) 7326 qkyz = rpole(10,kk) 7327 qkzz = rpole(13,kk) 7328 ukx = uind(1,kk) 7329 uky = uind(2,kk) 7330 ukz = uind(3,kk) 7331 ukxp = uinp(1,kk) 7332 ukyp = uinp(2,kk) 7333 ukzp = uinp(3,kk) 7334c 7335c intermediates involving moments and separation distance 7336c 7337 dir = dix*xr + diy*yr + diz*zr 7338 qix = qixx*xr + qixy*yr + qixz*zr 7339 qiy = qixy*xr + qiyy*yr + qiyz*zr 7340 qiz = qixz*xr + qiyz*yr + qizz*zr 7341 qir = qix*xr + qiy*yr + qiz*zr 7342 dkr = dkx*xr + dky*yr + dkz*zr 7343 qkx = qkxx*xr + qkxy*yr + qkxz*zr 7344 qky = qkxy*xr + qkyy*yr + qkyz*zr 7345 qkz = qkxz*xr + qkyz*yr + qkzz*zr 7346 qkr = qkx*xr + qky*yr + qkz*zr 7347 uir = uix*xr + uiy*yr + uiz*zr 7348 uirp = uixp*xr + uiyp*yr + uizp*zr 7349 ukr = ukx*xr + uky*yr + ukz*zr 7350 ukrp = ukxp*xr + ukyp*yr + ukzp*zr 7351c 7352c get reciprocal distance terms for this interaction 7353c 7354 rr1 = f / r 7355 rr3 = rr1 / r2 7356 rr5 = 3.0d0 * rr3 / r2 7357 rr7 = 5.0d0 * rr5 / r2 7358 rr9 = 7.0d0 * rr7 / r2 7359c 7360c calculate real space Ewald error function damping 7361c 7362 call dampewald (9,r,r2,f,dmpe) 7363c 7364c set initial values for tha damping scale factors 7365c 7366 sc3 = 1.0d0 7367 sc5 = 1.0d0 7368 sc7 = 1.0d0 7369 do j = 1, 3 7370 rc3(j) = 0.0d0 7371 rc5(j) = 0.0d0 7372 rc7(j) = 0.0d0 7373 end do 7374c 7375c apply Thole polarization damping to scale factors 7376c 7377 if (use_thole) then 7378 damp = pdi * pdamp(kk) 7379 if (use_dirdamp) then 7380 pgamma = min(ddi,dirdamp(kk)) 7381 if (pgamma .eq. 0.0d0) then 7382 pgamma = max(ddi,dirdamp(kk)) 7383 end if 7384 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 7385 damp = pgamma * (r/damp)**(1.5d0) 7386 if (damp .lt. 50.0d0) then 7387 expdamp = exp(-damp) 7388 sc3 = 1.0d0 - expdamp 7389 sc5 = 1.0d0 - expdamp*(1.0d0+0.5d0*damp) 7390 sc7 = 1.0d0 - expdamp*(1.0d0+0.65d0*damp 7391 & +0.15d0*damp**2) 7392 temp3 = 1.5d0 * damp * expdamp / r2 7393 temp5 = 0.5d0 * (1.0d0+damp) 7394 temp7 = 0.7d0 + 0.15d0*damp**2/temp5 7395 rc3(1) = xr * temp3 7396 rc3(2) = yr * temp3 7397 rc3(3) = zr * temp3 7398 rc5(1) = rc3(1) * temp5 7399 rc5(2) = rc3(2) * temp5 7400 rc5(3) = rc3(3) * temp5 7401 rc7(1) = rc5(1) * temp7 7402 rc7(2) = rc5(2) * temp7 7403 rc7(3) = rc5(3) * temp7 7404 end if 7405 end if 7406 else 7407 pgamma = min(pti,thole(kk)) 7408 if (pgamma .eq. 0.0d0) then 7409 pgamma = max(pti,thole(kk)) 7410 end if 7411 if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then 7412 damp = pgamma * (r/damp)**3 7413 if (damp .lt. 50.0d0) then 7414 expdamp = exp(-damp) 7415 sc3 = 1.0d0 - expdamp 7416 sc5 = 1.0d0 - expdamp*(1.0d0+damp) 7417 sc7 = 1.0d0 - expdamp*(1.0d0+damp 7418 & +0.6d0*damp**2) 7419 temp3 = 3.0d0 * damp * expdamp / r2 7420 temp5 = damp 7421 temp7 = -0.2d0 + 0.6d0*damp 7422 rc3(1) = xr * temp3 7423 rc3(2) = yr * temp3 7424 rc3(3) = zr * temp3 7425 rc5(1) = rc3(1) * temp5 7426 rc5(2) = rc3(2) * temp5 7427 rc5(3) = rc3(3) * temp5 7428 rc7(1) = rc5(1) * temp7 7429 rc7(2) = rc5(2) * temp7 7430 rc7(3) = rc5(3) * temp7 7431 end if 7432 end if 7433 end if 7434 psc3 = 1.0d0 - sc3*pscale(k) 7435 psc5 = 1.0d0 - sc5*pscale(k) 7436 psc7 = 1.0d0 - sc7*pscale(k) 7437 dsc3 = 1.0d0 - sc3*dscale(k) 7438 dsc5 = 1.0d0 - sc5*dscale(k) 7439 dsc7 = 1.0d0 - sc7*dscale(k) 7440 usc3 = 1.0d0 - sc3*uscale(k) 7441 usc5 = 1.0d0 - sc5*uscale(k) 7442 psr3 = dmpe(3) - psc3*rr3 7443 psr5 = dmpe(5) - psc5*rr5 7444 psr7 = dmpe(7) - psc7*rr7 7445 dsr3 = dmpe(3) - dsc3*rr3 7446 dsr5 = dmpe(5) - dsc5*rr5 7447 dsr7 = dmpe(7) - dsc7*rr7 7448 usr3 = dmpe(3) - usc3*rr3 7449 usr5 = dmpe(5) - usc5*rr5 7450 do j = 1, 3 7451 prc3(j) = rc3(j) * pscale(k) 7452 prc5(j) = rc5(j) * pscale(k) 7453 prc7(j) = rc7(j) * pscale(k) 7454 drc3(j) = rc3(j) * dscale(k) 7455 drc5(j) = rc5(j) * dscale(k) 7456 drc7(j) = rc7(j) * dscale(k) 7457 urc3(j) = rc3(j) * uscale(k) 7458 urc5(j) = rc5(j) * uscale(k) 7459 end do 7460c 7461c apply charge penetration damping to scale factors 7462c 7463 else if (use_chgpen) then 7464 corek = pcore(kk) 7465 valk = pval(kk) 7466 alphak = palpha(kk) 7467 call damppole (r,9,alphai,alphak,dmpi,dmpk,dmpik) 7468 rr3core = dmpe(3) - (1.0d0-dscale(k))*rr3 7469 rr5core = dmpe(5) - (1.0d0-dscale(k))*rr5 7470 rr3i = dmpe(3) - (1.0d0-dscale(k)*dmpi(3))*rr3 7471 rr5i = dmpe(5) - (1.0d0-dscale(k)*dmpi(5))*rr5 7472 rr7i = dmpe(7) - (1.0d0-dscale(k)*dmpi(7))*rr7 7473 rr9i = dmpe(9) - (1.0d0-dscale(k)*dmpi(9))*rr9 7474 rr3k = dmpe(3) - (1.0d0-dscale(k)*dmpk(3))*rr3 7475 rr5k = dmpe(5) - (1.0d0-dscale(k)*dmpk(5))*rr5 7476 rr7k = dmpe(7) - (1.0d0-dscale(k)*dmpk(7))*rr7 7477 rr9k = dmpe(9) - (1.0d0-dscale(k)*dmpk(9))*rr9 7478 rr5ik = dmpe(5) - (1.0d0-wscale(k)*dmpik(5))*rr5 7479 rr7ik = dmpe(7) - (1.0d0-wscale(k)*dmpik(7))*rr7 7480 end if 7481c 7482c store the potential at each site for use in charge flux 7483c 7484 if (use_chgflx) then 7485 if (use_thole) then 7486 poti = -ukr*psr3 - ukrp*dsr3 7487 potk = uir*psr3 + uirp*dsr3 7488 else if (use_chgpen) then 7489 poti = -2.0d0 * ukr * rr3i 7490 potk = 2.0d0 * uir * rr3k 7491 end if 7492 pot(i) = pot(i) + poti 7493 pot(k) = pot(k) + potk 7494 end if 7495c 7496c get the induced dipole field used for dipole torques 7497c 7498 if (use_thole) then 7499 tix3 = psr3*ukx + dsr3*ukxp 7500 tiy3 = psr3*uky + dsr3*ukyp 7501 tiz3 = psr3*ukz + dsr3*ukzp 7502 tkx3 = psr3*uix + dsr3*uixp 7503 tky3 = psr3*uiy + dsr3*uiyp 7504 tkz3 = psr3*uiz + dsr3*uizp 7505 tuir = -psr5*ukr - dsr5*ukrp 7506 tukr = -psr5*uir - dsr5*uirp 7507 else if (use_chgpen) then 7508 tix3 = 2.0d0*rr3i*ukx 7509 tiy3 = 2.0d0*rr3i*uky 7510 tiz3 = 2.0d0*rr3i*ukz 7511 tkx3 = 2.0d0*rr3k*uix 7512 tky3 = 2.0d0*rr3k*uiy 7513 tkz3 = 2.0d0*rr3k*uiz 7514 tuir = -2.0d0*rr5i*ukr 7515 tukr = -2.0d0*rr5k*uir 7516 end if 7517 ufld(1,i) = ufld(1,i) + tix3 + xr*tuir 7518 ufld(2,i) = ufld(2,i) + tiy3 + yr*tuir 7519 ufld(3,i) = ufld(3,i) + tiz3 + zr*tuir 7520 ufld(1,k) = ufld(1,k) + tkx3 + xr*tukr 7521 ufld(2,k) = ufld(2,k) + tky3 + yr*tukr 7522 ufld(3,k) = ufld(3,k) + tkz3 + zr*tukr 7523c 7524c get induced dipole field gradient used for quadrupole torques 7525c 7526 if (use_thole) then 7527 tix5 = 2.0d0 * (psr5*ukx+dsr5*ukxp) 7528 tiy5 = 2.0d0 * (psr5*uky+dsr5*ukyp) 7529 tiz5 = 2.0d0 * (psr5*ukz+dsr5*ukzp) 7530 tkx5 = 2.0d0 * (psr5*uix+dsr5*uixp) 7531 tky5 = 2.0d0 * (psr5*uiy+dsr5*uiyp) 7532 tkz5 = 2.0d0 * (psr5*uiz+dsr5*uizp) 7533 tuir = -psr7*ukr - dsr7*ukrp 7534 tukr = -psr7*uir - dsr7*uirp 7535 else if (use_chgpen) then 7536 tix5 = 4.0d0 * (rr5i*ukx) 7537 tiy5 = 4.0d0 * (rr5i*uky) 7538 tiz5 = 4.0d0 * (rr5i*ukz) 7539 tkx5 = 4.0d0 * (rr5k*uix) 7540 tky5 = 4.0d0 * (rr5k*uiy) 7541 tkz5 = 4.0d0 * (rr5k*uiz) 7542 tuir = -2.0d0*rr7i*ukr 7543 tukr = -2.0d0*rr7k*uir 7544 end if 7545 dufld(1,i) = dufld(1,i) + xr*tix5 + xr*xr*tuir 7546 dufld(2,i) = dufld(2,i) + xr*tiy5 + yr*tix5 7547 & + 2.0d0*xr*yr*tuir 7548 dufld(3,i) = dufld(3,i) + yr*tiy5 + yr*yr*tuir 7549 dufld(4,i) = dufld(4,i) + xr*tiz5 + zr*tix5 7550 & + 2.0d0*xr*zr*tuir 7551 dufld(5,i) = dufld(5,i) + yr*tiz5 + zr*tiy5 7552 & + 2.0d0*yr*zr*tuir 7553 dufld(6,i) = dufld(6,i) + zr*tiz5 + zr*zr*tuir 7554 dufld(1,k) = dufld(1,k) - xr*tkx5 - xr*xr*tukr 7555 dufld(2,k) = dufld(2,k) - xr*tky5 - yr*tkx5 7556 & - 2.0d0*xr*yr*tukr 7557 dufld(3,k) = dufld(3,k) - yr*tky5 - yr*yr*tukr 7558 dufld(4,k) = dufld(4,k) - xr*tkz5 - zr*tkx5 7559 & - 2.0d0*xr*zr*tukr 7560 dufld(5,k) = dufld(5,k) - yr*tkz5 - zr*tky5 7561 & - 2.0d0*yr*zr*tukr 7562 dufld(6,k) = dufld(6,k) - zr*tkz5 - zr*zr*tukr 7563c 7564c get the dEd/dR terms used for direct polarization force 7565c 7566 if (use_thole) then 7567 term1 = dmpe(5) - dsc3*rr5 7568 term2 = dmpe(7) - dsc5*rr7 7569 term3 = -dsr3 + term1*xr*xr - rr3*xr*drc3(1) 7570 term4 = rr3*drc3(1) - term1*xr - dsr5*xr 7571 term5 = term2*xr*xr - dsr5 - rr5*xr*drc5(1) 7572 term6 = (dmpe(9)-dsc7*rr9)*xr*xr - dmpe(7) 7573 & - rr7*xr*drc7(1) 7574 term7 = rr5*drc5(1) - 2.0d0*dmpe(7)*xr 7575 & + (dsc5+1.5d0*dsc7)*rr7*xr 7576 tixx = ci*term3 + dix*term4 + dir*term5 7577 & + 2.0d0*dsr5*qixx + (qiy*yr+qiz*zr)*dsc7*rr7 7578 & + 2.0d0*qix*term7 + qir*term6 7579 tkxx = ck*term3 - dkx*term4 - dkr*term5 7580 & + 2.0d0*dsr5*qkxx + (qky*yr+qkz*zr)*dsc7*rr7 7581 & + 2.0d0*qkx*term7 + qkr*term6 7582 term3 = -dsr3 + term1*yr*yr - rr3*yr*drc3(2) 7583 term4 = rr3*drc3(2) - term1*yr - dsr5*yr 7584 term5 = term2*yr*yr - dsr5 - rr5*yr*drc5(2) 7585 term6 = (dmpe(9)-dsc7*rr9)*yr*yr - dmpe(7) 7586 & - rr7*yr*drc7(2) 7587 term7 = rr5*drc5(2) - 2.0d0*dmpe(7)*yr 7588 & + (dsc5+1.5d0*dsc7)*rr7*yr 7589 tiyy = ci*term3 + diy*term4 + dir*term5 7590 & + 2.0d0*dsr5*qiyy + (qix*xr+qiz*zr)*dsc7*rr7 7591 & + 2.0d0*qiy*term7 + qir*term6 7592 tkyy = ck*term3 - dky*term4 - dkr*term5 7593 & + 2.0d0*dsr5*qkyy + (qkx*xr+qkz*zr)*dsc7*rr7 7594 & + 2.0d0*qky*term7 + qkr*term6 7595 term3 = -dsr3 + term1*zr*zr - rr3*zr*drc3(3) 7596 term4 = rr3*drc3(3) - term1*zr - dsr5*zr 7597 term5 = term2*zr*zr - dsr5 - rr5*zr*drc5(3) 7598 term6 = (dmpe(9)-dsc7*rr9)*zr*zr - dmpe(7) 7599 & - rr7*zr*drc7(3) 7600 term7 = rr5*drc5(3) - 2.0d0*dmpe(7)*zr 7601 & + (dsc5+1.5d0*dsc7)*rr7*zr 7602 tizz = ci*term3 + diz*term4 + dir*term5 7603 & + 2.0d0*dsr5*qizz + (qix*xr+qiy*yr)*dsc7*rr7 7604 & + 2.0d0*qiz*term7 + qir*term6 7605 tkzz = ck*term3 - dkz*term4 - dkr*term5 7606 & + 2.0d0*dsr5*qkzz + (qkx*xr+qky*yr)*dsc7*rr7 7607 & + 2.0d0*qkz*term7 + qkr*term6 7608 term3 = term1*xr*yr - rr3*yr*drc3(1) 7609 term4 = rr3*drc3(1) - term1*xr 7610 term5 = term2*xr*yr - rr5*yr*drc5(1) 7611 term6 = (dmpe(9)-dsc7*rr9)*xr*yr - rr7*yr*drc7(1) 7612 term7 = rr5*drc5(1) - term2*xr 7613 tixy = ci*term3 - dsr5*dix*yr + diy*term4 + dir*term5 7614 & + 2.0d0*dsr5*qixy - 2.0d0*dsr7*yr*qix 7615 & + 2.0d0*qiy*term7 + qir*term6 7616 tkxy = ck*term3 + dsr5*dkx*yr - dky*term4 - dkr*term5 7617 & + 2.0d0*dsr5*qkxy - 2.0d0*dsr7*yr*qkx 7618 & + 2.0d0*qky*term7 + qkr*term6 7619 term3 = term1*xr*zr - rr3*zr*drc3(1) 7620 term5 = term2*xr*zr - rr5*zr*drc5(1) 7621 term6 = (dmpe(9)-dsc7*rr9)*xr*zr - rr7*zr*drc7(1) 7622 tixz = ci*term3 - dsr5*dix*zr + diz*term4 + dir*term5 7623 & + 2.0d0*dsr5*qixz - 2.0d0*dsr7*zr*qix 7624 & + 2.0d0*qiz*term7 + qir*term6 7625 tkxz = ck*term3 + dsr5*dkx*zr - dkz*term4 - dkr*term5 7626 & + 2.0d0*dsr5*qkxz - 2.0d0*dsr7*zr*qkx 7627 & + 2.0d0*qkz*term7 + qkr*term6 7628 term3 = term1*yr*zr - rr3*zr*drc3(2) 7629 term4 = rr3*drc3(2) - term1*yr 7630 term5 = term2*yr*zr - rr5*zr*drc5(2) 7631 term6 = (dmpe(9)-dsc7*rr9)*yr*zr - rr7*zr*drc7(2) 7632 term7 = rr5*drc5(2) - term2*yr 7633 tiyz = ci*term3 - dsr5*diy*zr + diz*term4 + dir*term5 7634 & + 2.0d0*dsr5*qiyz - 2.0d0*dsr7*zr*qiy 7635 & + 2.0d0*qiz*term7 + qir*term6 7636 tkyz = ck*term3 + dsr5*dky*zr - dkz*term4 - dkr*term5 7637 & + 2.0d0*dsr5*qkyz - 2.0d0*dsr7*zr*qky 7638 & + 2.0d0*qkz*term7 + qkr*term6 7639 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 7640 & - tkxx*uixp - tkxy*uiyp - tkxz*uizp 7641 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 7642 & - tkxy*uixp - tkyy*uiyp - tkyz*uizp 7643 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 7644 & - tkxz*uixp - tkyz*uiyp - tkzz*uizp 7645 frcx = depx 7646 frcy = depy 7647 frcz = depz 7648c 7649c get the dEp/dR terms used for direct polarization force 7650c 7651 term1 = dmpe(5) - psc3*rr5 7652 term2 = dmpe(7) - psc5*rr7 7653 term3 = -psr3 + term1*xr*xr - rr3*xr*prc3(1) 7654 term4 = rr3*prc3(1) - term1*xr - psr5*xr 7655 term5 = term2*xr*xr - psr5 - rr5*xr*prc5(1) 7656 term6 = (dmpe(9)-psc7*rr9)*xr*xr - dmpe(7) 7657 & - rr7*xr*prc7(1) 7658 term7 = rr5*prc5(1) - 2.0d0*dmpe(7)*xr 7659 & + (psc5+1.5d0*psc7)*rr7*xr 7660 tixx = ci*term3 + dix*term4 + dir*term5 7661 & + 2.0d0*psr5*qixx + (qiy*yr+qiz*zr)*psc7*rr7 7662 & + 2.0d0*qix*term7 + qir*term6 7663 tkxx = ck*term3 - dkx*term4 - dkr*term5 7664 & + 2.0d0*psr5*qkxx + (qky*yr+qkz*zr)*psc7*rr7 7665 & + 2.0d0*qkx*term7 + qkr*term6 7666 term3 = -psr3 + term1*yr*yr - rr3*yr*prc3(2) 7667 term4 = rr3*prc3(2) - term1*yr - psr5*yr 7668 term5 = term2*yr*yr - psr5 - rr5*yr*prc5(2) 7669 term6 = (dmpe(9)-psc7*rr9)*yr*yr - dmpe(7) 7670 & - rr7*yr*prc7(2) 7671 term7 = rr5*prc5(2) - 2.0d0*dmpe(7)*yr 7672 & + (psc5+1.5d0*psc7)*rr7*yr 7673 tiyy = ci*term3 + diy*term4 + dir*term5 7674 & + 2.0d0*psr5*qiyy + (qix*xr+qiz*zr)*psc7*rr7 7675 & + 2.0d0*qiy*term7 + qir*term6 7676 tkyy = ck*term3 - dky*term4 - dkr*term5 7677 & + 2.0d0*psr5*qkyy + (qkx*xr+qkz*zr)*psc7*rr7 7678 & + 2.0d0*qky*term7 + qkr*term6 7679 term3 = -psr3 + term1*zr*zr - rr3*zr*prc3(3) 7680 term4 = rr3*prc3(3) - term1*zr - psr5*zr 7681 term5 = term2*zr*zr - psr5 - rr5*zr*prc5(3) 7682 term6 = (dmpe(9)-psc7*rr9)*zr*zr - dmpe(7) 7683 & - rr7*zr*prc7(3) 7684 term7 = rr5*prc5(3) - 2.0d0*dmpe(7)*zr 7685 & + (psc5+1.5d0*psc7)*rr7*zr 7686 tizz = ci*term3 + diz*term4 + dir*term5 7687 & + 2.0d0*psr5*qizz + (qix*xr+qiy*yr)*psc7*rr7 7688 & + 2.0d0*qiz*term7 + qir*term6 7689 tkzz = ck*term3 - dkz*term4 - dkr*term5 7690 & + 2.0d0*psr5*qkzz + (qkx*xr+qky*yr)*psc7*rr7 7691 & + 2.0d0*qkz*term7 + qkr*term6 7692 term3 = term1*xr*yr - rr3*yr*prc3(1) 7693 term4 = rr3*prc3(1) - term1*xr 7694 term5 = term2*xr*yr - rr5*yr*prc5(1) 7695 term6 = (dmpe(9)-psc7*rr9)*xr*yr - rr7*yr*prc7(1) 7696 term7 = rr5*prc5(1) - term2*xr 7697 tixy = ci*term3 - psr5*dix*yr + diy*term4 + dir*term5 7698 & + 2.0d0*psr5*qixy - 2.0d0*psr7*yr*qix 7699 & + 2.0d0*qiy*term7 + qir*term6 7700 tkxy = ck*term3 + psr5*dkx*yr - dky*term4 - dkr*term5 7701 & + 2.0d0*psr5*qkxy - 2.0d0*psr7*yr*qkx 7702 & + 2.0d0*qky*term7 + qkr*term6 7703 term3 = term1*xr*zr - rr3*zr*prc3(1) 7704 term5 = term2*xr*zr - rr5*zr*prc5(1) 7705 term6 = (dmpe(9)-psc7*rr9)*xr*zr - rr7*zr*prc7(1) 7706 tixz = ci*term3 - psr5*dix*zr + diz*term4 + dir*term5 7707 & + 2.0d0*psr5*qixz - 2.0d0*psr7*zr*qix 7708 & + 2.0d0*qiz*term7 + qir*term6 7709 tkxz = ck*term3 + psr5*dkx*zr - dkz*term4 - dkr*term5 7710 & + 2.0d0*psr5*qkxz - 2.0d0*psr7*zr*qkx 7711 & + 2.0d0*qkz*term7 + qkr*term6 7712 term3 = term1*yr*zr - rr3*zr*prc3(2) 7713 term4 = rr3*prc3(2) - term1*yr 7714 term5 = term2*yr*zr - rr5*zr*prc5(2) 7715 term6 = (dmpe(9)-psc7*rr9)*yr*zr - rr7*zr*prc7(2) 7716 term7 = rr5*prc5(2) - term2*yr 7717 tiyz = ci*term3 - psr5*diy*zr + diz*term4 + dir*term5 7718 & + 2.0d0*psr5*qiyz - 2.0d0*psr7*zr*qiy 7719 & + 2.0d0*qiz*term7 + qir*term6 7720 tkyz = ck*term3 + psr5*dky*zr - dkz*term4 - dkr*term5 7721 & + 2.0d0*psr5*qkyz - 2.0d0*psr7*zr*qky 7722 & + 2.0d0*qkz*term7 + qkr*term6 7723 depx = tixx*ukx + tixy*uky + tixz*ukz 7724 & - tkxx*uix - tkxy*uiy - tkxz*uiz 7725 depy = tixy*ukx + tiyy*uky + tiyz*ukz 7726 & - tkxy*uix - tkyy*uiy - tkyz*uiz 7727 depz = tixz*ukx + tiyz*uky + tizz*ukz 7728 & - tkxz*uix - tkyz*uiy - tkzz*uiz 7729 frcx = frcx + depx 7730 frcy = frcy + depy 7731 frcz = frcz + depz 7732c 7733c get the field gradient for direct polarization force 7734c 7735 else if (use_chgpen) then 7736 term1i = rr3i - rr5i*xr*xr 7737 term1core = rr3core - rr5core*xr*xr 7738 term2i = 2.0d0*rr5i*xr 7739 term3i = rr7i*xr*xr - rr5i 7740 term4i = 2.0d0*rr5i 7741 term5i = 5.0d0*rr7i*xr 7742 term6i = rr9i*xr*xr 7743 term1k = rr3k - rr5k*xr*xr 7744 term2k = 2.0d0*rr5k*xr 7745 term3k = rr7k*xr*xr - rr5k 7746 term4k = 2.0d0*rr5k 7747 term5k = 5.0d0*rr7k*xr 7748 term6k = rr9k*xr*xr 7749 tixx = vali*term1i + corei*term1core 7750 & + dix*term2i - dir*term3i 7751 & - qixx*term4i + qix*term5i - qir*term6i 7752 & + (qiy*yr+qiz*zr)*rr7i 7753 tkxx = valk*term1k + corek*term1core 7754 & - dkx*term2k + dkr*term3k 7755 & - qkxx*term4k + qkx*term5k - qkr*term6k 7756 & + (qky*yr+qkz*zr)*rr7k 7757 term1i = rr3i - rr5i*yr*yr 7758 term1core = rr3core - rr5core*yr*yr 7759 term2i = 2.0d0*rr5i*yr 7760 term3i = rr7i*yr*yr - rr5i 7761 term4i = 2.0d0*rr5i 7762 term5i = 5.0d0*rr7i*yr 7763 term6i = rr9i*yr*yr 7764 term1k = rr3k - rr5k*yr*yr 7765 term2k = 2.0d0*rr5k*yr 7766 term3k = rr7k*yr*yr - rr5k 7767 term4k = 2.0d0*rr5k 7768 term5k = 5.0d0*rr7k*yr 7769 term6k = rr9k*yr*yr 7770 tiyy = vali*term1i + corei*term1core 7771 & + diy*term2i - dir*term3i 7772 & - qiyy*term4i + qiy*term5i - qir*term6i 7773 & + (qix*xr+qiz*zr)*rr7i 7774 tkyy = valk*term1k + corek*term1core 7775 & - dky*term2k + dkr*term3k 7776 & - qkyy*term4k + qky*term5k - qkr*term6k 7777 & + (qkx*xr+qkz*zr)*rr7k 7778 term1i = rr3i - rr5i*zr*zr 7779 term1core = rr3core - rr5core*zr*zr 7780 term2i = 2.0d0*rr5i*zr 7781 term3i = rr7i*zr*zr - rr5i 7782 term4i = 2.0d0*rr5i 7783 term5i = 5.0d0*rr7i*zr 7784 term6i = rr9i*zr*zr 7785 term1k = rr3k - rr5k*zr*zr 7786 term2k = 2.0d0*rr5k*zr 7787 term3k = rr7k*zr*zr - rr5k 7788 term4k = 2.0d0*rr5k 7789 term5k = 5.0d0*rr7k*zr 7790 term6k = rr9k*zr*zr 7791 tizz = vali*term1i + corei*term1core 7792 & + diz*term2i - dir*term3i 7793 & - qizz*term4i + qiz*term5i - qir*term6i 7794 & + (qix*xr+qiy*yr)*rr7i 7795 tkzz = valk*term1k + corek*term1core 7796 & - dkz*term2k + dkr*term3k 7797 & - qkzz*term4k + qkz*term5k - qkr*term6k 7798 & + (qkx*xr+qky*yr)*rr7k 7799 term2i = rr5i*xr 7800 term1i = yr * term2i 7801 term1core = rr5core*xr*yr 7802 term3i = rr5i*yr 7803 term4i = yr * (rr7i*xr) 7804 term5i = 2.0d0*rr5i 7805 term6i = 2.0d0*rr7i*xr 7806 term7i = 2.0d0*rr7i*yr 7807 term8i = yr*rr9i*xr 7808 term2k = rr5k*xr 7809 term1k = yr * term2k 7810 term3k = rr5k*yr 7811 term4k = yr * (rr7k*xr) 7812 term5k = 2.0d0*rr5k 7813 term6k = 2.0d0*rr7k*xr 7814 term7k = 2.0d0*rr7k*yr 7815 term8k = yr*rr9k*xr 7816 tixy = -vali*term1i - corei*term1core 7817 & + diy*term2i + dix*term3i 7818 & - dir*term4i - qixy*term5i + qiy*term6i 7819 & + qix*term7i - qir*term8i 7820 tkxy = -valk*term1k - corek*term1core 7821 & - dky*term2k - dkx*term3k 7822 & + dkr*term4k - qkxy*term5k + qky*term6k 7823 & + qkx*term7k - qkr*term8k 7824 term2i = rr5i*xr 7825 term1i = zr * term2i 7826 term1core = rr5core*xr*zr 7827 term3i = rr5i*zr 7828 term4i = zr * (rr7i*xr) 7829 term5i = 2.0d0*rr5i 7830 term6i = 2.0d0*rr7i*xr 7831 term7i = 2.0d0*rr7i*zr 7832 term8i = zr*rr9i*xr 7833 term2k = rr5k*xr 7834 term1k = zr * term2k 7835 term3k = rr5k*zr 7836 term4k = zr * (rr7k*xr) 7837 term5k = 2.0d0*rr5k 7838 term6k = 2.0d0*rr7k*xr 7839 term7k = 2.0d0*rr7k*zr 7840 term8k = zr*rr9k*xr 7841 tixz = -vali*term1i - corei*term1core 7842 & + diz*term2i + dix*term3i 7843 & - dir*term4i - qixz*term5i + qiz*term6i 7844 & + qix*term7i - qir*term8i 7845 tkxz = -valk*term1k - corek*term1core 7846 & - dkz*term2k - dkx*term3k 7847 & + dkr*term4k - qkxz*term5k + qkz*term6k 7848 & + qkx*term7k - qkr*term8k 7849 term2i = rr5i*yr 7850 term1i = zr * term2i 7851 term1core = rr5core*yr*zr 7852 term3i = rr5i*zr 7853 term4i = zr * (rr7i*yr) 7854 term5i = 2.0d0*rr5i 7855 term6i = 2.0d0*rr7i*yr 7856 term7i = 2.0d0*rr7i*zr 7857 term8i = zr*rr9i*yr 7858 term2k = rr5k*yr 7859 term1k = zr * term2k 7860 term3k = rr5k*zr 7861 term4k = zr * (rr7k*yr) 7862 term5k = 2.0d0*rr5k 7863 term6k = 2.0d0*rr7k*yr 7864 term7k = 2.0d0*rr7k*zr 7865 term8k = zr*rr9k*yr 7866 tiyz = -vali*term1i - corei*term1core 7867 & + diz*term2i + diy*term3i 7868 & - dir*term4i - qiyz*term5i + qiz*term6i 7869 & + qiy*term7i - qir*term8i 7870 tkyz = -valk*term1k - corek*term1core 7871 & - dkz*term2k - dky*term3k 7872 & + dkr*term4k - qkyz*term5k + qkz*term6k 7873 & + qky*term7k - qkr*term8k 7874 depx = tixx*ukx + tixy*uky + tixz*ukz 7875 & - tkxx*uix - tkxy*uiy - tkxz*uiz 7876 depy = tixy*ukx + tiyy*uky + tiyz*ukz 7877 & - tkxy*uix - tkyy*uiy - tkyz*uiz 7878 depz = tixz*ukx + tiyz*uky + tizz*ukz 7879 & - tkxz*uix - tkyz*uiy - tkzz*uiz 7880 frcx = -2.0d0 * depx 7881 frcy = -2.0d0 * depy 7882 frcz = -2.0d0 * depz 7883 end if 7884c 7885c reset Thole values if alternate direct damping was used 7886c 7887 if (use_dirdamp) then 7888 sc3 = 1.0d0 7889 sc5 = 1.0d0 7890 do j = 1, 3 7891 rc3(j) = 0.0d0 7892 rc5(j) = 0.0d0 7893 end do 7894 damp = pdi * pdamp(kk) 7895 if (damp .ne. 0.0d0) then 7896 pgamma = min(pti,thole(kk)) 7897 damp = pgamma * (r/damp)**3 7898 if (damp .lt. 50.0d0) then 7899 expdamp = exp(-damp) 7900 sc3 = 1.0d0 - expdamp 7901 sc5 = 1.0d0 - expdamp*(1.0d0+damp) 7902 temp3 = 3.0d0 * damp * expdamp / r2 7903 temp5 = damp 7904 rc3(1) = xr * temp3 7905 rc3(2) = yr * temp3 7906 rc3(3) = zr * temp3 7907 rc5(1) = rc3(1) * temp5 7908 rc5(2) = rc3(2) * temp5 7909 rc5(3) = rc3(3) * temp5 7910 end if 7911 end if 7912 usc3 = 1.0d0 - sc3*uscale(k) 7913 usc5 = 1.0d0 - sc5*uscale(k) 7914 usr3 = dmpe(3) - usc3*rr3 7915 usr5 = dmpe(5) - usc5*rr5 7916 do j = 1, 3 7917 urc3(j) = rc3(j) * uscale(k) 7918 urc5(j) = rc5(j) * uscale(k) 7919 end do 7920 end if 7921c 7922c get the dtau/dr terms used for mutual polarization force 7923c 7924 if (poltyp.eq.'MUTUAL' .and. use_thole) then 7925 term1 = dmpe(5) - usc3*rr5 7926 term2 = dmpe(7) - usc5*rr7 7927 term3 = usr5 + term1 7928 term4 = rr3 * uscale(k) 7929 term5 = -xr*term3 + rc3(1)*term4 7930 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 7931 tixx = uix*term5 + uir*term6 7932 tkxx = ukx*term5 + ukr*term6 7933 term5 = -yr*term3 + rc3(2)*term4 7934 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 7935 tiyy = uiy*term5 + uir*term6 7936 tkyy = uky*term5 + ukr*term6 7937 term5 = -zr*term3 + rc3(3)*term4 7938 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 7939 tizz = uiz*term5 + uir*term6 7940 tkzz = ukz*term5 + ukr*term6 7941 term4 = -usr5 * yr 7942 term5 = -xr*term1 + rr3*urc3(1) 7943 term6 = xr*yr*term2 - rr5*yr*urc5(1) 7944 tixy = uix*term4 + uiy*term5 + uir*term6 7945 tkxy = ukx*term4 + uky*term5 + ukr*term6 7946 term4 = -usr5 * zr 7947 term6 = xr*zr*term2 - rr5*zr*urc5(1) 7948 tixz = uix*term4 + uiz*term5 + uir*term6 7949 tkxz = ukx*term4 + ukz*term5 + ukr*term6 7950 term5 = -yr*term1 + rr3*urc3(2) 7951 term6 = yr*zr*term2 - rr5*zr*urc5(2) 7952 tiyz = uiy*term4 + uiz*term5 + uir*term6 7953 tkyz = uky*term4 + ukz*term5 + ukr*term6 7954 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 7955 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 7956 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 7957 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 7958 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 7959 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 7960 frcx = frcx + depx 7961 frcy = frcy + depy 7962 frcz = frcz + depz 7963c 7964c get the dtau/dr terms used for mutual polarization force 7965c 7966 else if (poltyp.eq.'MUTUAL' .and. use_chgpen) then 7967 term1 = 2.0d0 * rr5ik 7968 term2 = term1*xr 7969 term3 = rr5ik - rr7ik*xr*xr 7970 tixx = uix*term2 + uir*term3 7971 tkxx = ukx*term2 + ukr*term3 7972 term2 = term1*yr 7973 term3 = rr5ik - rr7ik*yr*yr 7974 tiyy = uiy*term2 + uir*term3 7975 tkyy = uky*term2 + ukr*term3 7976 term2 = term1*zr 7977 term3 = rr5ik - rr7ik*zr*zr 7978 tizz = uiz*term2 + uir*term3 7979 tkzz = ukz*term2 + ukr*term3 7980 term1 = rr5ik*yr 7981 term2 = rr5ik*xr 7982 term3 = yr * (rr7ik*xr) 7983 tixy = uix*term1 + uiy*term2 - uir*term3 7984 tkxy = ukx*term1 + uky*term2 - ukr*term3 7985 term1 = rr5ik * zr 7986 term3 = zr * (rr7ik*xr) 7987 tixz = uix*term1 + uiz*term2 - uir*term3 7988 tkxz = ukx*term1 + ukz*term2 - ukr*term3 7989 term2 = rr5ik*yr 7990 term3 = zr * (rr7ik*yr) 7991 tiyz = uiy*term1 + uiz*term2 - uir*term3 7992 tkyz = uky*term1 + ukz*term2 - ukr*term3 7993 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 7994 & + tkxx*uixp + tkxy*uiyp + tkxz*uizp 7995 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 7996 & + tkxy*uixp + tkyy*uiyp + tkyz*uizp 7997 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 7998 & + tkxz*uixp + tkyz*uiyp + tkzz*uizp 7999 frcx = frcx - depx 8000 frcy = frcy - depy 8001 frcz = frcz - depz 8002c 8003c get the dtau/dr terms used for OPT polarization force 8004c 8005 else if (poltyp.eq.'OPT' .and. use_thole) then 8006 do j = 0, optorder-1 8007 uirm = uopt(j,1,ii)*xr + uopt(j,2,ii)*yr 8008 & + uopt(j,3,ii)*zr 8009 do m = 0, optorder-j-1 8010 ukrm = uopt(m,1,kk)*xr + uopt(m,2,kk)*yr 8011 & + uopt(m,3,kk)*zr 8012 term1 = dmpe(5) - usc3*rr5 8013 term2 = dmpe(7) - usc5*rr7 8014 term3 = usr5 + term1 8015 term4 = rr3 * uscale(k) 8016 term5 = -xr*term3 + rc3(1)*term4 8017 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 8018 tixx = uopt(j,1,ii)*term5 + uirm*term6 8019 tkxx = uopt(m,1,kk)*term5 + ukrm*term6 8020 term5 = -yr*term3 + rc3(2)*term4 8021 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 8022 tiyy = uopt(j,2,ii)*term5 + uirm*term6 8023 tkyy = uopt(m,2,kk)*term5 + ukrm*term6 8024 term5 = -zr*term3 + rc3(3)*term4 8025 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 8026 tizz = uopt(j,3,ii)*term5 + uirm*term6 8027 tkzz = uopt(m,3,kk)*term5 + ukrm*term6 8028 term4 = -usr5 * yr 8029 term5 = -xr*term1 + rr3*urc3(1) 8030 term6 = xr*yr*term2 - rr5*yr*urc5(1) 8031 tixy = uopt(j,1,ii)*term4 + uopt(j,2,ii)*term5 8032 & + uirm*term6 8033 tkxy = uopt(m,1,kk)*term4 + uopt(m,2,kk)*term5 8034 & + ukrm*term6 8035 term4 = -usr5 * zr 8036 term6 = xr*zr*term2 - rr5*zr*urc5(1) 8037 tixz = uopt(j,1,ii)*term4 + uopt(j,3,ii)*term5 8038 & + uirm*term6 8039 tkxz = uopt(m,1,kk)*term4 + uopt(m,3,kk)*term5 8040 & + ukrm*term6 8041 term5 = -yr*term1 + rr3*urc3(2) 8042 term6 = yr*zr*term2 - rr5*zr*urc5(2) 8043 tiyz = uopt(j,2,ii)*term4 + uopt(j,3,ii)*term5 8044 & + uirm*term6 8045 tkyz = uopt(m,2,kk)*term4 + uopt(m,3,kk)*term5 8046 & + ukrm*term6 8047 depx = tixx*uoptp(m,1,kk) + tkxx*uoptp(j,1,ii) 8048 & + tixy*uoptp(m,2,kk) + tkxy*uoptp(j,2,ii) 8049 & + tixz*uoptp(m,3,kk) + tkxz*uoptp(j,3,ii) 8050 depy = tixy*uoptp(m,1,kk) + tkxy*uoptp(j,1,ii) 8051 & + tiyy*uoptp(m,2,kk) + tkyy*uoptp(j,2,ii) 8052 & + tiyz*uoptp(m,3,kk) + tkyz*uoptp(j,3,ii) 8053 depz = tixz*uoptp(m,1,kk) + tkxz*uoptp(j,1,ii) 8054 & + tiyz*uoptp(m,2,kk) + tkyz*uoptp(j,2,ii) 8055 & + tizz*uoptp(m,3,kk) + tkzz*uoptp(j,3,ii) 8056 frcx = frcx + copm(j+m+1)*depx 8057 frcy = frcy + copm(j+m+1)*depy 8058 frcz = frcz + copm(j+m+1)*depz 8059 end do 8060 end do 8061c 8062c get the dtau/dr terms used for OPT polarization force 8063c 8064 else if (poltyp.eq.'OPT' .and. use_chgpen) then 8065 do j = 0, optorder-1 8066 uirm = uopt(j,1,i)*xr + uopt(j,2,i)*yr 8067 & + uopt(j,3,i)*zr 8068 do m = 0, optorder-j-1 8069 ukrm = uopt(m,1,k)*xr + uopt(m,2,k)*yr 8070 & + uopt(m,3,k)*zr 8071 term1 = 2.0d0 * rr5ik 8072 term2 = term1*xr 8073 term3 = rr5ik - rr7ik*xr*xr 8074 tixx = uopt(j,1,i)*term2 + uirm*term3 8075 tkxx = uopt(m,1,k)*term2 + ukrm*term3 8076 term2 = term1*yr 8077 term3 = rr5ik - rr7ik*yr*yr 8078 tiyy = uopt(j,2,i)*term2 + uirm*term3 8079 tkyy = uopt(m,2,k)*term2 + ukrm*term3 8080 term2 = term1*zr 8081 term3 = rr5ik - rr7ik*zr*zr 8082 tizz = uopt(j,3,i)*term2 + uirm*term3 8083 tkzz = uopt(m,3,k)*term2 + ukrm*term3 8084 term1 = rr5ik*yr 8085 term2 = rr5ik*xr 8086 term3 = yr * (rr7ik*xr) 8087 tixy = uopt(j,1,i)*term1 + uopt(j,2,i)*term2 8088 & - uirm*term3 8089 tkxy = uopt(m,1,k)*term1 + uopt(m,2,k)*term2 8090 & - ukrm*term3 8091 term1 = rr5ik * zr 8092 term3 = zr * (rr7ik*xr) 8093 tixz = uopt(j,1,i)*term1 + uopt(j,3,i)*term2 8094 & - uirm*term3 8095 tkxz = uopt(m,1,k)*term1 + uopt(m,3,k)*term2 8096 & - ukrm*term3 8097 term2 = rr5ik*yr 8098 term3 = zr * (rr7ik*yr) 8099 tiyz = uopt(j,2,i)*term1 + uopt(j,3,i)*term2 8100 & - uirm*term3 8101 tkyz = uopt(m,2,k)*term1 + uopt(m,3,k)*term2 8102 & - ukrm*term3 8103 depx = tixx*uoptp(m,1,k) + tkxx*uoptp(j,1,i) 8104 & + tixy*uoptp(m,2,k) + tkxy*uoptp(j,2,i) 8105 & + tixz*uoptp(m,3,k) + tkxz*uoptp(j,3,i) 8106 depy = tixy*uoptp(m,1,k) + tkxy*uoptp(j,1,i) 8107 & + tiyy*uoptp(m,2,k) + tkyy*uoptp(j,2,i) 8108 & + tiyz*uoptp(m,3,k) + tkyz*uoptp(j,3,i) 8109 depz = tixz*uoptp(m,1,k) + tkxz*uoptp(j,1,i) 8110 & + tiyz*uoptp(m,2,k) + tkyz*uoptp(j,2,i) 8111 & + tizz*uoptp(m,3,k) + tkzz*uoptp(j,3,i) 8112 frcx = frcx - copm(j+m+1)*depx 8113 frcy = frcy - copm(j+m+1)*depy 8114 frcz = frcz - copm(j+m+1)*depz 8115 end do 8116 end do 8117c 8118c get the dtau/dr terms used for TCG polarization force 8119c 8120 else if (poltyp.eq.'TCG' .and. use_thole) then 8121 do j = 1, tcgnab 8122 ukx = ubd(1,kk,j) 8123 uky = ubd(2,kk,j) 8124 ukz = ubd(3,kk,j) 8125 ukxp = ubp(1,kk,j) 8126 ukyp = ubp(2,kk,j) 8127 ukzp = ubp(3,kk,j) 8128 uirt = uax(j)*xr + uay(j)*yr + uaz(j)*zr 8129 ukrt = ukx*xr + uky*yr + ukz*zr 8130 term1 = dmpe(5) - usc3*rr5 8131 term2 = dmpe(7) - usc5*rr7 8132 term3 = usr5 + term1 8133 term4 = rr3 * uscale(k) 8134 term5 = -xr*term3 + rc3(1)*term4 8135 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 8136 tixx = uax(j)*term5 + uirt*term6 8137 tkxx = ukx*term5 + ukrt*term6 8138 term5 = -yr*term3 + rc3(2)*term4 8139 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 8140 tiyy = uay(j)*term5 + uirt*term6 8141 tkyy = uky*term5 + ukrt*term6 8142 term5 = -zr*term3 + rc3(3)*term4 8143 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 8144 tizz = uaz(j)*term5 + uirt*term6 8145 tkzz = ukz*term5 + ukrt*term6 8146 term4 = -usr5 * yr 8147 term5 = -xr*term1 + rr3*urc3(1) 8148 term6 = xr*yr*term2 - rr5*yr*urc5(1) 8149 tixy = uax(j)*term4 + uay(j)*term5 + uirt*term6 8150 tkxy = ukx*term4 + uky*term5 + ukrt*term6 8151 term4 = -usr5 * zr 8152 term6 = xr*zr*term2 - rr5*zr*urc5(1) 8153 tixz = uax(j)*term4 + uaz(j)*term5 + uirt*term6 8154 tkxz = ukx*term4 + ukz*term5 + ukrt*term6 8155 term5 = -yr*term1 + rr3*urc3(2) 8156 term6 = yr*zr*term2 - rr5*zr*urc5(2) 8157 tiyz = uay(j)*term4 + uaz(j)*term5 + uirt*term6 8158 tkyz = uky*term4 + ukz*term5 + ukrt*term6 8159 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 8160 & + tkxx*uaxp(j) + tkxy*uayp(j) 8161 & + tkxz*uazp(j) 8162 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 8163 & + tkxy*uaxp(j) + tkyy*uayp(j) 8164 & + tkyz*uazp(j) 8165 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 8166 & + tkxz*uaxp(j) + tkyz*uayp(j) 8167 & + tkzz*uazp(j) 8168 frcx = frcx + depx 8169 frcy = frcy + depy 8170 frcz = frcz + depz 8171 ukx = uad(1,kk,j) 8172 uky = uad(2,kk,j) 8173 ukz = uad(3,kk,j) 8174 ukxp = uap(1,kk,j) 8175 ukyp = uap(2,kk,j) 8176 ukzp = uap(3,kk,j) 8177 uirt = ubx(j)*xr + uby(j)*yr + ubz(j)*zr 8178 ukrt = ukx*xr + uky*yr + ukz*zr 8179 term1 = dmpe(5) - usc3*rr5 8180 term2 = dmpe(7) - usc5*rr7 8181 term3 = usr5 + term1 8182 term4 = rr3 * uscale(k) 8183 term5 = -xr*term3 + rc3(1)*term4 8184 term6 = -usr5 + xr*xr*term2 - rr5*xr*urc5(1) 8185 tixx = ubx(j)*term5 + uirt*term6 8186 tkxx = ukx*term5 + ukrt*term6 8187 term5 = -yr*term3 + rc3(2)*term4 8188 term6 = -usr5 + yr*yr*term2 - rr5*yr*urc5(2) 8189 tiyy = uby(j)*term5 + uirt*term6 8190 tkyy = uky*term5 + ukrt*term6 8191 term5 = -zr*term3 + rc3(3)*term4 8192 term6 = -usr5 + zr*zr*term2 - rr5*zr*urc5(3) 8193 tizz = ubz(j)*term5 + uirt*term6 8194 tkzz = ukz*term5 + ukrt*term6 8195 term4 = -usr5 * yr 8196 term5 = -xr*term1 + rr3*urc3(1) 8197 term6 = xr*yr*term2 - rr5*yr*urc5(1) 8198 tixy = ubx(j)*term4 + uby(j)*term5 + uirt*term6 8199 tkxy = ukx*term4 + uky*term5 + ukrt*term6 8200 term4 = -usr5 * zr 8201 term6 = xr*zr*term2 - rr5*zr*urc5(1) 8202 tixz = ubx(j)*term4 + ubz(j)*term5 + uirt*term6 8203 tkxz = ukx*term4 + ukz*term5 + ukrt*term6 8204 term5 = -yr*term1 + rr3*urc3(2) 8205 term6 = yr*zr*term2 - rr5*zr*urc5(2) 8206 tiyz = uby(j)*term4 + ubz(j)*term5 + uirt*term6 8207 tkyz = uky*term4 + ukz*term5 + ukrt*term6 8208 depx = tixx*ukxp + tixy*ukyp + tixz*ukzp 8209 & + tkxx*ubxp(j) + tkxy*ubyp(j) 8210 & + tkxz*ubzp(j) 8211 depy = tixy*ukxp + tiyy*ukyp + tiyz*ukzp 8212 & + tkxy*ubxp(j) + tkyy*ubyp(j) 8213 & + tkyz*ubzp(j) 8214 depz = tixz*ukxp + tiyz*ukyp + tizz*ukzp 8215 & + tkxz*ubxp(j) + tkyz*ubyp(j) 8216 & + tkzz*ubzp(j) 8217 frcx = frcx + depx 8218 frcy = frcy + depy 8219 frcz = frcz + depz 8220 end do 8221 end if 8222c 8223c increment force-based gradient on the interaction sites 8224c 8225 dep(1,i) = dep(1,i) - frcx 8226 dep(2,i) = dep(2,i) - frcy 8227 dep(3,i) = dep(3,i) - frcz 8228 dep(1,k) = dep(1,k) + frcx 8229 dep(2,k) = dep(2,k) + frcy 8230 dep(3,k) = dep(3,k) + frcz 8231c 8232c increment the virial due to pairwise Cartesian forces 8233c 8234 vxx = xr * frcx 8235 vxy = 0.5d0 * (yr*frcx+xr*frcy) 8236 vxz = 0.5d0 * (zr*frcx+xr*frcz) 8237 vyy = yr * frcy 8238 vyz = 0.5d0 * (zr*frcy+yr*frcz) 8239 vzz = zr * frcz 8240 vir(1,1) = vir(1,1) + vxx 8241 vir(2,1) = vir(2,1) + vxy 8242 vir(3,1) = vir(3,1) + vxz 8243 vir(1,2) = vir(1,2) + vxy 8244 vir(2,2) = vir(2,2) + vyy 8245 vir(3,2) = vir(3,2) + vyz 8246 vir(1,3) = vir(1,3) + vxz 8247 vir(2,3) = vir(2,3) + vyz 8248 vir(3,3) = vir(3,3) + vzz 8249 end if 8250 end do 8251c 8252c reset exclusion coefficients for connected atoms 8253c 8254 if (dpequal) then 8255 do j = 1, n12(i) 8256 pscale(i12(j,i)) = 1.0d0 8257 dscale(i12(j,i)) = 1.0d0 8258 wscale(i12(j,i)) = 1.0d0 8259 end do 8260 do j = 1, n13(i) 8261 pscale(i13(j,i)) = 1.0d0 8262 dscale(i13(j,i)) = 1.0d0 8263 wscale(i13(j,i)) = 1.0d0 8264 end do 8265 do j = 1, n14(i) 8266 pscale(i14(j,i)) = 1.0d0 8267 dscale(i14(j,i)) = 1.0d0 8268 wscale(i14(j,i)) = 1.0d0 8269 end do 8270 do j = 1, n15(i) 8271 pscale(i15(j,i)) = 1.0d0 8272 dscale(i15(j,i)) = 1.0d0 8273 wscale(i15(j,i)) = 1.0d0 8274 end do 8275 do j = 1, np11(i) 8276 uscale(ip11(j,i)) = 1.0d0 8277 end do 8278 do j = 1, np12(i) 8279 uscale(ip12(j,i)) = 1.0d0 8280 end do 8281 do j = 1, np13(i) 8282 uscale(ip13(j,i)) = 1.0d0 8283 end do 8284 do j = 1, np14(i) 8285 uscale(ip14(j,i)) = 1.0d0 8286 end do 8287 else 8288 do j = 1, n12(i) 8289 pscale(i12(j,i)) = 1.0d0 8290 wscale(i12(j,i)) = 1.0d0 8291 end do 8292 do j = 1, n13(i) 8293 pscale(i13(j,i)) = 1.0d0 8294 wscale(i13(j,i)) = 1.0d0 8295 end do 8296 do j = 1, n14(i) 8297 pscale(i14(j,i)) = 1.0d0 8298 wscale(i14(j,i)) = 1.0d0 8299 end do 8300 do j = 1, n15(i) 8301 pscale(i15(j,i)) = 1.0d0 8302 wscale(i15(j,i)) = 1.0d0 8303 end do 8304 do j = 1, np11(i) 8305 dscale(ip11(j,i)) = 1.0d0 8306 uscale(ip11(j,i)) = 1.0d0 8307 end do 8308 do j = 1, np12(i) 8309 dscale(ip12(j,i)) = 1.0d0 8310 uscale(ip12(j,i)) = 1.0d0 8311 end do 8312 do j = 1, np13(i) 8313 dscale(ip13(j,i)) = 1.0d0 8314 uscale(ip13(j,i)) = 1.0d0 8315 end do 8316 do j = 1, np14(i) 8317 dscale(ip14(j,i)) = 1.0d0 8318 uscale(ip14(j,i)) = 1.0d0 8319 end do 8320 end if 8321 end do 8322c 8323c OpenMP directives for the major loop structure 8324c 8325!$OMP END DO 8326!$OMP DO reduction(+:dep,vir) schedule(guided) 8327c 8328c torque is induced field and gradient cross permanent moments 8329c 8330 do ii = 1, npole 8331 i = ipole(ii) 8332 dix = rpole(2,ii) 8333 diy = rpole(3,ii) 8334 diz = rpole(4,ii) 8335 qixx = rpole(5,ii) 8336 qixy = rpole(6,ii) 8337 qixz = rpole(7,ii) 8338 qiyy = rpole(9,ii) 8339 qiyz = rpole(10,ii) 8340 qizz = rpole(13,ii) 8341 tep(1) = diz*ufld(2,i) - diy*ufld(3,i) 8342 & + qixz*dufld(2,i) - qixy*dufld(4,i) 8343 & + 2.0d0*qiyz*(dufld(3,i)-dufld(6,i)) 8344 & + (qizz-qiyy)*dufld(5,i) 8345 tep(2) = dix*ufld(3,i) - diz*ufld(1,i) 8346 & - qiyz*dufld(2,i) + qixy*dufld(5,i) 8347 & + 2.0d0*qixz*(dufld(6,i)-dufld(1,i)) 8348 & + (qixx-qizz)*dufld(4,i) 8349 tep(3) = diy*ufld(1,i) - dix*ufld(2,i) 8350 & + qiyz*dufld(4,i) - qixz*dufld(5,i) 8351 & + 2.0d0*qixy*(dufld(1,i)-dufld(3,i)) 8352 & + (qiyy-qixx)*dufld(2,i) 8353 call torque (ii,tep,fix,fiy,fiz,dep) 8354 iz = zaxis(ii) 8355 ix = xaxis(ii) 8356 iy = abs(yaxis(ii)) 8357 if (iz .eq. 0) iz = i 8358 if (ix .eq. 0) ix = i 8359 if (iy .eq. 0) iy = i 8360 xiz = x(iz) - x(i) 8361 yiz = y(iz) - y(i) 8362 ziz = z(iz) - z(i) 8363 xix = x(ix) - x(i) 8364 yix = y(ix) - y(i) 8365 zix = z(ix) - z(i) 8366 xiy = x(iy) - x(i) 8367 yiy = y(iy) - y(i) 8368 ziy = z(iy) - z(i) 8369 vxx = xix*fix(1) + xiy*fiy(1) + xiz*fiz(1) 8370 vxy = 0.5d0 * (yix*fix(1) + yiy*fiy(1) + yiz*fiz(1) 8371 & + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2)) 8372 vxz = 0.5d0 * (zix*fix(1) + ziy*fiy(1) + ziz*fiz(1) 8373 & + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 8374 vyy = yix*fix(2) + yiy*fiy(2) + yiz*fiz(2) 8375 vyz = 0.5d0 * (zix*fix(2) + ziy*fiy(2) + ziz*fiz(2) 8376 & + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3)) 8377 vzz = zix*fix(3) + ziy*fiy(3) + ziz*fiz(3) 8378 vir(1,1) = vir(1,1) + vxx 8379 vir(2,1) = vir(2,1) + vxy 8380 vir(3,1) = vir(3,1) + vxz 8381 vir(1,2) = vir(1,2) + vxy 8382 vir(2,2) = vir(2,2) + vyy 8383 vir(3,2) = vir(3,2) + vyz 8384 vir(1,3) = vir(1,3) + vxz 8385 vir(2,3) = vir(2,3) + vyz 8386 vir(3,3) = vir(3,3) + vzz 8387 end do 8388c 8389c OpenMP directives for the major loop structure 8390c 8391!$OMP END DO 8392c 8393c modify the gradient and virial for charge flux 8394c 8395 if (use_chgflx) then 8396 call dcflux (pot,decfx,decfy,decfz) 8397!$OMP DO reduction(+:dep,vir) schedule(guided) 8398 do ii = 1, npole 8399 i = ipole(ii) 8400 xi = x(i) 8401 yi = y(i) 8402 zi = z(i) 8403 frcx = decfx(i) 8404 frcy = decfy(i) 8405 frcz = decfz(i) 8406 dep(1,i) = dep(1,i) + frcx 8407 dep(2,i) = dep(2,i) + frcy 8408 dep(3,i) = dep(3,i) + frcz 8409 vxx = xi * frcx 8410 vxy = yi * frcx 8411 vxz = zi * frcx 8412 vyy = yi * frcy 8413 vyz = zi * frcy 8414 vzz = zi * frcz 8415 vir(1,1) = vir(1,1) + vxx 8416 vir(2,1) = vir(2,1) + vxy 8417 vir(3,1) = vir(3,1) + vxz 8418 vir(1,2) = vir(1,2) + vxy 8419 vir(2,2) = vir(2,2) + vyy 8420 vir(3,2) = vir(3,2) + vyz 8421 vir(1,3) = vir(1,3) + vxz 8422 vir(2,3) = vir(2,3) + vyz 8423 vir(3,3) = vir(3,3) + vzz 8424 end do 8425!$OMP END DO 8426 end if 8427c 8428c OpenMP directives for the major loop structure 8429c 8430!$OMP END PARALLEL 8431c 8432c perform deallocation of some local arrays 8433c 8434 deallocate (pscale) 8435 deallocate (dscale) 8436 deallocate (uscale) 8437 deallocate (wscale) 8438 deallocate (ufld) 8439 deallocate (dufld) 8440 deallocate (pot) 8441 deallocate (decfx) 8442 deallocate (decfy) 8443 deallocate (decfz) 8444 return 8445 end 8446c 8447c 8448c ################################################################ 8449c ## ## 8450c ## subroutine epolar1e -- single-loop polarization energy ## 8451c ## ## 8452c ################################################################ 8453c 8454c 8455c "epreal1e" calculates the induced dipole polarization energy 8456c from the induced dipoles times the electric field 8457c 8458c 8459 subroutine epolar1e 8460 use atoms 8461 use boxes 8462 use chgpot 8463 use energi 8464 use ewald 8465 use limits 8466 use math 8467 use mpole 8468 use polar 8469 use polpot 8470 implicit none 8471 integer i,j,ii 8472 real*8 e,f,fi,term 8473 real*8 xd,yd,zd 8474 real*8 xu,yu,zu 8475 real*8 dix,diy,diz 8476 real*8 uix,uiy,uiz 8477c 8478c 8479c set the energy unit conversion factor 8480c 8481 f = -0.5d0 * electric / dielec 8482c 8483c OpenMP directives for the major loop structure 8484c 8485!$OMP PARALLEL default(shared) private(ii,j,fi,e) 8486!$OMP DO reduction(+:ep) schedule(guided) 8487c 8488c get polarization energy via induced dipoles times field 8489c 8490 do ii = 1, npole 8491 if (douind(ipole(ii))) then 8492 fi = f / polarity(ii) 8493 e = 0.0d0 8494 do j = 1, 3 8495 e = e + fi*uind(j,ii)*udirp(j,ii) 8496 end do 8497 ep = ep + e 8498 end if 8499 end do 8500c 8501c OpenMP directives for the major loop structure 8502c 8503!$OMP END DO 8504!$OMP END PARALLEL 8505c 8506c compute the cell dipole boundary correction term 8507c 8508 if (use_ewald) then 8509 if (boundary .eq. 'VACUUM') then 8510 f = electric / dielec 8511 xd = 0.0d0 8512 yd = 0.0d0 8513 zd = 0.0d0 8514 xu = 0.0d0 8515 yu = 0.0d0 8516 zu = 0.0d0 8517 do ii = 1, npole 8518 i = ipole(ii) 8519 dix = rpole(2,ii) 8520 diy = rpole(3,ii) 8521 diz = rpole(4,ii) 8522 uix = uind(1,ii) 8523 uiy = uind(2,ii) 8524 uiz = uind(3,ii) 8525 xd = xd + dix + rpole(1,ii)*x(i) 8526 yd = yd + diy + rpole(1,ii)*y(i) 8527 zd = zd + diz + rpole(1,ii)*z(i) 8528 xu = xu + uix 8529 yu = yu + uiy 8530 zu = zu + uiz 8531 end do 8532 term = (2.0d0/3.0d0) * f * (pi/volbox) 8533 e = term * (xd*xu+yd*yu+zd*zu) 8534 ep = ep + e 8535 end if 8536 end if 8537 return 8538 end 8539c 8540c 8541c ################################################################### 8542c ## ## 8543c ## subroutine eprecip1 -- PME recip polarize energy & derivs ## 8544c ## ## 8545c ################################################################### 8546c 8547c 8548c "eprecip1" evaluates the reciprocal space portion of the particle 8549c mesh Ewald summation energy and gradient due to dipole polarization 8550c 8551c literature reference: 8552c 8553c C. Sagui, L. G. Pedersen and T. A. Darden, "Towards an Accurate 8554c Representation of Electrostatics in Classical Force Fields: 8555c Efficient Implementation of Multipolar Interactions in 8556c Biomolecular Simulations", Journal of Chemical Physics, 120, 8557c 73-87 (2004) 8558c 8559c modifications for nonperiodic systems suggested by Tom Darden 8560c during May 2007 8561c 8562c 8563 subroutine eprecip1 8564 use atoms 8565 use bound 8566 use boxes 8567 use chgpot 8568 use deriv 8569 use ewald 8570 use math 8571 use mpole 8572 use mrecip 8573 use pme 8574 use polar 8575 use polopt 8576 use polpot 8577 use poltcg 8578 use potent 8579 use virial 8580 implicit none 8581 integer i,j,k,m,ii 8582 integer j1,j2,j3 8583 integer k1,k2,k3 8584 integer m1,m2,m3 8585 integer ix,iy,iz 8586 integer ntot,nff 8587 integer nf1,nf2,nf3 8588 integer deriv1(10) 8589 integer deriv2(10) 8590 integer deriv3(10) 8591 real*8 eterm,f 8592 real*8 r1,r2,r3 8593 real*8 h1,h2,h3 8594 real*8 f1,f2,f3 8595 real*8 xi,yi,zi 8596 real*8 xix,yix,zix 8597 real*8 xiy,yiy,ziy 8598 real*8 xiz,yiz,ziz 8599 real*8 vxx,vyy,vzz 8600 real*8 vxy,vxz,vyz 8601 real*8 frcx,frcy,frcz 8602 real*8 volterm,denom 8603 real*8 hsq,expterm 8604 real*8 term,pterm 8605 real*8 vterm,struc2 8606 real*8 tep(3),fix(3) 8607 real*8 fiy(3),fiz(3) 8608 real*8 cphid(4),cphip(4) 8609 real*8 a(3,3),ftc(10,10) 8610 real*8, allocatable :: fuind(:,:) 8611 real*8, allocatable :: fuinp(:,:) 8612 real*8, allocatable :: fphid(:,:) 8613 real*8, allocatable :: fphip(:,:) 8614 real*8, allocatable :: fphidp(:,:) 8615 real*8, allocatable :: cphidp(:,:) 8616 real*8, allocatable :: qgrip(:,:,:,:) 8617 real*8, allocatable :: pot(:) 8618 real*8, allocatable :: decfx(:) 8619 real*8, allocatable :: decfy(:) 8620 real*8, allocatable :: decfz(:) 8621c 8622c indices into the electrostatic field array 8623c 8624 data deriv1 / 2, 5, 8, 9, 11, 16, 18, 14, 15, 20 / 8625 data deriv2 / 3, 8, 6, 10, 14, 12, 19, 16, 20, 17 / 8626 data deriv3 / 4, 9, 10, 7, 15, 17, 13, 20, 18, 19 / 8627c 8628c 8629c return if the Ewald coefficient is zero 8630c 8631 if (aewald .lt. 1.0d-6) return 8632 f = electric / dielec 8633c 8634c initialize variables required for the scalar summation 8635c 8636 pterm = (pi/aewald)**2 8637 volterm = pi * volbox 8638 nf1 = (nfft1+1) / 2 8639 nf2 = (nfft2+1) / 2 8640 nf3 = (nfft3+1) / 2 8641 nff = nfft1 * nfft2 8642 ntot = nff * nfft3 8643c 8644c remove scalar sum virial from prior multipole FFT 8645c 8646 if (use_mpole .and. aewald.eq.aeewald) then 8647 vxx = -vmxx 8648 vxy = -vmxy 8649 vxz = -vmxz 8650 vyy = -vmyy 8651 vyz = -vmyz 8652 vzz = -vmzz 8653c 8654c perform dynamic allocation of some global arrays 8655c 8656 else 8657 if (allocated(cmp)) then 8658 if (size(cmp) .lt. 10*npole) deallocate (cmp) 8659 end if 8660 if (allocated(fmp)) then 8661 if (size(fmp) .lt. 10*npole) deallocate (fmp) 8662 end if 8663 if (allocated(cphi)) then 8664 if (size(cphi) .lt. 10*npole) deallocate (cphi) 8665 end if 8666 if (allocated(fphi)) then 8667 if (size(fphi) .lt. 20*npole) deallocate (fphi) 8668 end if 8669 if (.not. allocated(cmp)) allocate (cmp(10,npole)) 8670 if (.not. allocated(fmp)) allocate (fmp(10,npole)) 8671 if (.not. allocated(cphi)) allocate (cphi(10,npole)) 8672 if (.not. allocated(fphi)) allocate (fphi(20,npole)) 8673c 8674c perform dynamic allocation of some global arrays 8675c 8676 ntot = nfft1 * nfft2 * nfft3 8677 if (allocated(qgrid)) then 8678 if (size(qgrid) .ne. 2*ntot) call fftclose 8679 end if 8680 if (allocated(qfac)) then 8681 if (size(qfac) .ne. ntot) deallocate (qfac) 8682 end if 8683 if (.not. allocated(qgrid)) call fftsetup 8684 if (.not. allocated(qfac)) allocate (qfac(nfft1,nfft2,nfft3)) 8685c 8686c setup spatial decomposition and B-spline coefficients 8687c 8688 call getchunk 8689 call moduli 8690 call bspline_fill 8691 call table_fill 8692c 8693c assign only the permanent multipoles to the PME grid 8694c and perform the 3-D FFT forward transformation 8695c 8696 do i = 1, npole 8697 cmp(1,i) = rpole(1,i) 8698 cmp(2,i) = rpole(2,i) 8699 cmp(3,i) = rpole(3,i) 8700 cmp(4,i) = rpole(4,i) 8701 cmp(5,i) = rpole(5,i) 8702 cmp(6,i) = rpole(9,i) 8703 cmp(7,i) = rpole(13,i) 8704 cmp(8,i) = 2.0d0 * rpole(6,i) 8705 cmp(9,i) = 2.0d0 * rpole(7,i) 8706 cmp(10,i) = 2.0d0 * rpole(10,i) 8707 end do 8708 call cmp_to_fmp (cmp,fmp) 8709 call grid_mpole (fmp) 8710 call fftfront 8711c 8712c zero out the temporary virial accumulation variables 8713c 8714 vxx = 0.0d0 8715 vxy = 0.0d0 8716 vxz = 0.0d0 8717 vyy = 0.0d0 8718 vyz = 0.0d0 8719 vzz = 0.0d0 8720c 8721c make the scalar summation over reciprocal lattice 8722c 8723 qfac(1,1,1) = 0.0d0 8724 do i = 1, ntot-1 8725 k3 = i/nff + 1 8726 j = i - (k3-1)*nff 8727 k2 = j/nfft1 + 1 8728 k1 = j - (k2-1)*nfft1 + 1 8729 m1 = k1 - 1 8730 m2 = k2 - 1 8731 m3 = k3 - 1 8732 if (k1 .gt. nf1) m1 = m1 - nfft1 8733 if (k2 .gt. nf2) m2 = m2 - nfft2 8734 if (k3 .gt. nf3) m3 = m3 - nfft3 8735 r1 = dble(m1) 8736 r2 = dble(m2) 8737 r3 = dble(m3) 8738 h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3 8739 h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3 8740 h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3 8741 hsq = h1*h1 + h2*h2 + h3*h3 8742 term = -pterm * hsq 8743 expterm = 0.0d0 8744 if (term .gt. -50.0d0) then 8745 denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3) 8746 expterm = exp(term) / denom 8747 if (.not. use_bounds) then 8748 expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) 8749 else if (nonprism) then 8750 if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 8751 end if 8752 struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2 8753 eterm = 0.5d0 * f * expterm * struc2 8754 vterm = (2.0d0/hsq) * (1.0d0-term) * eterm 8755 vxx = vxx - h1*h1*vterm + eterm 8756 vxy = vxy - h1*h2*vterm 8757 vxz = vxz - h1*h3*vterm 8758 vyy = vyy - h2*h2*vterm + eterm 8759 vyz = vyz - h2*h3*vterm 8760 vzz = vzz - h3*h3*vterm + eterm 8761 end if 8762 qfac(k1,k2,k3) = expterm 8763 end do 8764c 8765c account for zeroth grid point for nonperiodic system 8766c 8767 if (.not. use_bounds) then 8768 expterm = 0.5d0 * pi / xbox 8769 qfac(1,1,1) = expterm 8770 end if 8771c 8772c complete the transformation of the PME grid 8773c 8774 do k = 1, nfft3 8775 do j = 1, nfft2 8776 do i = 1, nfft1 8777 term = qfac(i,j,k) 8778 qgrid(1,i,j,k) = term * qgrid(1,i,j,k) 8779 qgrid(2,i,j,k) = term * qgrid(2,i,j,k) 8780 end do 8781 end do 8782 end do 8783c 8784c perform 3-D FFT backward transform and get potential 8785c 8786 call fftback 8787 call fphi_mpole (fphi) 8788 do i = 1, npole 8789 do j = 1, 20 8790 fphi(j,i) = f * fphi(j,i) 8791 end do 8792 end do 8793 call fphi_to_cphi (fphi,cphi) 8794 end if 8795c 8796c perform dynamic allocation of some local arrays 8797c 8798 allocate (fuind(3,npole)) 8799 allocate (fuinp(3,npole)) 8800 allocate (fphid(10,npole)) 8801 allocate (fphip(10,npole)) 8802 allocate (fphidp(20,npole)) 8803 allocate (cphidp(10,npole)) 8804c 8805c convert Cartesian induced dipoles to fractional coordinates 8806c 8807 do i = 1, 3 8808 a(1,i) = dble(nfft1) * recip(i,1) 8809 a(2,i) = dble(nfft2) * recip(i,2) 8810 a(3,i) = dble(nfft3) * recip(i,3) 8811 end do 8812 do i = 1, npole 8813 do j = 1, 3 8814 fuind(j,i) = a(j,1)*uind(1,i) + a(j,2)*uind(2,i) 8815 & + a(j,3)*uind(3,i) 8816 fuinp(j,i) = a(j,1)*uinp(1,i) + a(j,2)*uinp(2,i) 8817 & + a(j,3)*uinp(3,i) 8818 end do 8819 end do 8820c 8821c assign PME grid and perform 3-D FFT forward transform 8822c 8823 call grid_uind (fuind,fuinp) 8824 call fftfront 8825c 8826c complete the transformation of the PME grid 8827c 8828 do k = 1, nfft3 8829 do j = 1, nfft2 8830 do i = 1, nfft1 8831 term = qfac(i,j,k) 8832 qgrid(1,i,j,k) = term * qgrid(1,i,j,k) 8833 qgrid(2,i,j,k) = term * qgrid(2,i,j,k) 8834 end do 8835 end do 8836 end do 8837c 8838c perform 3-D FFT backward transform and get potential 8839c 8840 call fftback 8841 call fphi_uind (fphid,fphip,fphidp) 8842 do i = 1, npole 8843 do j = 2, 10 8844 fphid(j,i) = f * fphid(j,i) 8845 fphip(j,i) = f * fphip(j,i) 8846 end do 8847 do j = 1, 20 8848 fphidp(j,i) = f * fphidp(j,i) 8849 end do 8850 end do 8851c 8852c increment the dipole polarization gradient contributions 8853c 8854 do i = 1, npole 8855 ii = ipole(i) 8856 f1 = 0.0d0 8857 f2 = 0.0d0 8858 f3 = 0.0d0 8859 do k = 1, 3 8860 j1 = deriv1(k+1) 8861 j2 = deriv2(k+1) 8862 j3 = deriv3(k+1) 8863 f1 = f1 + (fuind(k,i)+fuinp(k,i))*fphi(j1,i) 8864 f2 = f2 + (fuind(k,i)+fuinp(k,i))*fphi(j2,i) 8865 f3 = f3 + (fuind(k,i)+fuinp(k,i))*fphi(j3,i) 8866 if (poltyp .eq. 'MUTUAL') then 8867 f1 = f1 + fuind(k,i)*fphip(j1,i) + fuinp(k,i)*fphid(j1,i) 8868 f2 = f2 + fuind(k,i)*fphip(j2,i) + fuinp(k,i)*fphid(j2,i) 8869 f3 = f3 + fuind(k,i)*fphip(j3,i) + fuinp(k,i)*fphid(j3,i) 8870 end if 8871 end do 8872 do k = 1, 10 8873 f1 = f1 + fmp(k,i)*fphidp(deriv1(k),i) 8874 f2 = f2 + fmp(k,i)*fphidp(deriv2(k),i) 8875 f3 = f3 + fmp(k,i)*fphidp(deriv3(k),i) 8876 end do 8877 f1 = 0.5d0 * dble(nfft1) * f1 8878 f2 = 0.5d0 * dble(nfft2) * f2 8879 f3 = 0.5d0 * dble(nfft3) * f3 8880 h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3 8881 h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3 8882 h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3 8883 dep(1,ii) = dep(1,ii) + h1 8884 dep(2,ii) = dep(2,ii) + h2 8885 dep(3,ii) = dep(3,ii) + h3 8886 end do 8887c 8888c set the potential to be the induced dipole average 8889c 8890 do i = 1, npole 8891 do j = 1, 10 8892 fphidp(j,i) = 0.5d0 * fphidp(j,i) 8893 end do 8894 end do 8895 call fphi_to_cphi (fphidp,cphidp) 8896c 8897c get the fractional to Cartesian transformation matrix 8898c 8899 call frac_to_cart (ftc) 8900c 8901c increment the dipole polarization virial contributions 8902c 8903 do i = 1, npole 8904 do j = 2, 4 8905 cphid(j) = 0.0d0 8906 cphip(j) = 0.0d0 8907 do k = 2, 4 8908 cphid(j) = cphid(j) + ftc(j,k)*fphid(k,i) 8909 cphip(j) = cphip(j) + ftc(j,k)*fphip(k,i) 8910 end do 8911 end do 8912 vxx = vxx - cmp(2,i)*cphidp(2,i) 8913 & - 0.5d0*((uind(1,i)+uinp(1,i))*cphi(2,i)) 8914 vxy = vxy - 0.5d0*(cphidp(2,i)*cmp(3,i)+cphidp(3,i)*cmp(2,i)) 8915 & - 0.25d0*((uind(2,i)+uinp(2,i))*cphi(2,i) 8916 & +(uind(1,i)+uinp(1,i))*cphi(3,i)) 8917 vxz = vxz - 0.5d0*(cphidp(2,i)*cmp(4,i)+cphidp(4,i)*cmp(2,i)) 8918 & - 0.25d0*((uind(3,i)+uinp(3,i))*cphi(2,i) 8919 & +(uind(1,i)+uinp(1,i))*cphi(4,i)) 8920 vyy = vyy - cmp(3,i)*cphidp(3,i) 8921 & - 0.5d0*((uind(2,i)+uinp(2,i))*cphi(3,i)) 8922 vyz = vyz - 0.5d0*(cphidp(3,i)*cmp(4,i)+cphidp(4,i)*cmp(3,i)) 8923 & - 0.25d0*((uind(3,i)+uinp(3,i))*cphi(3,i) 8924 & +(uind(2,i)+uinp(2,i))*cphi(4,i)) 8925 vzz = vzz - cmp(4,i)*cphidp(4,i) 8926 & - 0.5d0*((uind(3,i)+uinp(3,i))*cphi(4,i)) 8927 vxx = vxx - 2.0d0*cmp(5,i)*cphidp(5,i) 8928 & - cmp(8,i)*cphidp(8,i) - cmp(9,i)*cphidp(9,i) 8929 vxy = vxy - (cmp(5,i)+cmp(6,i))*cphidp(8,i) 8930 & - 0.5d0*(cmp(8,i)*(cphidp(6,i)+cphidp(5,i)) 8931 & +cmp(9,i)*cphidp(10,i)+cmp(10,i)*cphidp(9,i)) 8932 vxz = vxz - (cmp(5,i)+cmp(7,i))*cphidp(9,i) 8933 & - 0.5d0*(cmp(9,i)*(cphidp(5,i)+cphidp(7,i)) 8934 & +cmp(8,i)*cphidp(10,i)+cmp(10,i)*cphidp(8,i)) 8935 vyy = vyy - 2.0d0*cmp(6,i)*cphidp(6,i) 8936 & - cmp(8,i)*cphidp(8,i) - cmp(10,i)*cphidp(10,i) 8937 vyz = vyz - (cmp(6,i)+cmp(7,i))*cphidp(10,i) 8938 & - 0.5d0*(cmp(10,i)*(cphidp(6,i)+cphidp(7,i)) 8939 & +cmp(8,i)*cphidp(9,i)+cmp(9,i)*cphidp(8,i)) 8940 vzz = vzz - 2.0d0*cmp(7,i)*cphidp(7,i) 8941 & - cmp(9,i)*cphidp(9,i) - cmp(10,i)*cphidp(10,i) 8942 if (poltyp .eq. 'MUTUAL') then 8943 vxx = vxx - 0.5d0*(cphid(2)*uinp(1,i)+cphip(2)*uind(1,i)) 8944 vxy = vxy - 0.25d0*(cphid(2)*uinp(2,i)+cphip(2)*uind(2,i) 8945 & +cphid(3)*uinp(1,i)+cphip(3)*uind(1,i)) 8946 vxz = vxz - 0.25d0*(cphid(2)*uinp(3,i)+cphip(2)*uind(3,i) 8947 & +cphid(4)*uinp(1,i)+cphip(4)*uind(1,i)) 8948 vyy = vyy - 0.5d0*(cphid(3)*uinp(2,i)+cphip(3)*uind(2,i)) 8949 vyz = vyz - 0.25d0*(cphid(3)*uinp(3,i)+cphip(3)*uind(3,i) 8950 & +cphid(4)*uinp(2,i)+cphip(4)*uind(2,i)) 8951 vzz = vzz - 0.5d0*(cphid(4)*uinp(3,i)+cphip(4)*uind(3,i)) 8952 end if 8953 end do 8954c 8955c resolve site torques then increment forces and virial 8956c 8957 do i = 1, npole 8958 tep(1) = cmp(4,i)*cphidp(3,i) - cmp(3,i)*cphidp(4,i) 8959 & + 2.0d0*(cmp(7,i)-cmp(6,i))*cphidp(10,i) 8960 & + cmp(9,i)*cphidp(8,i) + cmp(10,i)*cphidp(6,i) 8961 & - cmp(8,i)*cphidp(9,i) - cmp(10,i)*cphidp(7,i) 8962 tep(2) = cmp(2,i)*cphidp(4,i) - cmp(4,i)*cphidp(2,i) 8963 & + 2.0d0*(cmp(5,i)-cmp(7,i))*cphidp(9,i) 8964 & + cmp(8,i)*cphidp(10,i) + cmp(9,i)*cphidp(7,i) 8965 & - cmp(9,i)*cphidp(5,i) - cmp(10,i)*cphidp(8,i) 8966 tep(3) = cmp(3,i)*cphidp(2,i) - cmp(2,i)*cphidp(3,i) 8967 & + 2.0d0*(cmp(6,i)-cmp(5,i))*cphidp(8,i) 8968 & + cmp(8,i)*cphidp(5,i) + cmp(10,i)*cphidp(9,i) 8969 & - cmp(8,i)*cphidp(6,i) - cmp(9,i)*cphidp(10,i) 8970 call torque (i,tep,fix,fiy,fiz,dep) 8971 ii = ipole(i) 8972 iz = zaxis(i) 8973 ix = xaxis(i) 8974 iy = abs(yaxis(i)) 8975 if (iz .eq. 0) iz = ii 8976 if (ix .eq. 0) ix = ii 8977 if (iy .eq. 0) iy = ii 8978 xiz = x(iz) - x(ii) 8979 yiz = y(iz) - y(ii) 8980 ziz = z(iz) - z(ii) 8981 xix = x(ix) - x(ii) 8982 yix = y(ix) - y(ii) 8983 zix = z(ix) - z(ii) 8984 xiy = x(iy) - x(ii) 8985 yiy = y(iy) - y(ii) 8986 ziy = z(iy) - z(ii) 8987 vxx = vxx + xix*fix(1) + xiy*fiy(1) + xiz*fiz(1) 8988 vxy = vxy + 0.5d0*(yix*fix(1) + yiy*fiy(1) + yiz*fiz(1) 8989 & + xix*fix(2) + xiy*fiy(2) + xiz*fiz(2)) 8990 vxz = vxz + 0.5d0*(zix*fix(1) + ziy*fiy(1) + ziz*fiz(1) 8991 & + xix*fix(3) + xiy*fiy(3) + xiz*fiz(3)) 8992 vyy = vyy + yix*fix(2) + yiy*fiy(2) + yiz*fiz(2) 8993 vyz = vyz + 0.5d0*(zix*fix(2) + ziy*fiy(2) + ziz*fiz(2) 8994 & + yix*fix(3) + yiy*fiy(3) + yiz*fiz(3)) 8995 vzz = vzz + zix*fix(3) + ziy*fiy(3) + ziz*fiz(3) 8996 end do 8997c 8998c account for dipole response terms in the OPT method 8999c 9000 if (poltyp .eq. 'OPT') then 9001 do i = 1, npole 9002 ii = ipole(i) 9003 do k = 0, optorder-1 9004 do j = 2, 10 9005 fphid(j,i) = f * fopt(k,j,i) 9006 fphip(j,i) = f * foptp(k,j,i) 9007 end do 9008 do m = 0, optorder-k-1 9009 do j = 1, 3 9010 fuind(j,i) = a(j,1)*uopt(m,1,i) 9011 & + a(j,2)*uopt(m,2,i) 9012 & + a(j,3)*uopt(m,3,i) 9013 fuinp(j,i) = a(j,1)*uoptp(m,1,i) 9014 & + a(j,2)*uoptp(m,2,i) 9015 & + a(j,3)*uoptp(m,3,i) 9016 end do 9017 f1 = 0.0d0 9018 f2 = 0.0d0 9019 f3 = 0.0d0 9020 do j = 1, 3 9021 j1 = deriv1(j+1) 9022 j2 = deriv2(j+1) 9023 j3 = deriv3(j+1) 9024 f1 = f1 + fuind(j,i)*fphip(j1,i) 9025 & + fuinp(j,i)*fphid(j1,i) 9026 f2 = f2 + fuind(j,i)*fphip(j2,i) 9027 & + fuinp(j,i)*fphid(j2,i) 9028 f3 = f3 + fuind(j,i)*fphip(j3,i) 9029 & + fuinp(j,i)*fphid(j3,i) 9030 end do 9031 f1 = 0.5d0 * dble(nfft1) * f1 9032 f2 = 0.5d0 * dble(nfft2) * f2 9033 f3 = 0.5d0 * dble(nfft3) * f3 9034 h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3 9035 h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3 9036 h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3 9037 dep(1,ii) = dep(1,ii) + copm(k+m+1)*h1 9038 dep(2,ii) = dep(2,ii) + copm(k+m+1)*h2 9039 dep(3,ii) = dep(3,ii) + copm(k+m+1)*h3 9040 do j = 2, 4 9041 cphid(j) = 0.0d0 9042 cphip(j) = 0.0d0 9043 do j1 = 2, 4 9044 cphid(j) = cphid(j) + ftc(j,j1)*fphid(j1,i) 9045 cphip(j) = cphip(j) + ftc(j,j1)*fphip(j1,i) 9046 end do 9047 end do 9048 vxx = vxx - 0.5d0*copm(k+m+1) 9049 & *(cphid(2)*uoptp(m,1,i) 9050 & +cphip(2)*uopt(m,1,i)) 9051 vxy = vxy - 0.25d0*copm(k+m+1) 9052 & *(cphid(2)*uoptp(m,2,i) 9053 & +cphip(2)*uopt(m,2,i) 9054 & +cphid(3)*uoptp(m,1,i) 9055 & +cphip(3)*uopt(m,1,i)) 9056 vxz = vxz - 0.25d0*copm(k+m+1) 9057 & *(cphid(2)*uoptp(m,3,i) 9058 & +cphip(2)*uopt(m,3,i) 9059 & +cphid(4)*uoptp(m,1,i) 9060 & +cphip(4)*uopt(m,1,i)) 9061 vyy = vyy - 0.5d0*copm(k+m+1) 9062 & *(cphid(3)*uoptp(m,2,i) 9063 & +cphip(3)*uopt(m,2,i)) 9064 vyz = vyz - 0.25d0*copm(k+m+1) 9065 & *(cphid(3)*uoptp(m,3,i) 9066 & +cphip(3)*uopt(m,3,i) 9067 & +cphid(4)*uoptp(m,2,i) 9068 & +cphip(4)*uopt(m,2,i)) 9069 vzz = vzz - 0.5d0*copm(k+m+1) 9070 & *(cphid(4)*uoptp(m,3,i) 9071 & +cphip(4)*uopt(m,3,i)) 9072 end do 9073 end do 9074 end do 9075 end if 9076c 9077c account for dipole response terms in the TCG method 9078c 9079 if (poltyp .eq. 'TCG') then 9080 do m = 1, tcgnab 9081 do i = 1, npole 9082 do j = 1, 3 9083 fuind(j,i) = a(j,1)*uad(1,i,m) + a(j,2)*uad(2,i,m) 9084 & + a(j,3)*uad(3,i,m) 9085 fuinp(j,i) = a(j,1)*ubp(1,i,m) + a(j,2)*ubp(2,i,m) 9086 & + a(j,3)*ubp(3,i,m) 9087 end do 9088 end do 9089 call grid_uind (fuind,fuinp) 9090 call fftfront 9091 do k = 1, nfft3 9092 do j = 1, nfft2 9093 do i = 1, nfft1 9094 term = qfac(i,j,k) 9095 qgrid(1,i,j,k) = term * qgrid(1,i,j,k) 9096 qgrid(2,i,j,k) = term * qgrid(2,i,j,k) 9097 end do 9098 end do 9099 end do 9100 call fftback 9101 call fphi_uind (fphid,fphip,fphidp) 9102 do i = 1, npole 9103 do j = 2, 10 9104 fphid(j,i) = f * fphid(j,i) 9105 fphip(j,i) = f * fphip(j,i) 9106 end do 9107 end do 9108 do i = 1, npole 9109 ii = ipole(i) 9110 f1 = 0.0d0 9111 f2 = 0.0d0 9112 f3 = 0.0d0 9113 do k = 1, 3 9114 j1 = deriv1(k+1) 9115 j2 = deriv2(k+1) 9116 j3 = deriv3(k+1) 9117 f1 = f1+fuind(k,i)*fphip(j1,i)+fuinp(k,i)*fphid(j1,i) 9118 f2 = f2+fuind(k,i)*fphip(j2,i)+fuinp(k,i)*fphid(j2,i) 9119 f3 = f3+fuind(k,i)*fphip(j3,i)+fuinp(k,i)*fphid(j3,i) 9120 end do 9121 f1 = 0.5d0 * dble(nfft1) * f1 9122 f2 = 0.5d0 * dble(nfft2) * f2 9123 f3 = 0.5d0 * dble(nfft3) * f3 9124 h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3 9125 h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3 9126 h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3 9127 dep(1,ii) = dep(1,ii) + h1 9128 dep(2,ii) = dep(2,ii) + h2 9129 dep(3,ii) = dep(3,ii) + h3 9130 do j = 2, 4 9131 cphid(j) = 0.0d0 9132 cphip(j) = 0.0d0 9133 do k = 2, 4 9134 cphid(j) = cphid(j) + ftc(j,k)*fphid(k,i) 9135 cphip(j) = cphip(j) + ftc(j,k)*fphip(k,i) 9136 end do 9137 end do 9138 vxx = vxx - 0.5d0*(cphid(2)*ubp(1,i,m) 9139 & +cphip(2)*uad(1,i,m)) 9140 vxy = vxy - 0.25d0*(cphid(2)*ubp(2,i,m) 9141 & +cphip(2)*uad(2,i,m) 9142 & +cphid(3)*ubp(1,i,m) 9143 & +cphip(3)*uad(1,i,m)) 9144 vxz = vxz - 0.25d0*(cphid(2)*ubp(3,i,m) 9145 & +cphip(2)*uad(3,i,m) 9146 & +cphid(4)*ubp(1,i,m) 9147 & +cphip(4)*uad(1,i,m)) 9148 vyy = vyy - 0.5d0*(cphid(3)*ubp(2,i,m) 9149 & +cphip(3)*uad(2,i,m)) 9150 vyz = vyz - 0.25d0*(cphid(3)*ubp(3,i,m) 9151 & +cphip(3)*uad(3,i,m) 9152 & +cphid(4)*ubp(2,i,m) 9153 & +cphip(4)*uad(2,i,m)) 9154 vzz = vzz - 0.5d0*(cphid(4)*ubp(3,i,m) 9155 & +cphip(4)*uad(3,i,m)) 9156 end do 9157 do i = 1, npole 9158 do j = 1, 3 9159 fuind(j,i) = a(j,1)*ubd(1,i,m) + a(j,2)*ubd(2,i,m) 9160 & + a(j,3)*ubd(3,i,m) 9161 fuinp(j,i) = a(j,1)*uap(1,i,m) + a(j,2)*uap(2,i,m) 9162 & + a(j,3)*uap(3,i,m) 9163 end do 9164 end do 9165 call grid_uind (fuind,fuinp) 9166 call fftfront 9167 do k = 1, nfft3 9168 do j = 1, nfft2 9169 do i = 1, nfft1 9170 term = qfac(i,j,k) 9171 qgrid(1,i,j,k) = term * qgrid(1,i,j,k) 9172 qgrid(2,i,j,k) = term * qgrid(2,i,j,k) 9173 end do 9174 end do 9175 end do 9176 call fftback 9177 call fphi_uind (fphid,fphip,fphidp) 9178 do i = 1, npole 9179 do j = 2, 10 9180 fphid(j,i) = f * fphid(j,i) 9181 fphip(j,i) = f * fphip(j,i) 9182 end do 9183 end do 9184 do i = 1, npole 9185 ii = ipole(i) 9186 f1 = 0.0d0 9187 f2 = 0.0d0 9188 f3 = 0.0d0 9189 do k = 1, 3 9190 j1 = deriv1(k+1) 9191 j2 = deriv2(k+1) 9192 j3 = deriv3(k+1) 9193 f1 = f1+fuind(k,i)*fphip(j1,i)+fuinp(k,i)*fphid(j1,i) 9194 f2 = f2+fuind(k,i)*fphip(j2,i)+fuinp(k,i)*fphid(j2,i) 9195 f3 = f3+fuind(k,i)*fphip(j3,i)+fuinp(k,i)*fphid(j3,i) 9196 end do 9197 f1 = 0.5d0 * dble(nfft1) * f1 9198 f2 = 0.5d0 * dble(nfft2) * f2 9199 f3 = 0.5d0 * dble(nfft3) * f3 9200 h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3 9201 h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3 9202 h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3 9203 dep(1,ii) = dep(1,ii) + h1 9204 dep(2,ii) = dep(2,ii) + h2 9205 dep(3,ii) = dep(3,ii) + h3 9206 do j = 2, 4 9207 cphid(j) = 0.0d0 9208 cphip(j) = 0.0d0 9209 do k = 2, 4 9210 cphid(j) = cphid(j) + ftc(j,k)*fphid(k,i) 9211 cphip(j) = cphip(j) + ftc(j,k)*fphip(k,i) 9212 end do 9213 end do 9214 vxx = vxx - 0.5d0*(cphid(2)*uap(1,i,m) 9215 & +cphip(2)*ubd(1,i,m)) 9216 vxy = vxy - 0.25d0*(cphid(2)*uap(2,i,m) 9217 & +cphip(2)*ubd(2,i,m) 9218 & +cphid(3)*uap(1,i,m) 9219 & +cphip(3)*ubd(1,i,m)) 9220 vxz = vxz - 0.25d0*(cphid(2)*uap(3,i,m) 9221 & +cphip(2)*ubd(3,i,m) 9222 & +cphid(4)*uap(1,i,m) 9223 & +cphip(4)*ubd(1,i,m)) 9224 vyy = vyy - 0.5d0*(cphid(3)*uap(2,i,m) 9225 & +cphip(3)*ubd(2,i,m)) 9226 vyz = vyz - 0.25d0*(cphid(3)*uap(3,i,m) 9227 & +cphip(3)*ubd(3,i,m) 9228 & +cphid(4)*uap(2,i,m) 9229 & +cphip(4)*ubd(2,i,m)) 9230 vzz = vzz - 0.5d0*(cphid(4)*uap(3,i,m) 9231 & +cphip(4)*ubd(3,i,m)) 9232 end do 9233 end do 9234 end if 9235c 9236c perform deallocation of some local arrays 9237c 9238 deallocate (fuind) 9239 deallocate (fuinp) 9240 deallocate (fphid) 9241 deallocate (fphip) 9242 deallocate (fphidp) 9243c 9244c perform dynamic allocation of some local arrays 9245c 9246 allocate (qgrip(2,nfft1,nfft2,nfft3)) 9247c 9248c assign permanent and induced multipoles to the PME grid 9249c and perform the 3-D FFT forward transformation 9250c 9251 do i = 1, npole 9252 do j = 2, 4 9253 cmp(j,i) = cmp(j,i) + uinp(j-1,i) 9254 end do 9255 end do 9256 call cmp_to_fmp (cmp,fmp) 9257 call grid_mpole (fmp) 9258 call fftfront 9259 do k = 1, nfft3 9260 do j = 1, nfft2 9261 do i = 1, nfft1 9262 qgrip(1,i,j,k) = qgrid(1,i,j,k) 9263 qgrip(2,i,j,k) = qgrid(2,i,j,k) 9264 end do 9265 end do 9266 end do 9267 do i = 1, npole 9268 do j = 2, 4 9269 cmp(j,i) = cmp(j,i) + uind(j-1,i) - uinp(j-1,i) 9270 end do 9271 end do 9272 call cmp_to_fmp (cmp,fmp) 9273 call grid_mpole (fmp) 9274 call fftfront 9275c 9276c make the scalar summation over reciprocal lattice 9277c 9278 do i = 1, ntot-1 9279 k3 = i/nff + 1 9280 j = i - (k3-1)*nff 9281 k2 = j/nfft1 + 1 9282 k1 = j - (k2-1)*nfft1 + 1 9283 m1 = k1 - 1 9284 m2 = k2 - 1 9285 m3 = k3 - 1 9286 if (k1 .gt. nf1) m1 = m1 - nfft1 9287 if (k2 .gt. nf2) m2 = m2 - nfft2 9288 if (k3 .gt. nf3) m3 = m3 - nfft3 9289 r1 = dble(m1) 9290 r2 = dble(m2) 9291 r3 = dble(m3) 9292 h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3 9293 h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3 9294 h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3 9295 hsq = h1*h1 + h2*h2 + h3*h3 9296 term = -pterm * hsq 9297 expterm = 0.0d0 9298 if (term .gt. -50.0d0) then 9299 denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3) 9300 expterm = exp(term) / denom 9301 if (.not. use_bounds) then 9302 expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) 9303 else if (nonprism) then 9304 if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 9305 end if 9306 struc2 = qgrid(1,k1,k2,k3)*qgrip(1,k1,k2,k3) 9307 & + qgrid(2,k1,k2,k3)*qgrip(2,k1,k2,k3) 9308 eterm = 0.5d0 * f * expterm * struc2 9309 vterm = (2.0d0/hsq) * (1.0d0-term) * eterm 9310 vxx = vxx + h1*h1*vterm - eterm 9311 vxy = vxy + h1*h2*vterm 9312 vxz = vxz + h1*h3*vterm 9313 vyy = vyy + h2*h2*vterm - eterm 9314 vyz = vyz + h2*h3*vterm 9315 vzz = vzz + h3*h3*vterm - eterm 9316 end if 9317 qfac(k1,k2,k3) = expterm 9318 end do 9319c 9320c assign only the induced dipoles to the PME grid 9321c and perform the 3-D FFT forward transformation 9322c 9323 if (poltyp.eq.'DIRECT' .or. poltyp.eq.'TCG') then 9324 do i = 1, npole 9325 do j = 1, 10 9326 cmp(j,i) = 0.0d0 9327 end do 9328 do j = 2, 4 9329 cmp(j,i) = uinp(j-1,i) 9330 end do 9331 end do 9332 call cmp_to_fmp (cmp,fmp) 9333 call grid_mpole (fmp) 9334 call fftfront 9335 do k = 1, nfft3 9336 do j = 1, nfft2 9337 do i = 1, nfft1 9338 qgrip(1,i,j,k) = qgrid(1,i,j,k) 9339 qgrip(2,i,j,k) = qgrid(2,i,j,k) 9340 end do 9341 end do 9342 end do 9343 do i = 1, npole 9344 do j = 2, 4 9345 cmp(j,i) = uind(j-1,i) 9346 end do 9347 end do 9348 call cmp_to_fmp (cmp,fmp) 9349 call grid_mpole (fmp) 9350 call fftfront 9351c 9352c make the scalar summation over reciprocal lattice 9353c 9354 do i = 1, ntot-1 9355 k3 = i/nff + 1 9356 j = i - (k3-1)*nff 9357 k2 = j/nfft1 + 1 9358 k1 = j - (k2-1)*nfft1 + 1 9359 m1 = k1 - 1 9360 m2 = k2 - 1 9361 m3 = k3 - 1 9362 if (k1 .gt. nf1) m1 = m1 - nfft1 9363 if (k2 .gt. nf2) m2 = m2 - nfft2 9364 if (k3 .gt. nf3) m3 = m3 - nfft3 9365 r1 = dble(m1) 9366 r2 = dble(m2) 9367 r3 = dble(m3) 9368 h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3 9369 h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3 9370 h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3 9371 hsq = h1*h1 + h2*h2 + h3*h3 9372 term = -pterm * hsq 9373 expterm = 0.0d0 9374 if (term .gt. -50.0d0) then 9375 denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3) 9376 expterm = exp(term) / denom 9377 if (.not. use_bounds) then 9378 expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) 9379 else if (nonprism) then 9380 if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 9381 end if 9382 struc2 = qgrid(1,k1,k2,k3)*qgrip(1,k1,k2,k3) 9383 & + qgrid(2,k1,k2,k3)*qgrip(2,k1,k2,k3) 9384 eterm = 0.5d0 * f * expterm * struc2 9385 vterm = (2.0d0/hsq) * (1.0d0-term) * eterm 9386 vxx = vxx - h1*h1*vterm + eterm 9387 vxy = vxy - h1*h2*vterm 9388 vxz = vxz - h1*h3*vterm 9389 vyy = vyy - h2*h2*vterm + eterm 9390 vyz = vyz - h2*h3*vterm 9391 vzz = vzz - h3*h3*vterm + eterm 9392 end if 9393 end do 9394 end if 9395c 9396c add back missing terms for the TCG polarization method; 9397c first do the term for "UAD" dotted with "UBP" 9398c 9399 if (poltyp .eq. 'TCG') then 9400 do m = 1, tcgnab 9401 do i = 1, npole 9402 do j = 1, 10 9403 cmp(j,i) = 0.0d0 9404 end do 9405 do j = 2, 4 9406 cmp(j,i) = ubp(j-1,i,m) 9407 end do 9408 end do 9409 call cmp_to_fmp (cmp,fmp) 9410 call grid_mpole (fmp) 9411 call fftfront 9412 do k = 1, nfft3 9413 do j = 1, nfft2 9414 do i = 1, nfft1 9415 qgrip(1,i,j,k) = qgrid(1,i,j,k) 9416 qgrip(2,i,j,k) = qgrid(2,i,j,k) 9417 end do 9418 end do 9419 end do 9420 do i = 1, npole 9421 do j = 2, 4 9422 cmp(j,i) = uad(j-1,i,m) 9423 end do 9424 end do 9425 call cmp_to_fmp (cmp,fmp) 9426 call grid_mpole (fmp) 9427 call fftfront 9428c 9429c make the scalar summation over reciprocal lattice 9430c 9431 do i = 1, ntot-1 9432 k3 = i/nff + 1 9433 j = i - (k3-1)*nff 9434 k2 = j/nfft1 + 1 9435 k1 = j - (k2-1)*nfft1 + 1 9436 m1 = k1 - 1 9437 m2 = k2 - 1 9438 m3 = k3 - 1 9439 if (k1 .gt. nf1) m1 = m1 - nfft1 9440 if (k2 .gt. nf2) m2 = m2 - nfft2 9441 if (k3 .gt. nf3) m3 = m3 - nfft3 9442 r1 = dble(m1) 9443 r2 = dble(m2) 9444 r3 = dble(m3) 9445 h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3 9446 h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3 9447 h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3 9448 hsq = h1*h1 + h2*h2 + h3*h3 9449 term = -pterm * hsq 9450 expterm = 0.0d0 9451 if (term .gt. -50.0d0) then 9452 denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3) 9453 expterm = exp(term) / denom 9454 if (.not. use_bounds) then 9455 expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) 9456 else if (nonprism) then 9457 if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 9458 end if 9459 struc2 = qgrid(1,k1,k2,k3)*qgrip(1,k1,k2,k3) 9460 & + qgrid(2,k1,k2,k3)*qgrip(2,k1,k2,k3) 9461 eterm = 0.5d0 * f * expterm * struc2 9462 vterm = (2.0d0/hsq) * (1.0d0-term) * eterm 9463 vxx = vxx + h1*h1*vterm - eterm 9464 vxy = vxy + h1*h2*vterm 9465 vxz = vxz + h1*h3*vterm 9466 vyy = vyy + h2*h2*vterm - eterm 9467 vyz = vyz + h2*h3*vterm 9468 vzz = vzz + h3*h3*vterm - eterm 9469 end if 9470 end do 9471c 9472c now do the TCG terms with "UBD" dotted with "UAP" 9473c 9474 do i = 1, npole 9475 do j = 1, 10 9476 cmp(j,i) = 0.0d0 9477 end do 9478 do j = 2, 4 9479 cmp(j,i) = uap(j-1,i,m) 9480 end do 9481 end do 9482 call cmp_to_fmp (cmp,fmp) 9483 call grid_mpole (fmp) 9484 call fftfront 9485 do k = 1, nfft3 9486 do j = 1, nfft2 9487 do i = 1, nfft1 9488 qgrip(1,i,j,k) = qgrid(1,i,j,k) 9489 qgrip(2,i,j,k) = qgrid(2,i,j,k) 9490 end do 9491 end do 9492 end do 9493 do i = 1, npole 9494 do j = 2, 4 9495 cmp(j,i) = ubd(j-1,i,m) 9496 end do 9497 end do 9498 call cmp_to_fmp (cmp,fmp) 9499 call grid_mpole (fmp) 9500 call fftfront 9501c 9502c make the scalar summation over reciprocal lattice 9503c 9504 do i = 1, ntot-1 9505 k3 = i/nff + 1 9506 j = i - (k3-1)*nff 9507 k2 = j/nfft1 + 1 9508 k1 = j - (k2-1)*nfft1 + 1 9509 m1 = k1 - 1 9510 m2 = k2 - 1 9511 m3 = k3 - 1 9512 if (k1 .gt. nf1) m1 = m1 - nfft1 9513 if (k2 .gt. nf2) m2 = m2 - nfft2 9514 if (k3 .gt. nf3) m3 = m3 - nfft3 9515 r1 = dble(m1) 9516 r2 = dble(m2) 9517 r3 = dble(m3) 9518 h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3 9519 h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3 9520 h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3 9521 hsq = h1*h1 + h2*h2 + h3*h3 9522 term = -pterm * hsq 9523 expterm = 0.0d0 9524 if (term .gt. -50.0d0) then 9525 denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3) 9526 expterm = exp(term) / denom 9527 if (.not. use_bounds) then 9528 expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) 9529 else if (nonprism) then 9530 if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 9531 end if 9532 struc2 = qgrid(1,k1,k2,k3)*qgrip(1,k1,k2,k3) 9533 & + qgrid(2,k1,k2,k3)*qgrip(2,k1,k2,k3) 9534 eterm = 0.5d0 * f * expterm * struc2 9535 vterm = (2.0d0/hsq) * (1.0d0-term) * eterm 9536 vxx = vxx + h1*h1*vterm - eterm 9537 vxy = vxy + h1*h2*vterm 9538 vxz = vxz + h1*h3*vterm 9539 vyy = vyy + h2*h2*vterm - eterm 9540 vyz = vyz + h2*h3*vterm 9541 vzz = vzz + h3*h3*vterm - eterm 9542 end if 9543 end do 9544 end do 9545 end if 9546c 9547c perform dynamic allocation of some local arrays 9548c 9549 if (use_chgflx) then 9550 allocate (pot(n)) 9551 allocate (decfx(n)) 9552 allocate (decfy(n)) 9553 allocate (decfz(n)) 9554c 9555c modify the gradient and virial for charge flux 9556c 9557 do i = 1, n 9558 pot(i) = 0.0d0 9559 end do 9560 do i = 1, npole 9561 ii = ipole(i) 9562 pot(ii) = cphidp(1,i) 9563 end do 9564 call dcflux (pot,decfx,decfy,decfz) 9565 do i = 1, npole 9566 ii = ipole(i) 9567 xi = x(ii) 9568 yi = y(ii) 9569 zi = z(ii) 9570 frcx = decfx(ii) 9571 frcy = decfy(ii) 9572 frcz = decfz(ii) 9573 dep(1,ii) = dep(1,ii) + frcx 9574 dep(2,ii) = dep(2,ii) + frcy 9575 dep(3,ii) = dep(3,ii) + frcz 9576 vxx = vxx + xi*frcx 9577 vxy = vxy + yi*frcx 9578 vxz = vxz + zi*frcx 9579 vyy = vyy + yi*frcy 9580 vyz = vyz + zi*frcy 9581 vzz = vzz + zi*frcz 9582 end do 9583c 9584c perform deallocation of some local arrays 9585c 9586 deallocate (pot) 9587 deallocate (decfx) 9588 deallocate (decfy) 9589 deallocate (decfz) 9590 end if 9591c 9592c increment the total internal virial tensor components 9593c 9594 vir(1,1) = vir(1,1) + vxx 9595 vir(2,1) = vir(2,1) + vxy 9596 vir(3,1) = vir(3,1) + vxz 9597 vir(1,2) = vir(1,2) + vxy 9598 vir(2,2) = vir(2,2) + vyy 9599 vir(3,2) = vir(3,2) + vyz 9600 vir(1,3) = vir(1,3) + vxz 9601 vir(2,3) = vir(2,3) + vyz 9602 vir(3,3) = vir(3,3) + vzz 9603c 9604c perform deallocation of some local arrays 9605c 9606 deallocate (cphidp) 9607 deallocate (qgrip) 9608 return 9609 end 9610