1c 2c 3c ############################################################# 4c ## COPYRIGHT (C) 1999 by Pengyu Ren & Jay William Ponder ## 5c ## All Rights Reserved ## 6c ############################################################# 7c 8c ############################################################## 9c ## ## 10c ## subroutine induce -- evaluate induced dipole moments ## 11c ## ## 12c ############################################################## 13c 14c 15c "induce" computes the induced dipole moments at polarizable 16c sites due to direct or mutual polarization 17c 18c assumes multipole components have already been rotated into 19c the global coordinate frame; computes induced dipoles based 20c on full system, use of active or inactive atoms is ignored 21c 22c 23 subroutine induce 24 use inform 25 use iounit 26 use limits 27 use mpole 28 use polar 29 use polpot 30 use potent 31 use solpot 32 use units 33 use uprior 34 implicit none 35 integer i,j,k,ii 36 real*8 norm 37 logical header 38c 39c 40c choose the method for computation of induced dipoles 41c 42 if (solvtyp(1:2) .eq. 'PB') then 43 call induce0d 44 else if (solvtyp(1:2) .eq. 'GK') then 45 call induce0c 46 else if (poltyp .eq. 'TCG') then 47 call induce0b 48 else 49 call induce0a 50 end if 51c 52c update the lists of previous induced dipole values 53c 54 if (use_pred) then 55 nualt = min(nualt+1,maxualt) 56 do ii = 1, npole 57 do j = 1, 3 58 do k = nualt, 2, -1 59 udalt(k,j,ii) = udalt(k-1,j,ii) 60 upalt(k,j,ii) = upalt(k-1,j,ii) 61 end do 62 udalt(1,j,ii) = uind(j,ii) 63 upalt(1,j,ii) = uinp(j,ii) 64 if (use_solv) then 65 do k = nualt, 2, -1 66 usalt(k,j,ii) = usalt(k-1,j,ii) 67 upsalt(k,j,ii) = upsalt(k-1,j,ii) 68 end do 69 usalt(1,j,ii) = uinds(j,ii) 70 upsalt(1,j,ii) = uinps(j,ii) 71 end if 72 end do 73 end do 74 end if 75c 76c print out a list of the final induced dipole moments 77c 78 if (debug .and. use_polar) then 79 header = .true. 80 do ii = 1, npole 81 i = ipole(ii) 82 if (polarity(ii) .ne. 0.0d0) then 83 if (header) then 84 header = .false. 85 if (solvtyp(1:2).eq.'GK' .or. 86 & solvtyp(1:2).eq.'PB') then 87 write (iout,10) 88 10 format (/,' Vacuum Induced Dipole Moments', 89 & ' (Debye) :') 90 else 91 write (iout,20) 92 20 format (/,' Induced Dipole Moments (Debye) :') 93 end if 94 write (iout,30) 95 30 format (/,4x,'Atom',15x,'X',12x,'Y',12x,'Z', 96 & 11x,'Total',/) 97 end if 98 norm = sqrt(uind(1,ii)**2+uind(2,ii)**2+uind(3,ii)**2) 99 write (iout,40) i,(debye*uind(j,ii),j=1,3),debye*norm 100 40 format (i8,5x,3f13.4,1x,f13.4) 101 end if 102 end do 103 header = .true. 104 if (solvtyp(1:2).eq.'GK' .or. solvtyp(1:2).eq.'PB') then 105 do ii = 1, npole 106 i = ipole(ii) 107 if (polarity(ii) .ne. 0.0d0) then 108 if (header) then 109 header = .false. 110 write (iout,50) 111 50 format (/,' SCRF Induced Dipole Moments', 112 & ' (Debye) :') 113 write (iout,60) 114 60 format (/,4x,'Atom',15x,'X',12x,'Y',12x,'Z', 115 & 11x,'Total',/) 116 end if 117 norm = sqrt(uinds(1,ii)**2+uinds(2,ii)**2 118 & +uinds(3,ii)**2) 119 write (iout,70) i,(debye*uinds(j,ii),j=1,3), 120 & debye*norm 121 70 format (i8,5x,3f13.4,1x,f13.4) 122 end if 123 end do 124 end if 125 end if 126 return 127 end 128c 129c 130c ################################################################# 131c ## ## 132c ## subroutine induce0a -- conjugate gradient dipole solver ## 133c ## ## 134c ################################################################# 135c 136c 137c "induce0a" computes the induced dipole moments at polarizable 138c sites using a preconditioned conjugate gradient solver 139c 140c 141 subroutine induce0a 142 use atoms 143 use ielscf 144 use inform 145 use iounit 146 use limits 147 use mpole 148 use neigh 149 use polar 150 use polopt 151 use polpcg 152 use polpot 153 use potent 154 use units 155 use uprior 156 implicit none 157 integer i,j,k,iter 158 integer miniter 159 integer maxiter 160 real*8 polmin 161 real*8 eps,epsold 162 real*8 epsd,epsp 163 real*8 udsum,upsum 164 real*8 a,ap,b,bp 165 real*8 sum,sump,term 166 real*8, allocatable :: poli(:) 167 real*8, allocatable :: field(:,:) 168 real*8, allocatable :: fieldp(:,:) 169 real*8, allocatable :: rsd(:,:) 170 real*8, allocatable :: rsdp(:,:) 171 real*8, allocatable :: zrsd(:,:) 172 real*8, allocatable :: zrsdp(:,:) 173 real*8, allocatable :: conj(:,:) 174 real*8, allocatable :: conjp(:,:) 175 real*8, allocatable :: vec(:,:) 176 real*8, allocatable :: vecp(:,:) 177 real*8, allocatable :: usum(:,:) 178 real*8, allocatable :: usump(:,:) 179 logical done 180 character*6 mode 181c 182c 183c zero out the induced dipoles at each site 184c 185 do i = 1, npole 186 do j = 1, 3 187 uind(j,i) = 0.0d0 188 uinp(j,i) = 0.0d0 189 end do 190 end do 191 if (.not. use_polar) return 192c 193c perform dynamic allocation of some local arrays 194c 195 allocate (field(3,npole)) 196 allocate (fieldp(3,npole)) 197c 198c get the electrostatic field due to permanent multipoles 199c 200 if (use_ewald) then 201 call dfield0c (field,fieldp) 202 else if (use_mlist) then 203 call dfield0b (field,fieldp) 204 else 205 call dfield0a (field,fieldp) 206 end if 207c 208c set induced dipoles to polarizability times direct field 209c 210 do i = 1, npole 211 if (douind(ipole(i))) then 212 do j = 1, 3 213 udir(j,i) = polarity(i) * field(j,i) 214 udirp(j,i) = polarity(i) * fieldp(j,i) 215 if (pcgguess) then 216 uind(j,i) = udir(j,i) 217 uinp(j,i) = udirp(j,i) 218 end if 219 end do 220 end if 221 end do 222 223c get induced dipoles via the OPT extrapolation method 224c 225 if (poltyp .eq. 'OPT') then 226 do i = 1, npole 227 if (douind(ipole(i))) then 228 do j = 1, 3 229 uopt(0,j,i) = udir(j,i) 230 uoptp(0,j,i) = udirp(j,i) 231 end do 232 end if 233 end do 234 do k = 1, optorder 235 optlevel = k - 1 236 if (use_ewald) then 237 call ufield0c (field,fieldp) 238 else if (use_mlist) then 239 call ufield0b (field,fieldp) 240 else 241 call ufield0a (field,fieldp) 242 end if 243 do i = 1, npole 244 if (douind(ipole(i))) then 245 do j = 1, 3 246 uopt(k,j,i) = polarity(i) * field(j,i) 247 uoptp(k,j,i) = polarity(i) * fieldp(j,i) 248 uind(j,i) = uopt(k,j,i) 249 uinp(j,i) = uoptp(k,j,i) 250 end do 251 end if 252 end do 253 end do 254 allocate (usum(3,n)) 255 allocate (usump(3,n)) 256 do i = 1, npole 257 if (douind(ipole(i))) then 258 do j = 1, 3 259 uind(j,i) = 0.0d0 260 uinp(j,i) = 0.0d0 261 usum(j,i) = 0.0d0 262 usump(j,i) = 0.0d0 263 do k = 0, optorder 264 usum(j,i) = usum(j,i) + uopt(k,j,i) 265 usump(j,i) = usump(j,i) + uoptp(k,j,i) 266 uind(j,i) = uind(j,i) + copt(k)*usum(j,i) 267 uinp(j,i) = uinp(j,i) + copt(k)*usump(j,i) 268 end do 269 end do 270 end if 271 end do 272 deallocate (usum) 273 deallocate (usump) 274 end if 275c 276c set tolerances for computation of mutual induced dipoles 277c 278 if (poltyp .eq. 'MUTUAL') then 279 done = .false. 280 miniter = min(3,npole) 281 maxiter = 100 282 iter = 0 283 polmin = 0.00000001d0 284 eps = 100.0d0 285c 286c estimate induced dipoles using a polynomial predictor 287c 288 if (use_pred .and. nualt.eq.maxualt) then 289 call ulspred 290 do i = 1, npole 291 do j = 1, 3 292 udsum = 0.0d0 293 upsum = 0.0d0 294 do k = 1, nualt-1 295 udsum = udsum + bpred(k)*udalt(k,j,i) 296 upsum = upsum + bpredp(k)*upalt(k,j,i) 297 end do 298 uind(j,i) = udsum 299 uinp(j,i) = upsum 300 end do 301 end do 302 end if 303c 304c estimate induced dipoles via inertial extended Lagrangian 305c 306 if (use_ielscf) then 307 do i = 1, npole 308 do j = 1, 3 309 uind(j,i) = uaux(j,i) 310 uinp(j,i) = upaux(j,i) 311 end do 312 end do 313 end if 314c 315c perform dynamic allocation of some local arrays 316c 317 allocate (poli(npole)) 318 allocate (rsd(3,npole)) 319 allocate (rsdp(3,npole)) 320 allocate (zrsd(3,npole)) 321 allocate (zrsdp(3,npole)) 322 allocate (conj(3,npole)) 323 allocate (conjp(3,npole)) 324 allocate (vec(3,npole)) 325 allocate (vecp(3,npole)) 326c 327c get the electrostatic field due to induced dipoles 328c 329 if (use_ewald) then 330 call ufield0c (field,fieldp) 331 else if (use_mlist) then 332 call ufield0b (field,fieldp) 333 else 334 call ufield0a (field,fieldp) 335 end if 336c 337c set initial values for the residual vector components 338c 339 do i = 1, npole 340 if (douind(ipole(i))) then 341 poli(i) = max(polmin,polarity(i)) 342 do j = 1, 3 343 if (pcgguess) then 344 rsd(j,i) = (udir(j,i)-uind(j,i))/poli(i) 345 & + field(j,i) 346 rsdp(j,i) = (udirp(j,i)-uinp(j,i))/poli(i) 347 & + fieldp(j,i) 348 else 349 rsd(j,i) = udir(j,i) / poli(i) 350 rsdp(j,i) = udirp(j,i) / poli(i) 351 end if 352 zrsd(j,i) = rsd(j,i) 353 zrsdp(j,i) = rsdp(j,i) 354 end do 355 else 356 do j = 1, 3 357 rsd(j,i) = 0.0d0 358 rsdp(j,i) = 0.0d0 359 zrsd(j,i) = 0.0d0 360 zrsdp(j,i) = 0.0d0 361 end do 362 end if 363 end do 364c 365c perform dynamic allocation of some global arrays 366c 367 if (pcgprec) then 368 if (.not. allocated(mindex)) allocate (mindex(npole)) 369 if (.not. allocated(minv)) allocate (minv(3*maxulst*npole)) 370c 371c apply a sparse matrix conjugate gradient preconditioner 372c 373 mode = 'BUILD' 374 if (use_mlist) then 375 call uscale0b (mode,rsd,rsdp,zrsd,zrsdp) 376 mode = 'APPLY' 377 call uscale0b (mode,rsd,rsdp,zrsd,zrsdp) 378 else 379 call uscale0a (mode,rsd,rsdp,zrsd,zrsdp) 380 mode = 'APPLY' 381 call uscale0a (mode,rsd,rsdp,zrsd,zrsdp) 382 end if 383 end if 384c 385c set the initial conjugate vector to be the residuals 386c 387 do i = 1, npole 388 if (douind(ipole(i))) then 389 do j = 1, 3 390 conj(j,i) = zrsd(j,i) 391 conjp(j,i) = zrsdp(j,i) 392 end do 393 end if 394 end do 395c 396c conjugate gradient iteration of the mutual induced dipoles 397c 398 do while (.not. done) 399 iter = iter + 1 400 do i = 1, npole 401 if (douind(ipole(i))) then 402 do j = 1, 3 403 vec(j,i) = uind(j,i) 404 vecp(j,i) = uinp(j,i) 405 uind(j,i) = conj(j,i) 406 uinp(j,i) = conjp(j,i) 407 end do 408 end if 409 end do 410 if (use_ewald) then 411 call ufield0c (field,fieldp) 412 else if (use_mlist) then 413 call ufield0b (field,fieldp) 414 else 415 call ufield0a (field,fieldp) 416 end if 417 do i = 1, npole 418 if (douind(ipole(i))) then 419 do j = 1, 3 420 uind(j,i) = vec(j,i) 421 uinp(j,i) = vecp(j,i) 422 vec(j,i) = conj(j,i)/poli(i) - field(j,i) 423 vecp(j,i) = conjp(j,i)/poli(i) - fieldp(j,i) 424 end do 425 end if 426 end do 427 a = 0.0d0 428 ap = 0.0d0 429 sum = 0.0d0 430 sump = 0.0d0 431 do i = 1, npole 432 if (douind(ipole(i))) then 433 do j = 1, 3 434 a = a + conj(j,i)*vec(j,i) 435 ap = ap + conjp(j,i)*vecp(j,i) 436 sum = sum + rsd(j,i)*zrsd(j,i) 437 sump = sump + rsdp(j,i)*zrsdp(j,i) 438 end do 439 end if 440 end do 441 if (a .ne. 0.0d0) a = sum / a 442 if (ap .ne. 0.0d0) ap = sump / ap 443 do i = 1, npole 444 if (douind(ipole(i))) then 445 do j = 1, 3 446 uind(j,i) = uind(j,i) + a*conj(j,i) 447 uinp(j,i) = uinp(j,i) + ap*conjp(j,i) 448 rsd(j,i) = rsd(j,i) - a*vec(j,i) 449 rsdp(j,i) = rsdp(j,i) - ap*vecp(j,i) 450 zrsd(j,i) = rsd(j,i) 451 zrsdp(j,i) = rsdp(j,i) 452 end do 453 end if 454 end do 455 if (pcgprec) then 456 if (use_mlist) then 457 call uscale0b (mode,rsd,rsdp,zrsd,zrsdp) 458 else 459 call uscale0a (mode,rsd,rsdp,zrsd,zrsdp) 460 end if 461 end if 462 b = 0.0d0 463 bp = 0.0d0 464 do i = 1, npole 465 if (douind(ipole(i))) then 466 do j = 1, 3 467 b = b + rsd(j,i)*zrsd(j,i) 468 bp = bp + rsdp(j,i)*zrsdp(j,i) 469 end do 470 end if 471 end do 472 if (sum .ne. 0.0d0) b = b / sum 473 if (sump .ne. 0.0d0) bp = bp / sump 474 epsd = 0.0d0 475 epsp = 0.0d0 476 do i = 1, npole 477 if (douind(ipole(i))) then 478 do j = 1, 3 479 conj(j,i) = zrsd(j,i) + b*conj(j,i) 480 conjp(j,i) = zrsdp(j,i) + bp*conjp(j,i) 481 epsd = epsd + rsd(j,i)*rsd(j,i) 482 epsp = epsp + rsdp(j,i)*rsdp(j,i) 483 end do 484 end if 485 end do 486c 487c check the convergence of the mutual induced dipoles 488c 489 epsold = eps 490 eps = max(epsd,epsp) 491 eps = debye * sqrt(eps/dble(npolar)) 492 if (debug) then 493 if (iter .eq. 1) then 494 write (iout,10) 495 10 format (/,' Determination of SCF Induced Dipole', 496 & ' Moments :', 497 & //,4x,'Iter',7x,'RMS Residual (Debye)',/) 498 end if 499 write (iout,20) iter,eps 500 20 format (i8,7x,f16.10) 501 end if 502 if (eps .lt. poleps) done = .true. 503 if (eps .gt. epsold) done = .true. 504 if (iter .lt. miniter) done = .false. 505 if (iter .ge. politer) done = .true. 506c 507c apply a "peek" iteration to the mutual induced dipoles 508c 509 if (done) then 510 do i = 1, npole 511 if (douind(ipole(i))) then 512 term = pcgpeek * poli(i) 513 do j = 1, 3 514 uind(j,i) = uind(j,i) + term*rsd(j,i) 515 uinp(j,i) = uinp(j,i) + term*rsdp(j,i) 516 end do 517 end if 518 end do 519 end if 520 end do 521c 522c perform deallocation of some local arrays 523c 524 deallocate (poli) 525 deallocate (rsd) 526 deallocate (rsdp) 527 deallocate (zrsd) 528 deallocate (zrsdp) 529 deallocate (conj) 530 deallocate (conjp) 531 deallocate (vec) 532 deallocate (vecp) 533c 534c print the results from the conjugate gradient iteration 535c 536 if (debug .or. polprt) then 537 write (iout,30) iter,eps 538 30 format (/,' Induced Dipoles :',4x,'Iterations',i5, 539 & 7x,'RMS Residual',f15.10) 540 end if 541c 542c terminate the calculation if dipoles fail to converge 543c 544 if (iter.ge.maxiter .or. eps.gt.epsold) then 545 write (iout,40) 546 40 format (/,' INDUCE -- Warning, Induced Dipoles', 547 & ' are not Converged') 548 call prterr 549 call fatal 550 end if 551 end if 552c 553c perform deallocation of some local arrays 554c 555 deallocate (field) 556 deallocate (fieldp) 557 return 558 end 559c 560c 561c ################################################################# 562c ## ## 563c ## subroutine dfield0a -- direct induction via double loop ## 564c ## ## 565c ################################################################# 566c 567c 568c "dfield0a" computes the direct electrostatic field due to 569c permanent multipole moments via a double loop 570c 571c 572 subroutine dfield0a (field,fieldp) 573 use atoms 574 use bound 575 use cell 576 use chgpen 577 use couple 578 use mplpot 579 use mpole 580 use polar 581 use polgrp 582 use polpot 583 use shunt 584 implicit none 585 integer i,j,k,m 586 integer ii,kk 587 real*8 xr,yr,zr 588 real*8 r,r2,rr3 589 real*8 rr5,rr7 590 real*8 rr3i,rr5i,rr7i 591 real*8 rr3k,rr5k,rr7k 592 real*8 ci,dix,diy,diz 593 real*8 qixx,qixy,qixz 594 real*8 qiyy,qiyz,qizz 595 real*8 ck,dkx,dky,dkz 596 real*8 qkxx,qkxy,qkxz 597 real*8 qkyy,qkyz,qkzz 598 real*8 dir,dkr 599 real*8 qix,qiy,qiz,qir 600 real*8 qkx,qky,qkz,qkr 601 real*8 corei,corek 602 real*8 vali,valk 603 real*8 alphai,alphak 604 real*8 fid(3),fkd(3) 605 real*8 fip(3),fkp(3) 606 real*8 dmpi(7),dmpk(7) 607 real*8 dmpik(7) 608 real*8, allocatable :: dscale(:) 609 real*8, allocatable :: pscale(:) 610 real*8 field(3,*) 611 real*8 fieldp(3,*) 612 character*6 mode 613c 614c 615c zero out the value of the field at each site 616c 617 do ii = 1, npole 618 do j = 1, 3 619 field(j,ii) = 0.0d0 620 fieldp(j,ii) = 0.0d0 621 end do 622 end do 623c 624c set the switching function coefficients 625c 626 mode = 'MPOLE' 627 call switch (mode) 628c 629c perform dynamic allocation of some local arrays 630c 631 allocate (dscale(n)) 632 allocate (pscale(n)) 633c 634c set array needed to scale atom and group interactions 635c 636 do i = 1, n 637 dscale(i) = 1.0d0 638 pscale(i) = 1.0d0 639 end do 640c 641c find the electrostatic field due to permanent multipoles 642c 643 do ii = 1, npole-1 644 i = ipole(ii) 645 ci = rpole(1,ii) 646 dix = rpole(2,ii) 647 diy = rpole(3,ii) 648 diz = rpole(4,ii) 649 qixx = rpole(5,ii) 650 qixy = rpole(6,ii) 651 qixz = rpole(7,ii) 652 qiyy = rpole(9,ii) 653 qiyz = rpole(10,ii) 654 qizz = rpole(13,ii) 655 if (use_chgpen) then 656 corei = pcore(ii) 657 vali = pval(ii) 658 alphai = palpha(ii) 659 end if 660c 661c set exclusion coefficients for connected atoms 662c 663 if (dpequal) then 664 do j = 1, n12(i) 665 pscale(i12(j,i)) = p2scale 666 do k = 1, np11(i) 667 if (i12(j,i) .eq. ip11(k,i)) 668 & pscale(i12(j,i)) = p2iscale 669 end do 670 dscale(i12(j,i)) = pscale(i12(j,i)) 671 end do 672 do j = 1, n13(i) 673 pscale(i13(j,i)) = p3scale 674 do k = 1, np11(i) 675 if (i13(j,i) .eq. ip11(k,i)) 676 & pscale(i13(j,i)) = p3iscale 677 end do 678 dscale(i13(j,i)) = pscale(i13(j,i)) 679 end do 680 do j = 1, n14(i) 681 pscale(i14(j,i)) = p4scale 682 do k = 1, np11(i) 683 if (i14(j,i) .eq. ip11(k,i)) 684 & pscale(i14(j,i)) = p4iscale 685 end do 686 dscale(i14(j,i)) = pscale(i14(j,i)) 687 end do 688 do j = 1, n15(i) 689 pscale(i15(j,i)) = p5scale 690 do k = 1, np11(i) 691 if (i15(j,i) .eq. ip11(k,i)) 692 & pscale(i15(j,i)) = p5iscale 693 end do 694 dscale(i15(j,i)) = pscale(i15(j,i)) 695 end do 696 else 697 do j = 1, n12(i) 698 pscale(i12(j,i)) = p2scale 699 do k = 1, np11(i) 700 if (i12(j,i) .eq. ip11(k,i)) 701 & pscale(i12(j,i)) = p2iscale 702 end do 703 end do 704 do j = 1, n13(i) 705 pscale(i13(j,i)) = p3scale 706 do k = 1, np11(i) 707 if (i13(j,i) .eq. ip11(k,i)) 708 & pscale(i13(j,i)) = p3iscale 709 end do 710 end do 711 do j = 1, n14(i) 712 pscale(i14(j,i)) = p4scale 713 do k = 1, np11(i) 714 if (i14(j,i) .eq. ip11(k,i)) 715 & pscale(i14(j,i)) = p4iscale 716 end do 717 end do 718 do j = 1, n15(i) 719 pscale(i15(j,i)) = p5scale 720 do k = 1, np11(i) 721 if (i15(j,i) .eq. ip11(k,i)) 722 & pscale(i15(j,i)) = p5iscale 723 end do 724 end do 725 do j = 1, np11(i) 726 dscale(ip11(j,i)) = d1scale 727 end do 728 do j = 1, np12(i) 729 dscale(ip12(j,i)) = d2scale 730 end do 731 do j = 1, np13(i) 732 dscale(ip13(j,i)) = d3scale 733 end do 734 do j = 1, np14(i) 735 dscale(ip14(j,i)) = d4scale 736 end do 737 end if 738c 739c evaluate all sites within the cutoff distance 740c 741 do kk = ii+1, npole 742 k = ipole(kk) 743 xr = x(k) - x(i) 744 yr = y(k) - y(i) 745 zr = z(k) - z(i) 746 if (use_bounds) call image (xr,yr,zr) 747 r2 = xr*xr + yr* yr + zr*zr 748 if (r2 .le. off2) then 749 r = sqrt(r2) 750 ck = rpole(1,kk) 751 dkx = rpole(2,kk) 752 dky = rpole(3,kk) 753 dkz = rpole(4,kk) 754 qkxx = rpole(5,kk) 755 qkxy = rpole(6,kk) 756 qkxz = rpole(7,kk) 757 qkyy = rpole(9,kk) 758 qkyz = rpole(10,kk) 759 qkzz = rpole(13,kk) 760c 761c intermediates involving moments and separation distance 762c 763 dir = dix*xr + diy*yr + diz*zr 764 qix = qixx*xr + qixy*yr + qixz*zr 765 qiy = qixy*xr + qiyy*yr + qiyz*zr 766 qiz = qixz*xr + qiyz*yr + qizz*zr 767 qir = qix*xr + qiy*yr + qiz*zr 768 dkr = dkx*xr + dky*yr + dkz*zr 769 qkx = qkxx*xr + qkxy*yr + qkxz*zr 770 qky = qkxy*xr + qkyy*yr + qkyz*zr 771 qkz = qkxz*xr + qkyz*yr + qkzz*zr 772 qkr = qkx*xr + qky*yr + qkz*zr 773c 774c find the field components for Thole polarization damping 775c 776 if (use_thole) then 777 call dampthole (ii,kk,7,r,dmpik) 778 rr3 = dmpik(3) / (r*r2) 779 rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) 780 rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2) 781 fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) 782 & - rr3*dkx + 2.0d0*rr5*qkx 783 fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) 784 & - rr3*dky + 2.0d0*rr5*qky 785 fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) 786 & - rr3*dkz + 2.0d0*rr5*qkz 787 fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) 788 & - rr3*dix - 2.0d0*rr5*qix 789 fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) 790 & - rr3*diy - 2.0d0*rr5*qiy 791 fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) 792 & - rr3*diz - 2.0d0*rr5*qiz 793c 794c find the field components for charge penetration damping 795c 796 else if (use_chgpen) then 797 corek = pcore(kk) 798 valk = pval(kk) 799 alphak = palpha(kk) 800 call dampdir (r,alphai,alphak,dmpi,dmpk) 801 rr3 = 1.0d0 / (r*r2) 802 rr5 = 3.0d0 * rr3 / r2 803 rr7 = 5.0d0 * rr5 / r2 804 rr3i = dmpi(3) * rr3 805 rr5i = dmpi(5) * rr5 806 rr7i = dmpi(7) * rr7 807 rr3k = dmpk(3) * rr3 808 rr5k = dmpk(5) * rr5 809 rr7k = dmpk(7) * rr7 810 fid(1) = -xr*(rr3*corek + rr3k*valk 811 & - rr5k*dkr + rr7k*qkr) 812 & - rr3k*dkx + 2.0d0*rr5k*qkx 813 fid(2) = -yr*(rr3*corek + rr3k*valk 814 & - rr5k*dkr + rr7k*qkr) 815 & - rr3k*dky + 2.0d0*rr5k*qky 816 fid(3) = -zr*(rr3*corek + rr3k*valk 817 & - rr5k*dkr + rr7k*qkr) 818 & - rr3k*dkz + 2.0d0*rr5k*qkz 819 fkd(1) = xr*(rr3*corei + rr3i*vali 820 & + rr5i*dir + rr7i*qir) 821 & - rr3i*dix - 2.0d0*rr5i*qix 822 fkd(2) = yr*(rr3*corei + rr3i*vali 823 & + rr5i*dir + rr7i*qir) 824 & - rr3i*diy - 2.0d0*rr5i*qiy 825 fkd(3) = zr*(rr3*corei + rr3i*vali 826 & + rr5i*dir + rr7i*qir) 827 & - rr3i*diz - 2.0d0*rr5i*qiz 828 end if 829c 830c increment the direct electrostatic field components 831c 832 do j = 1, 3 833 field(j,ii) = field(j,ii) + fid(j)*dscale(k) 834 field(j,kk) = field(j,kk) + fkd(j)*dscale(k) 835 fieldp(j,ii) = fieldp(j,ii) + fid(j)*pscale(k) 836 fieldp(j,kk) = fieldp(j,kk) + fkd(j)*pscale(k) 837 end do 838 end if 839 end do 840c 841c reset exclusion coefficients for connected atoms 842c 843 if (dpequal) then 844 do j = 1, n12(i) 845 pscale(i12(j,i)) = 1.0d0 846 dscale(i12(j,i)) = 1.0d0 847 end do 848 do j = 1, n13(i) 849 pscale(i13(j,i)) = 1.0d0 850 dscale(i13(j,i)) = 1.0d0 851 end do 852 do j = 1, n14(i) 853 pscale(i14(j,i)) = 1.0d0 854 dscale(i14(j,i)) = 1.0d0 855 end do 856 do j = 1, n15(i) 857 pscale(i15(j,i)) = 1.0d0 858 dscale(i15(j,i)) = 1.0d0 859 end do 860 else 861 do j = 1, n12(i) 862 pscale(i12(j,i)) = 1.0d0 863 end do 864 do j = 1, n13(i) 865 pscale(i13(j,i)) = 1.0d0 866 end do 867 do j = 1, n14(i) 868 pscale(i14(j,i)) = 1.0d0 869 end do 870 do j = 1, n15(i) 871 pscale(i15(j,i)) = 1.0d0 872 end do 873 do j = 1, np11(i) 874 dscale(ip11(j,i)) = 1.0d0 875 end do 876 do j = 1, np12(i) 877 dscale(ip12(j,i)) = 1.0d0 878 end do 879 do j = 1, np13(i) 880 dscale(ip13(j,i)) = 1.0d0 881 end do 882 do j = 1, np14(i) 883 dscale(ip14(j,i)) = 1.0d0 884 end do 885 end if 886 end do 887c 888c periodic boundary for large cutoffs via replicates method 889c 890 if (use_replica) then 891 do ii = 1, npole 892 i = ipole(ii) 893 ci = rpole(1,ii) 894 dix = rpole(2,ii) 895 diy = rpole(3,ii) 896 diz = rpole(4,ii) 897 qixx = rpole(5,ii) 898 qixy = rpole(6,ii) 899 qixz = rpole(7,ii) 900 qiyy = rpole(9,ii) 901 qiyz = rpole(10,ii) 902 qizz = rpole(13,ii) 903 if (use_chgpen) then 904 corei = pcore(ii) 905 vali = pval(ii) 906 alphai = palpha(ii) 907 end if 908c 909c set exclusion coefficients for connected atoms 910c 911 if (dpequal) then 912 do j = 1, n12(i) 913 pscale(i12(j,i)) = p2scale 914 do k = 1, np11(i) 915 if (i12(j,i) .eq. ip11(k,i)) 916 & pscale(i12(j,i)) = p2iscale 917 end do 918 dscale(i12(j,i)) = pscale(i12(j,i)) 919 end do 920 do j = 1, n13(i) 921 pscale(i13(j,i)) = p3scale 922 do k = 1, np11(i) 923 if (i13(j,i) .eq. ip11(k,i)) 924 & pscale(i13(j,i)) = p3iscale 925 end do 926 dscale(i13(j,i)) = pscale(i13(j,i)) 927 end do 928 do j = 1, n14(i) 929 pscale(i14(j,i)) = p4scale 930 do k = 1, np11(i) 931 if (i14(j,i) .eq. ip11(k,i)) 932 & pscale(i14(j,i)) = p4iscale 933 end do 934 dscale(i14(j,i)) = pscale(i14(j,i)) 935 end do 936 do j = 1, n15(i) 937 pscale(i15(j,i)) = p5scale 938 do k = 1, np11(i) 939 if (i15(j,i) .eq. ip11(k,i)) 940 & pscale(i15(j,i)) = p5iscale 941 end do 942 dscale(i15(j,i)) = pscale(i15(j,i)) 943 end do 944 else 945 do j = 1, n12(i) 946 pscale(i12(j,i)) = p2scale 947 do k = 1, np11(i) 948 if (i12(j,i) .eq. ip11(k,i)) 949 & pscale(i12(j,i)) = p2iscale 950 end do 951 end do 952 do j = 1, n13(i) 953 pscale(i13(j,i)) = p3scale 954 do k = 1, np11(i) 955 if (i13(j,i) .eq. ip11(k,i)) 956 & pscale(i13(j,i)) = p3iscale 957 end do 958 end do 959 do j = 1, n14(i) 960 pscale(i14(j,i)) = p4scale 961 do k = 1, np11(i) 962 if (i14(j,i) .eq. ip11(k,i)) 963 & pscale(i14(j,i)) = p4iscale 964 end do 965 end do 966 do j = 1, n15(i) 967 pscale(i15(j,i)) = p5scale 968 do k = 1, np11(i) 969 if (i15(j,i) .eq. ip11(k,i)) 970 & pscale(i15(j,i)) = p5iscale 971 end do 972 end do 973 do j = 1, np11(i) 974 dscale(ip11(j,i)) = d1scale 975 end do 976 do j = 1, np12(i) 977 dscale(ip12(j,i)) = d2scale 978 end do 979 do j = 1, np13(i) 980 dscale(ip13(j,i)) = d3scale 981 end do 982 do j = 1, np14(i) 983 dscale(ip14(j,i)) = d4scale 984 end do 985 end if 986c 987c evaluate all sites within the cutoff distance 988c 989 do kk = ii, npole 990 k = ipole(kk) 991 ck = rpole(1,kk) 992 dkx = rpole(2,kk) 993 dky = rpole(3,kk) 994 dkz = rpole(4,kk) 995 qkxx = rpole(5,kk) 996 qkxy = rpole(6,kk) 997 qkxz = rpole(7,kk) 998 qkyy = rpole(9,kk) 999 qkyz = rpole(10,kk) 1000 qkzz = rpole(13,kk) 1001 do m = 2, ncell 1002 xr = x(k) - x(i) 1003 yr = y(k) - y(i) 1004 zr = z(k) - z(i) 1005 call imager (xr,yr,zr,m) 1006 r2 = xr*xr + yr* yr + zr*zr 1007 if (r2 .le. off2) then 1008 r = sqrt(r2) 1009c 1010c intermediates involving moments and separation distance 1011c 1012 dir = dix*xr + diy*yr + diz*zr 1013 qix = qixx*xr + qixy*yr + qixz*zr 1014 qiy = qixy*xr + qiyy*yr + qiyz*zr 1015 qiz = qixz*xr + qiyz*yr + qizz*zr 1016 qir = qix*xr + qiy*yr + qiz*zr 1017 dkr = dkx*xr + dky*yr + dkz*zr 1018 qkx = qkxx*xr + qkxy*yr + qkxz*zr 1019 qky = qkxy*xr + qkyy*yr + qkyz*zr 1020 qkz = qkxz*xr + qkyz*yr + qkzz*zr 1021 qkr = qkx*xr + qky*yr + qkz*zr 1022c 1023c find the field components for Thole polarization damping 1024c 1025 if (use_thole) then 1026 call dampthole (ii,kk,7,r,dmpik) 1027 rr3 = dmpik(3) / (r*r2) 1028 rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) 1029 rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2) 1030 fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) 1031 & - rr3*dkx + 2.0d0*rr5*qkx 1032 fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) 1033 & - rr3*dky + 2.0d0*rr5*qky 1034 fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) 1035 & - rr3*dkz + 2.0d0*rr5*qkz 1036 fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) 1037 & - rr3*dix - 2.0d0*rr5*qix 1038 fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) 1039 & - rr3*diy - 2.0d0*rr5*qiy 1040 fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) 1041 & - rr3*diz - 2.0d0*rr5*qiz 1042c 1043c find the field components for charge penetration damping 1044c 1045 else if (use_chgpen) then 1046 corek = pcore(kk) 1047 valk = pval(kk) 1048 alphak = palpha(kk) 1049 call dampdir (r,alphai,alphak,dmpi,dmpk) 1050 rr3 = 1.0d0 / (r*r2) 1051 rr5 = 3.0d0 * rr3 / r2 1052 rr7 = 5.0d0 * rr5 / r2 1053 rr3i = dmpi(3) * rr3 1054 rr5i = dmpi(5) * rr5 1055 rr7i = dmpi(7) * rr7 1056 rr3k = dmpk(3) * rr3 1057 rr5k = dmpk(5) * rr5 1058 rr7k = dmpk(7) * rr7 1059 fid(1) = -xr*(rr3*corek + rr3k*valk 1060 & - rr5k*dkr + rr7k*qkr) 1061 & - rr3k*dkx + 2.0d0*rr5k*qkx 1062 fid(2) = -yr*(rr3*corek + rr3k*valk 1063 & - rr5k*dkr+rr7k*qkr) 1064 & - rr3k*dky + 2.0d0*rr5k*qky 1065 fid(3) = -zr*(rr3*corek + rr3k*valk 1066 & - rr5k*dkr+rr7k*qkr) 1067 & - rr3k*dkz + 2.0d0*rr5k*qkz 1068 fkd(1) = xr*(rr3*corei + rr3i*vali 1069 & + rr5i*dir + rr7i*qir) 1070 & - rr3i*dix - 2.0d0*rr5i*qix 1071 fkd(2) = yr*(rr3*corei + rr3i*vali 1072 & + rr5i*dir + rr7i*qir) 1073 & - rr3i*diy - 2.0d0*rr5i*qiy 1074 fkd(3) = zr*(rr3*corei + rr3i*vali 1075 & + rr5i*dir + rr7i*qir) 1076 & - rr3i*diz - 2.0d0*rr5i*qiz 1077 end if 1078c 1079c increment the direct electrostatic field components 1080c 1081 do j = 1, 3 1082 fip(j) = fid(j) 1083 fkp(j) = fkd(j) 1084 end do 1085 if (use_polymer .and. r2.le.polycut2) then 1086 do j = 1, 3 1087 fid(j) = fid(j) * dscale(k) 1088 fip(j) = fip(j) * pscale(k) 1089 fkd(j) = fkd(j) * dscale(k) 1090 fkp(j) = fkp(j) * pscale(k) 1091 end do 1092 end if 1093 do j = 1, 3 1094 field(j,ii) = field(j,ii) + fid(j) 1095 fieldp(j,ii) = fieldp(j,ii) + fip(j) 1096 if (i .ne. k) then 1097 field(j,kk) = field(j,kk) + fkd(j) 1098 fieldp(j,kk) = fieldp(j,kk) + fkp(j) 1099 end if 1100 end do 1101 end if 1102 end do 1103 end do 1104c 1105c reset exclusion coefficients for connected atoms 1106c 1107 if (dpequal) then 1108 do j = 1, n12(i) 1109 pscale(i12(j,i)) = 1.0d0 1110 dscale(i12(j,i)) = 1.0d0 1111 end do 1112 do j = 1, n13(i) 1113 pscale(i13(j,i)) = 1.0d0 1114 dscale(i13(j,i)) = 1.0d0 1115 end do 1116 do j = 1, n14(i) 1117 pscale(i14(j,i)) = 1.0d0 1118 dscale(i14(j,i)) = 1.0d0 1119 end do 1120 do j = 1, n15(i) 1121 pscale(i15(j,i)) = 1.0d0 1122 dscale(i15(j,i)) = 1.0d0 1123 end do 1124 else 1125 do j = 1, n12(i) 1126 pscale(i12(j,i)) = 1.0d0 1127 end do 1128 do j = 1, n13(i) 1129 pscale(i13(j,i)) = 1.0d0 1130 end do 1131 do j = 1, n14(i) 1132 pscale(i14(j,i)) = 1.0d0 1133 end do 1134 do j = 1, n15(i) 1135 pscale(i15(j,i)) = 1.0d0 1136 end do 1137 do j = 1, np11(i) 1138 dscale(ip11(j,i)) = 1.0d0 1139 end do 1140 do j = 1, np12(i) 1141 dscale(ip12(j,i)) = 1.0d0 1142 end do 1143 do j = 1, np13(i) 1144 dscale(ip13(j,i)) = 1.0d0 1145 end do 1146 do j = 1, np14(i) 1147 dscale(ip14(j,i)) = 1.0d0 1148 end do 1149 end if 1150 end do 1151 end if 1152c 1153c perform deallocation of some local arrays 1154c 1155 deallocate (dscale) 1156 deallocate (pscale) 1157 return 1158 end 1159c 1160c 1161c ################################################################# 1162c ## ## 1163c ## subroutine ufield0a -- mutual induction via double loop ## 1164c ## ## 1165c ################################################################# 1166c 1167c 1168c "ufield0a" computes the mutual electrostatic field due to 1169c induced dipole moments via a double loop 1170c 1171c 1172 subroutine ufield0a (field,fieldp) 1173 use atoms 1174 use bound 1175 use cell 1176 use chgpen 1177 use couple 1178 use mplpot 1179 use mpole 1180 use polar 1181 use polgrp 1182 use polpot 1183 use shunt 1184 implicit none 1185 integer i,j,k,m 1186 integer ii,kk 1187 real*8 xr,yr,zr 1188 real*8 r,r2,rr3,rr5 1189 real*8 dix,diy,diz 1190 real*8 pix,piy,piz 1191 real*8 dkx,dky,dkz 1192 real*8 pkx,pky,pkz 1193 real*8 dir,pir 1194 real*8 dkr,pkr 1195 real*8 corei,corek 1196 real*8 vali,valk 1197 real*8 alphai,alphak 1198 real*8 fid(3),fkd(3) 1199 real*8 fip(3),fkp(3) 1200 real*8 dmpik(5) 1201 real*8, allocatable :: uscale(:) 1202 real*8, allocatable :: wscale(:) 1203 real*8 field(3,*) 1204 real*8 fieldp(3,*) 1205 character*6 mode 1206c 1207c 1208c zero out the value of the field at each site 1209c 1210 do ii = 1, npole 1211 do j = 1, 3 1212 field(j,ii) = 0.0d0 1213 fieldp(j,ii) = 0.0d0 1214 end do 1215 end do 1216c 1217c set the switching function coefficients 1218c 1219 mode = 'MPOLE' 1220 call switch (mode) 1221c 1222c perform dynamic allocation of some local arrays 1223c 1224 allocate (uscale(n)) 1225 allocate (wscale(n)) 1226c 1227c set array needed to scale atom and group interactions 1228c 1229 do i = 1, n 1230 uscale(i) = 1.0d0 1231 wscale(i) = 1.0d0 1232 end do 1233c 1234c find the electrostatic field due to mutual induced dipoles 1235c 1236 do ii = 1, npole-1 1237 i = ipole(ii) 1238 dix = uind(1,ii) 1239 diy = uind(2,ii) 1240 diz = uind(3,ii) 1241 pix = uinp(1,ii) 1242 piy = uinp(2,ii) 1243 piz = uinp(3,ii) 1244 if (use_chgpen) then 1245 corei = pcore(ii) 1246 vali = pval(ii) 1247 alphai = palpha(ii) 1248 end if 1249c 1250c set exclusion coefficients for connected atoms 1251c 1252 do j = 1, np11(i) 1253 uscale(ip11(j,i)) = u1scale 1254 end do 1255 do j = 1, np12(i) 1256 uscale(ip12(j,i)) = u2scale 1257 end do 1258 do j = 1, np13(i) 1259 uscale(ip13(j,i)) = u3scale 1260 end do 1261 do j = 1, np14(i) 1262 uscale(ip14(j,i)) = u4scale 1263 end do 1264 do j = 1, n12(i) 1265 wscale(i12(j,i)) = w2scale 1266 end do 1267 do j = 1, n13(i) 1268 wscale(i13(j,i)) = w3scale 1269 end do 1270 do j = 1, n14(i) 1271 wscale(i14(j,i)) = w4scale 1272 end do 1273 do j = 1, n15(i) 1274 wscale(i15(j,i)) = w5scale 1275 end do 1276c 1277c evaluate all sites within the cutoff distance 1278c 1279 do kk = ii+1, npole 1280 k = ipole(kk) 1281 xr = x(k) - x(i) 1282 yr = y(k) - y(i) 1283 zr = z(k) - z(i) 1284 if (use_bounds) call image (xr,yr,zr) 1285 r2 = xr*xr + yr* yr + zr*zr 1286 if (r2 .le. off2) then 1287 r = sqrt(r2) 1288 dkx = uind(1,kk) 1289 dky = uind(2,kk) 1290 dkz = uind(3,kk) 1291 pkx = uinp(1,kk) 1292 pky = uinp(2,kk) 1293 pkz = uinp(3,kk) 1294c 1295c intermediates involving moments and separation distance 1296c 1297 dir = dix*xr + diy*yr + diz*zr 1298 dkr = dkx*xr + dky*yr + dkz*zr 1299 pir = pix*xr + piy*yr + piz*zr 1300 pkr = pkx*xr + pky*yr + pkz*zr 1301c 1302c find the scale factors for Thole polarization damping 1303c 1304 if (use_thole) then 1305 call dampthole2 (ii,kk,5,r,dmpik) 1306 dmpik(3) = uscale(k) * dmpik(3) 1307 dmpik(5) = uscale(k) * dmpik(5) 1308c 1309c find the scale factors for charge penetration damping 1310c 1311 else if (use_chgpen) then 1312 corek = pcore(kk) 1313 valk = pval(kk) 1314 alphak = palpha(kk) 1315 call dampmut (r,alphai,alphak,dmpik) 1316 dmpik(3) = wscale(k) * dmpik(3) 1317 dmpik(5) = wscale(k) * dmpik(5) 1318 end if 1319c 1320c increment the mutual electrostatic field components 1321c 1322 rr3 = -dmpik(3) / (r*r2) 1323 rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) 1324 fid(1) = rr3*dkx + rr5*dkr*xr 1325 fid(2) = rr3*dky + rr5*dkr*yr 1326 fid(3) = rr3*dkz + rr5*dkr*zr 1327 fkd(1) = rr3*dix + rr5*dir*xr 1328 fkd(2) = rr3*diy + rr5*dir*yr 1329 fkd(3) = rr3*diz + rr5*dir*zr 1330 fip(1) = rr3*pkx + rr5*pkr*xr 1331 fip(2) = rr3*pky + rr5*pkr*yr 1332 fip(3) = rr3*pkz + rr5*pkr*zr 1333 fkp(1) = rr3*pix + rr5*pir*xr 1334 fkp(2) = rr3*piy + rr5*pir*yr 1335 fkp(3) = rr3*piz + rr5*pir*zr 1336 do j = 1, 3 1337 field(j,ii) = field(j,ii) + fid(j) 1338 field(j,kk) = field(j,kk) + fkd(j) 1339 fieldp(j,ii) = fieldp(j,ii) + fip(j) 1340 fieldp(j,kk) = fieldp(j,kk) + fkp(j) 1341 end do 1342 end if 1343 end do 1344c 1345c reset exclusion coefficients for connected atoms 1346c 1347 do j = 1, np11(i) 1348 uscale(ip11(j,i)) = 1.0d0 1349 end do 1350 do j = 1, np12(i) 1351 uscale(ip12(j,i)) = 1.0d0 1352 end do 1353 do j = 1, np13(i) 1354 uscale(ip13(j,i)) = 1.0d0 1355 end do 1356 do j = 1, np14(i) 1357 uscale(ip14(j,i)) = 1.0d0 1358 end do 1359 do j = 1, n12(i) 1360 wscale(i12(j,i)) = 1.0d0 1361 end do 1362 do j = 1, n13(i) 1363 wscale(i13(j,i)) = 1.0d0 1364 end do 1365 do j = 1, n14(i) 1366 wscale(i14(j,i)) = 1.0d0 1367 end do 1368 do j = 1, n15(i) 1369 wscale(i15(j,i)) = 1.0d0 1370 end do 1371 end do 1372c 1373c periodic boundary for large cutoffs via replicates method 1374c 1375 if (use_replica) then 1376 do ii = 1, npole 1377 i = ipole(ii) 1378 dix = uind(1,ii) 1379 diy = uind(2,ii) 1380 diz = uind(3,ii) 1381 pix = uinp(1,ii) 1382 piy = uinp(2,ii) 1383 piz = uinp(3,ii) 1384 if (use_chgpen) then 1385 corei = pcore(ii) 1386 vali = pval(ii) 1387 alphai = palpha(ii) 1388 end if 1389c 1390c set exclusion coefficients for connected atoms 1391c 1392 do j = 1, np11(i) 1393 uscale(ip11(j,i)) = u1scale 1394 end do 1395 do j = 1, np12(i) 1396 uscale(ip12(j,i)) = u2scale 1397 end do 1398 do j = 1, np13(i) 1399 uscale(ip13(j,i)) = u3scale 1400 end do 1401 do j = 1, np14(i) 1402 uscale(ip14(j,i)) = u4scale 1403 end do 1404 do j = 1, n12(i) 1405 wscale(i12(j,i)) = w2scale 1406 end do 1407 do j = 1, n13(i) 1408 wscale(i13(j,i)) = w3scale 1409 end do 1410 do j = 1, n14(i) 1411 wscale(i14(j,i)) = w4scale 1412 end do 1413 do j = 1, n15(i) 1414 wscale(i15(j,i)) = w5scale 1415 end do 1416c 1417c evaluate all sites within the cutoff distance 1418c 1419 do kk = ii, npole 1420 k = ipole(kk) 1421 dkx = uind(1,kk) 1422 dky = uind(2,kk) 1423 dkz = uind(3,kk) 1424 pkx = uinp(1,kk) 1425 pky = uinp(2,kk) 1426 pkz = uinp(3,kk) 1427 do m = 2, ncell 1428 xr = x(k) - x(i) 1429 yr = y(k) - y(i) 1430 zr = z(k) - z(i) 1431 call imager (xr,yr,zr,m) 1432 r2 = xr*xr + yr* yr + zr*zr 1433 if (r2 .le. off2) then 1434 r = sqrt(r2) 1435c 1436c intermediates involving moments and separation distance 1437c 1438 dir = dix*xr + diy*yr + diz*zr 1439 dkr = dkx*xr + dky*yr + dkz*zr 1440 pir = pix*xr + piy*yr + piz*zr 1441 pkr = pkx*xr + pky*yr + pkz*zr 1442c 1443c find the scale factors for Thole polarization damping 1444c 1445 if (use_thole) then 1446 call dampthole2 (ii,kk,5,r,dmpik) 1447 dmpik(3) = uscale(k) * dmpik(3) 1448 dmpik(5) = uscale(k) * dmpik(5) 1449c 1450c find the scale factors for charge penetration damping 1451c 1452 else if (use_chgpen) then 1453 corek = pcore(kk) 1454 valk = pval(kk) 1455 alphak = palpha(kk) 1456 call dampmut (r,alphai,alphak,dmpik) 1457 dmpik(3) = wscale(k) * dmpik(3) 1458 dmpik(5) = wscale(k) * dmpik(5) 1459 end if 1460c 1461c increment the mutual electrostatic field components 1462c 1463 rr3 = -dmpik(3) / (r*r2) 1464 rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) 1465 fid(1) = rr3*dkx + rr5*dkr*xr 1466 fid(2) = rr3*dky + rr5*dkr*yr 1467 fid(3) = rr3*dkz + rr5*dkr*zr 1468 fkd(1) = rr3*dix + rr5*dir*xr 1469 fkd(2) = rr3*diy + rr5*dir*yr 1470 fkd(3) = rr3*diz + rr5*dir*zr 1471 fip(1) = rr3*pkx + rr5*pkr*xr 1472 fip(2) = rr3*pky + rr5*pkr*yr 1473 fip(3) = rr3*pkz + rr5*pkr*zr 1474 fkp(1) = rr3*pix + rr5*pir*xr 1475 fkp(2) = rr3*piy + rr5*pir*yr 1476 fkp(3) = rr3*piz + rr5*pir*zr 1477 if (use_polymer) then 1478 if (r2 .le. polycut2) then 1479 do j = 1, 3 1480 fid(j) = fid(j) * uscale(k) 1481 fkd(j) = fkd(j) * uscale(k) 1482 fip(j) = fip(j) * uscale(k) 1483 fkp(j) = fkp(j) * uscale(k) 1484 end do 1485 end if 1486 end if 1487 do j = 1, 3 1488 field(j,ii) = field(j,ii) + fid(j) 1489 fieldp(j,ii) = fieldp(j,ii) + fip(j) 1490 if (ii .ne. kk) then 1491 field(j,kk) = field(j,kk) + fkd(j) 1492 fieldp(j,kk) = fieldp(j,kk) + fkp(j) 1493 end if 1494 end do 1495 end if 1496 end do 1497 end do 1498c 1499c reset exclusion coefficients for connected atoms 1500c 1501 do j = 1, np11(i) 1502 uscale(ip11(j,i)) = 1.0d0 1503 end do 1504 do j = 1, np12(i) 1505 uscale(ip12(j,i)) = 1.0d0 1506 end do 1507 do j = 1, np13(i) 1508 uscale(ip13(j,i)) = 1.0d0 1509 end do 1510 do j = 1, np14(i) 1511 uscale(ip14(j,i)) = 1.0d0 1512 end do 1513 do j = 1, n12(i) 1514 wscale(i12(j,i)) = 1.0d0 1515 end do 1516 do j = 1, n13(i) 1517 wscale(i13(j,i)) = 1.0d0 1518 end do 1519 do j = 1, n14(i) 1520 wscale(i14(j,i)) = 1.0d0 1521 end do 1522 do j = 1, n15(i) 1523 wscale(i15(j,i)) = 1.0d0 1524 end do 1525 end do 1526 end if 1527c 1528c perform deallocation of some local arrays 1529c 1530 deallocate (uscale) 1531 deallocate (wscale) 1532 return 1533 end 1534c 1535c 1536c ############################################################### 1537c ## ## 1538c ## subroutine dfield0b -- direct induction via pair list ## 1539c ## ## 1540c ############################################################### 1541c 1542c 1543c "dfield0b" computes the direct electrostatic field due to 1544c permanent multipole moments via a pair list 1545c 1546c 1547 subroutine dfield0b (field,fieldp) 1548 use atoms 1549 use bound 1550 use chgpen 1551 use couple 1552 use mplpot 1553 use mpole 1554 use neigh 1555 use polar 1556 use polgrp 1557 use polpot 1558 use shunt 1559 implicit none 1560 integer i,j,k 1561 integer ii,kk,kkk 1562 real*8 xr,yr,zr 1563 real*8 r,r2,rr3 1564 real*8 rr5,rr7 1565 real*8 rr3i,rr5i,rr7i 1566 real*8 rr3k,rr5k,rr7k 1567 real*8 ci,dix,diy,diz 1568 real*8 qixx,qixy,qixz 1569 real*8 qiyy,qiyz,qizz 1570 real*8 ck,dkx,dky,dkz 1571 real*8 qkxx,qkxy,qkxz 1572 real*8 qkyy,qkyz,qkzz 1573 real*8 dir,dkr 1574 real*8 qix,qiy,qiz,qir 1575 real*8 qkx,qky,qkz,qkr 1576 real*8 corei,corek 1577 real*8 vali,valk 1578 real*8 alphai,alphak 1579 real*8 fid(3),fkd(3) 1580 real*8 dmpi(7),dmpk(7) 1581 real*8 dmpik(7) 1582 real*8, allocatable :: dscale(:) 1583 real*8, allocatable :: pscale(:) 1584 real*8 field(3,*) 1585 real*8 fieldp(3,*) 1586 real*8, allocatable :: fieldt(:,:) 1587 real*8, allocatable :: fieldtp(:,:) 1588 character*6 mode 1589c 1590c 1591c set the switching function coefficients 1592c 1593 mode = 'MPOLE' 1594 call switch (mode) 1595c 1596c perform dynamic allocation of some local arrays 1597c 1598 allocate (dscale(n)) 1599 allocate (pscale(n)) 1600 allocate (fieldt(3,npole)) 1601 allocate (fieldtp(3,npole)) 1602c 1603c set array needed to scale connected atom interactions 1604c 1605 do i = 1, n 1606 dscale(i) = 1.0d0 1607 pscale(i) = 1.0d0 1608 end do 1609c 1610c initialize local variables for OpenMP calculation 1611c 1612 do ii = 1, npole 1613 do j = 1, 3 1614 fieldt(j,ii) = 0.0d0 1615 fieldtp(j,ii) = 0.0d0 1616 end do 1617 end do 1618c 1619c OpenMP directives for the major loop structure 1620c 1621!$OMP PARALLEL default(private) 1622!$OMP& shared(npole,ipole,rpole,x,y,z,pcore,pval,palpha,n12,i12, 1623!$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14, 1624!$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale, 1625!$OMP& p5iscale,d1scale,d2scale,d3scale,d4scale,nelst,elst,dpequal, 1626!$OMP& use_thole,use_chgpen,use_bounds,off2,field,fieldp) 1627!$OMP& firstprivate(dscale,pscale) shared (fieldt,fieldtp) 1628!$OMP DO reduction(+:fieldt,fieldtp) schedule(guided) 1629c 1630c find the electrostatic field due to permanent multipoles 1631c 1632 do ii = 1, npole 1633 i = ipole(ii) 1634 ci = rpole(1,ii) 1635 dix = rpole(2,ii) 1636 diy = rpole(3,ii) 1637 diz = rpole(4,ii) 1638 qixx = rpole(5,ii) 1639 qixy = rpole(6,ii) 1640 qixz = rpole(7,ii) 1641 qiyy = rpole(9,ii) 1642 qiyz = rpole(10,ii) 1643 qizz = rpole(13,ii) 1644 if (use_chgpen) then 1645 corei = pcore(ii) 1646 vali = pval(ii) 1647 alphai = palpha(ii) 1648 end if 1649c 1650c set exclusion coefficients for connected atoms 1651c 1652 if (dpequal) then 1653 do j = 1, n12(i) 1654 pscale(i12(j,i)) = p2scale 1655 do k = 1, np11(i) 1656 if (i12(j,i) .eq. ip11(k,i)) 1657 & pscale(i12(j,i)) = p2iscale 1658 end do 1659 dscale(i12(j,i)) = pscale(i12(j,i)) 1660 end do 1661 do j = 1, n13(i) 1662 pscale(i13(j,i)) = p3scale 1663 do k = 1, np11(i) 1664 if (i13(j,i) .eq. ip11(k,i)) 1665 & pscale(i13(j,i)) = p3iscale 1666 end do 1667 dscale(i13(j,i)) = pscale(i13(j,i)) 1668 end do 1669 do j = 1, n14(i) 1670 pscale(i14(j,i)) = p4scale 1671 do k = 1, np11(i) 1672 if (i14(j,i) .eq. ip11(k,i)) 1673 & pscale(i14(j,i)) = p4iscale 1674 end do 1675 dscale(i14(j,i)) = pscale(i14(j,i)) 1676 end do 1677 do j = 1, n15(i) 1678 pscale(i15(j,i)) = p5scale 1679 do k = 1, np11(i) 1680 if (i15(j,i) .eq. ip11(k,i)) 1681 & pscale(i15(j,i)) = p5iscale 1682 end do 1683 dscale(i15(j,i)) = pscale(i15(j,i)) 1684 end do 1685 else 1686 do j = 1, n12(i) 1687 pscale(i12(j,i)) = p2scale 1688 do k = 1, np11(i) 1689 if (i12(j,i) .eq. ip11(k,i)) 1690 & pscale(i12(j,i)) = p2iscale 1691 end do 1692 end do 1693 do j = 1, n13(i) 1694 pscale(i13(j,i)) = p3scale 1695 do k = 1, np11(i) 1696 if (i13(j,i) .eq. ip11(k,i)) 1697 & pscale(i13(j,i)) = p3iscale 1698 end do 1699 end do 1700 do j = 1, n14(i) 1701 pscale(i14(j,i)) = p4scale 1702 do k = 1, np11(i) 1703 if (i14(j,i) .eq. ip11(k,i)) 1704 & pscale(i14(j,i)) = p4iscale 1705 end do 1706 end do 1707 do j = 1, n15(i) 1708 pscale(i15(j,i)) = p5scale 1709 do k = 1, np11(i) 1710 if (i15(j,i) .eq. ip11(k,i)) 1711 & pscale(i15(j,i)) = p5iscale 1712 end do 1713 end do 1714 do j = 1, np11(i) 1715 dscale(ip11(j,i)) = d1scale 1716 end do 1717 do j = 1, np12(i) 1718 dscale(ip12(j,i)) = d2scale 1719 end do 1720 do j = 1, np13(i) 1721 dscale(ip13(j,i)) = d3scale 1722 end do 1723 do j = 1, np14(i) 1724 dscale(ip14(j,i)) = d4scale 1725 end do 1726 end if 1727c 1728c evaluate all sites within the cutoff distance 1729c 1730 do kkk = 1, nelst(ii) 1731 kk = elst(kkk,ii) 1732 k = ipole(kk) 1733 xr = x(k) - x(i) 1734 yr = y(k) - y(i) 1735 zr = z(k) - z(i) 1736 if (use_bounds) call image (xr,yr,zr) 1737 r2 = xr*xr + yr* yr + zr*zr 1738 if (r2 .le. off2) then 1739 r = sqrt(r2) 1740 ck = rpole(1,kk) 1741 dkx = rpole(2,kk) 1742 dky = rpole(3,kk) 1743 dkz = rpole(4,kk) 1744 qkxx = rpole(5,kk) 1745 qkxy = rpole(6,kk) 1746 qkxz = rpole(7,kk) 1747 qkyy = rpole(9,kk) 1748 qkyz = rpole(10,kk) 1749 qkzz = rpole(13,kk) 1750c 1751c intermediates involving moments and separation distance 1752c 1753 dir = dix*xr + diy*yr + diz*zr 1754 qix = qixx*xr + qixy*yr + qixz*zr 1755 qiy = qixy*xr + qiyy*yr + qiyz*zr 1756 qiz = qixz*xr + qiyz*yr + qizz*zr 1757 qir = qix*xr + qiy*yr + qiz*zr 1758 dkr = dkx*xr + dky*yr + dkz*zr 1759 qkx = qkxx*xr + qkxy*yr + qkxz*zr 1760 qky = qkxy*xr + qkyy*yr + qkyz*zr 1761 qkz = qkxz*xr + qkyz*yr + qkzz*zr 1762 qkr = qkx*xr + qky*yr + qkz*zr 1763c 1764c find the field components for Thole polarization damping 1765c 1766 if (use_thole) then 1767 call dampthole (ii,kk,7,r,dmpik) 1768 rr3 = dmpik(3) / (r*r2) 1769 rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) 1770 rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2) 1771 fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) 1772 & - rr3*dkx + 2.0d0*rr5*qkx 1773 fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) 1774 & - rr3*dky + 2.0d0*rr5*qky 1775 fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) 1776 & - rr3*dkz + 2.0d0*rr5*qkz 1777 fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) 1778 & - rr3*dix - 2.0d0*rr5*qix 1779 fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) 1780 & - rr3*diy - 2.0d0*rr5*qiy 1781 fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) 1782 & - rr3*diz - 2.0d0*rr5*qiz 1783c 1784c find the field components for charge penetration damping 1785c 1786 else if (use_chgpen) then 1787 corek = pcore(kk) 1788 valk = pval(kk) 1789 alphak = palpha(kk) 1790 call dampdir (r,alphai,alphak,dmpi,dmpk) 1791 rr3 = 1.0d0 / (r*r2) 1792 rr5 = 3.0d0 * rr3 / r2 1793 rr7 = 5.0d0 * rr5 / r2 1794 rr3i = dmpi(3) * rr3 1795 rr5i = dmpi(5) * rr5 1796 rr7i = dmpi(7) * rr7 1797 rr3k = dmpk(3) * rr3 1798 rr5k = dmpk(5) * rr5 1799 rr7k = dmpk(7) * rr7 1800 fid(1) = -xr*(rr3*corek + rr3k*valk 1801 & - rr5k*dkr + rr7k*qkr) 1802 & - rr3k*dkx + 2.0d0*rr5k*qkx 1803 fid(2) = -yr*(rr3*corek + rr3k*valk 1804 & - rr5k*dkr + rr7k*qkr) 1805 & - rr3k*dky + 2.0d0*rr5k*qky 1806 fid(3) = -zr*(rr3*corek + rr3k*valk 1807 & - rr5k*dkr + rr7k*qkr) 1808 & - rr3k*dkz + 2.0d0*rr5k*qkz 1809 fkd(1) = xr*(rr3*corei + rr3i*vali 1810 & + rr5i*dir + rr7i*qir) 1811 & - rr3i*dix - 2.0d0*rr5i*qix 1812 fkd(2) = yr*(rr3*corei + rr3i*vali 1813 & + rr5i*dir + rr7i*qir) 1814 & - rr3i*diy - 2.0d0*rr5i*qiy 1815 fkd(3) = zr*(rr3*corei + rr3i*vali 1816 & + rr5i*dir + rr7i*qir) 1817 & - rr3i*diz - 2.0d0*rr5i*qiz 1818 end if 1819c 1820c increment the direct electrostatic field components 1821c 1822 do j = 1, 3 1823 fieldt(j,ii) = fieldt(j,ii) + fid(j)*dscale(k) 1824 fieldt(j,kk) = fieldt(j,kk) + fkd(j)*dscale(k) 1825 fieldtp(j,ii) = fieldtp(j,ii) + fid(j)*pscale(k) 1826 fieldtp(j,kk) = fieldtp(j,kk) + fkd(j)*pscale(k) 1827 end do 1828 end if 1829 end do 1830c 1831c reset exclusion coefficients for connected atoms 1832c 1833 if (dpequal) then 1834 do j = 1, n12(i) 1835 pscale(i12(j,i)) = 1.0d0 1836 dscale(i12(j,i)) = 1.0d0 1837 end do 1838 do j = 1, n13(i) 1839 pscale(i13(j,i)) = 1.0d0 1840 dscale(i13(j,i)) = 1.0d0 1841 end do 1842 do j = 1, n14(i) 1843 pscale(i14(j,i)) = 1.0d0 1844 dscale(i14(j,i)) = 1.0d0 1845 end do 1846 do j = 1, n15(i) 1847 pscale(i15(j,i)) = 1.0d0 1848 dscale(i15(j,i)) = 1.0d0 1849 end do 1850 else 1851 do j = 1, n12(i) 1852 pscale(i12(j,i)) = 1.0d0 1853 end do 1854 do j = 1, n13(i) 1855 pscale(i13(j,i)) = 1.0d0 1856 end do 1857 do j = 1, n14(i) 1858 pscale(i14(j,i)) = 1.0d0 1859 end do 1860 do j = 1, n15(i) 1861 pscale(i15(j,i)) = 1.0d0 1862 end do 1863 do j = 1, np11(i) 1864 dscale(ip11(j,i)) = 1.0d0 1865 end do 1866 do j = 1, np12(i) 1867 dscale(ip12(j,i)) = 1.0d0 1868 end do 1869 do j = 1, np13(i) 1870 dscale(ip13(j,i)) = 1.0d0 1871 end do 1872 do j = 1, np14(i) 1873 dscale(ip14(j,i)) = 1.0d0 1874 end do 1875 end if 1876 end do 1877!$OMP END DO 1878c 1879c add local to global variables for OpenMP calculation 1880c 1881!$OMP DO 1882 do ii = 1, npole 1883 do j = 1, 3 1884 field(j,ii) = fieldt(j,ii) 1885 fieldp(j,ii) = fieldtp(j,ii) 1886 end do 1887 end do 1888!$OMP END DO 1889!$OMP END PARALLEL 1890c 1891c perform deallocation of some local arrays 1892c 1893 deallocate (dscale) 1894 deallocate (pscale) 1895 deallocate (fieldt) 1896 deallocate (fieldtp) 1897 return 1898 end 1899c 1900c 1901c ############################################################### 1902c ## ## 1903c ## subroutine ufield0b -- mutual induction via pair list ## 1904c ## ## 1905c ############################################################### 1906c 1907c 1908c "ufield0b" computes the mutual electrostatic field due to 1909c induced dipole moments via a pair list 1910c 1911c 1912 subroutine ufield0b (field,fieldp) 1913 use atoms 1914 use bound 1915 use chgpen 1916 use couple 1917 use mplpot 1918 use mpole 1919 use neigh 1920 use polar 1921 use polgrp 1922 use polpot 1923 use shunt 1924 implicit none 1925 integer i,j,k 1926 integer ii,kk,kkk 1927 real*8 xr,yr,zr 1928 real*8 r,r2,rr3,rr5 1929 real*8 dix,diy,diz 1930 real*8 pix,piy,piz 1931 real*8 dkx,dky,dkz 1932 real*8 pkx,pky,pkz 1933 real*8 dir,pir 1934 real*8 dkr,pkr 1935 real*8 corei,corek 1936 real*8 vali,valk 1937 real*8 alphai,alphak 1938 real*8 fid(3),fkd(3) 1939 real*8 fip(3),fkp(3) 1940 real*8 dmpik(5) 1941 real*8, allocatable :: uscale(:) 1942 real*8, allocatable :: wscale(:) 1943 real*8 field(3,*) 1944 real*8 fieldp(3,*) 1945 real*8, allocatable :: fieldt(:,:) 1946 real*8, allocatable :: fieldtp(:,:) 1947 character*6 mode 1948c 1949c 1950c set the switching function coefficients 1951c 1952 mode = 'MPOLE' 1953 call switch (mode) 1954c 1955c perform dynamic allocation of some local arrays 1956c 1957 allocate (uscale(n)) 1958 allocate (wscale(n)) 1959 allocate (fieldt(3,npole)) 1960 allocate (fieldtp(3,npole)) 1961c 1962c set array needed to scale connected atom interactions 1963c 1964 do i = 1, n 1965 uscale(i) = 1.0d0 1966 wscale(i) = 1.0d0 1967 end do 1968c 1969c initialize local variables for OpenMP calculation 1970c 1971 do ii = 1, npole 1972 do j = 1, 3 1973 fieldt(j,ii) = 0.0d0 1974 fieldtp(j,ii) = 0.0d0 1975 end do 1976 end do 1977c 1978c OpenMP directives for the major loop structure 1979c 1980!$OMP PARALLEL default(private) 1981!$OMP& shared(npole,ipole,uind,uinp,x,y,z,pcore,pval,palpha,n12,i12, 1982!$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14, 1983!$OMP& u1scale,u2scale,u3scale,u4scale,w2scale,w3scale,w4scale,w5scale, 1984!$OMP& nelst,elst,use_thole,use_chgpen,use_bounds,off2,field,fieldp) 1985!$OMP& firstprivate(uscale,wscale) shared (fieldt,fieldtp) 1986!$OMP DO reduction(+:fieldt,fieldtp) schedule(guided) 1987c 1988c find the electrostatic field due to mutual induced dipoles 1989c 1990 do ii = 1, npole 1991 i = ipole(ii) 1992 dix = uind(1,ii) 1993 diy = uind(2,ii) 1994 diz = uind(3,ii) 1995 pix = uinp(1,ii) 1996 piy = uinp(2,ii) 1997 piz = uinp(3,ii) 1998 if (use_chgpen) then 1999 corei = pcore(ii) 2000 vali = pval(ii) 2001 alphai = palpha(ii) 2002 end if 2003c 2004c set exclusion coefficients for connected atoms 2005c 2006 do j = 1, np11(i) 2007 uscale(ip11(j,i)) = u1scale 2008 end do 2009 do j = 1, np12(i) 2010 uscale(ip12(j,i)) = u2scale 2011 end do 2012 do j = 1, np13(i) 2013 uscale(ip13(j,i)) = u3scale 2014 end do 2015 do j = 1, np14(i) 2016 uscale(ip14(j,i)) = u4scale 2017 end do 2018 do j = 1, n12(i) 2019 wscale(i12(j,i)) = w2scale 2020 end do 2021 do j = 1, n13(i) 2022 wscale(i13(j,i)) = w3scale 2023 end do 2024 do j = 1, n14(i) 2025 wscale(i14(j,i)) = w4scale 2026 end do 2027 do j = 1, n15(i) 2028 wscale(i15(j,i)) = w5scale 2029 end do 2030c 2031c evaluate all sites within the cutoff distance 2032c 2033 do kkk = 1, nelst(ii) 2034 kk = elst(kkk,ii) 2035 k = ipole(kk) 2036 xr = x(k) - x(i) 2037 yr = y(k) - y(i) 2038 zr = z(k) - z(i) 2039 if (use_bounds) call image (xr,yr,zr) 2040 r2 = xr*xr + yr* yr + zr*zr 2041 if (r2 .le. off2) then 2042 r = sqrt(r2) 2043 dkx = uind(1,kk) 2044 dky = uind(2,kk) 2045 dkz = uind(3,kk) 2046 pkx = uinp(1,kk) 2047 pky = uinp(2,kk) 2048 pkz = uinp(3,kk) 2049c 2050c intermediates involving moments and separation distance 2051c 2052 dir = dix*xr + diy*yr + diz*zr 2053 dkr = dkx*xr + dky*yr + dkz*zr 2054 pir = pix*xr + piy*yr + piz*zr 2055 pkr = pkx*xr + pky*yr + pkz*zr 2056c 2057c find the scale factors for Thole polarization damping 2058c 2059 if (use_thole) then 2060 call dampthole2 (ii,kk,5,r,dmpik) 2061 dmpik(3) = uscale(k) * dmpik(3) 2062 dmpik(5) = uscale(k) * dmpik(5) 2063c 2064c find the scale factors for charge penetration damping 2065c 2066 else if (use_chgpen) then 2067 corek = pcore(kk) 2068 valk = pval(kk) 2069 alphak = palpha(kk) 2070 call dampmut (r,alphai,alphak,dmpik) 2071 dmpik(3) = wscale(k) * dmpik(3) 2072 dmpik(5) = wscale(k) * dmpik(5) 2073 end if 2074c 2075c increment the mutual electrostatic field components 2076c 2077 rr3 = -dmpik(3) / (r*r2) 2078 rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) 2079 fid(1) = rr3*dkx + rr5*dkr*xr 2080 fid(2) = rr3*dky + rr5*dkr*yr 2081 fid(3) = rr3*dkz + rr5*dkr*zr 2082 fkd(1) = rr3*dix + rr5*dir*xr 2083 fkd(2) = rr3*diy + rr5*dir*yr 2084 fkd(3) = rr3*diz + rr5*dir*zr 2085 fip(1) = rr3*pkx + rr5*pkr*xr 2086 fip(2) = rr3*pky + rr5*pkr*yr 2087 fip(3) = rr3*pkz + rr5*pkr*zr 2088 fkp(1) = rr3*pix + rr5*pir*xr 2089 fkp(2) = rr3*piy + rr5*pir*yr 2090 fkp(3) = rr3*piz + rr5*pir*zr 2091 do j = 1, 3 2092 fieldt(j,ii) = fieldt(j,ii) + fid(j) 2093 fieldt(j,kk) = fieldt(j,kk) + fkd(j) 2094 fieldtp(j,ii) = fieldtp(j,ii) + fip(j) 2095 fieldtp(j,kk) = fieldtp(j,kk) + fkp(j) 2096 end do 2097 end if 2098 end do 2099c 2100c reset exclusion coefficients for connected atoms 2101c 2102 do j = 1, np11(i) 2103 uscale(ip11(j,i)) = 1.0d0 2104 end do 2105 do j = 1, np12(i) 2106 uscale(ip12(j,i)) = 1.0d0 2107 end do 2108 do j = 1, np13(i) 2109 uscale(ip13(j,i)) = 1.0d0 2110 end do 2111 do j = 1, np14(i) 2112 uscale(ip14(j,i)) = 1.0d0 2113 end do 2114 do j = 1, n12(i) 2115 wscale(i12(j,i)) = 1.0d0 2116 end do 2117 do j = 1, n13(i) 2118 wscale(i13(j,i)) = 1.0d0 2119 end do 2120 do j = 1, n14(i) 2121 wscale(i14(j,i)) = 1.0d0 2122 end do 2123 do j = 1, n15(i) 2124 wscale(i15(j,i)) = 1.0d0 2125 end do 2126 end do 2127!$OMP END DO 2128c 2129c add local to global variables for OpenMP calculation 2130c 2131!$OMP DO 2132 do ii = 1, npole 2133 do j = 1, 3 2134 field(j,ii) = fieldt(j,ii) 2135 fieldp(j,ii) = fieldtp(j,ii) 2136 end do 2137 end do 2138!$OMP END DO 2139!$OMP END PARALLEL 2140c 2141c perform deallocation of some local arrays 2142c 2143 deallocate (uscale) 2144 deallocate (wscale) 2145 deallocate (fieldt) 2146 deallocate (fieldtp) 2147 return 2148 end 2149c 2150c 2151c ############################################################### 2152c ## ## 2153c ## subroutine dfield0c -- direct induction via Ewald sum ## 2154c ## ## 2155c ############################################################### 2156c 2157c 2158c "dfield0c" computes the mutual electrostatic field due to 2159c permanent multipole moments via Ewald summation 2160c 2161c 2162 subroutine dfield0c (field,fieldp) 2163 use atoms 2164 use boxes 2165 use ewald 2166 use limits 2167 use math 2168 use mpole 2169 use pme 2170 use polar 2171 implicit none 2172 integer i,j,ii 2173 real*8 term 2174 real*8 ucell(3) 2175 real*8 field(3,*) 2176 real*8 fieldp(3,*) 2177c 2178c 2179c zero out the value of the field at each site 2180c 2181 do ii = 1, npole 2182 do j = 1, 3 2183 field(j,ii) = 0.0d0 2184 fieldp(j,ii) = 0.0d0 2185 end do 2186 end do 2187c 2188c set grid size, spline order and Ewald coefficient 2189c 2190 nfft1 = nefft1 2191 nfft2 = nefft2 2192 nfft3 = nefft3 2193 bsorder = bsporder 2194 aewald = apewald 2195c 2196c get the reciprocal space part of the permanent field 2197c 2198 call udirect1 (field) 2199 do ii = 1, npole 2200 do j = 1, 3 2201 fieldp(j,ii) = field(j,ii) 2202 end do 2203 end do 2204c 2205c get the real space portion of the permanent field 2206c 2207 if (use_mlist) then 2208 call udirect2b (field,fieldp) 2209 else 2210 call udirect2a (field,fieldp) 2211 end if 2212c 2213c get the self-energy portion of the permanent field 2214c 2215 term = (4.0d0/3.0d0) * aewald**3 / rootpi 2216 do ii = 1, npole 2217 do j = 1, 3 2218 field(j,ii) = field(j,ii) + term*rpole(j+1,ii) 2219 fieldp(j,ii) = fieldp(j,ii) + term*rpole(j+1,ii) 2220 end do 2221 end do 2222c 2223c compute the cell dipole boundary correction to field 2224c 2225 if (boundary .eq. 'VACUUM') then 2226 do i = 1, 3 2227 ucell(i) = 0.0d0 2228 end do 2229 do ii = 1, npole 2230 i = ipole(ii) 2231 ucell(1) = ucell(1) + rpole(2,ii) + rpole(1,ii)*x(i) 2232 ucell(2) = ucell(2) + rpole(3,ii) + rpole(1,ii)*y(i) 2233 ucell(3) = ucell(3) + rpole(4,ii) + rpole(1,ii)*z(i) 2234 end do 2235 term = (4.0d0/3.0d0) * pi/volbox 2236 do ii = 1, npole 2237 do j = 1, 3 2238 field(j,ii) = field(j,ii) - term*ucell(j) 2239 fieldp(j,ii) = fieldp(j,ii) - term*ucell(j) 2240 end do 2241 end do 2242 end if 2243 return 2244 end 2245c 2246c 2247c ################################################################# 2248c ## ## 2249c ## subroutine udirect1 -- Ewald recip direct induced field ## 2250c ## ## 2251c ################################################################# 2252c 2253c 2254c "udirect1" computes the reciprocal space contribution of the 2255c permanent atomic multipole moments to the field 2256c 2257c note that cmp, fmp, cphi and fphi should not be made global 2258c since corresponding values in empole and epolar are different 2259c 2260c 2261 subroutine udirect1 (field) 2262 use bound 2263 use boxes 2264 use ewald 2265 use math 2266 use mpole 2267 use pme 2268 use polpot 2269 implicit none 2270 integer i,j,k,ii 2271 integer k1,k2,k3 2272 integer m1,m2,m3 2273 integer ntot,nff 2274 integer nf1,nf2,nf3 2275 real*8 r1,r2,r3 2276 real*8 h1,h2,h3 2277 real*8 volterm,denom 2278 real*8 hsq,expterm 2279 real*8 term,pterm 2280 real*8 field(3,*) 2281 real*8, allocatable :: cmp(:,:) 2282 real*8, allocatable :: fmp(:,:) 2283 real*8, allocatable :: cphi(:,:) 2284 real*8, allocatable :: fphi(:,:) 2285c 2286c 2287c return if the Ewald coefficient is zero 2288c 2289 if (aewald .lt. 1.0d-6) return 2290c 2291c perform dynamic allocation of some local arrays 2292c 2293 allocate (cmp(10,npole)) 2294 allocate (fmp(10,npole)) 2295 allocate (cphi(10,npole)) 2296 allocate (fphi(20,npole)) 2297c 2298c perform dynamic allocation of some global arrays 2299c 2300 ntot = nfft1 * nfft2 * nfft3 2301 if (allocated(qgrid)) then 2302 if (size(qgrid) .ne. 2*ntot) call fftclose 2303 end if 2304 if (allocated(qfac)) then 2305 if (size(qfac) .ne. ntot) deallocate (qfac) 2306 end if 2307 if (.not. allocated(qgrid)) call fftsetup 2308 if (.not. allocated(qfac)) allocate (qfac(nfft1,nfft2,nfft3)) 2309c 2310c setup spatial decomposition and B-spline coefficients 2311c 2312 call getchunk 2313 call moduli 2314 call bspline_fill 2315 call table_fill 2316c 2317c copy the multipole moments into local storage areas 2318c 2319 do ii = 1, npole 2320 cmp(1,ii) = rpole(1,ii) 2321 cmp(2,ii) = rpole(2,ii) 2322 cmp(3,ii) = rpole(3,ii) 2323 cmp(4,ii) = rpole(4,ii) 2324 cmp(5,ii) = rpole(5,ii) 2325 cmp(6,ii) = rpole(9,ii) 2326 cmp(7,ii) = rpole(13,ii) 2327 cmp(8,ii) = 2.0d0 * rpole(6,ii) 2328 cmp(9,ii) = 2.0d0 * rpole(7,ii) 2329 cmp(10,ii) = 2.0d0 * rpole(10,ii) 2330 end do 2331c 2332c convert Cartesian multipoles to fractional coordinates 2333c 2334 call cmp_to_fmp (cmp,fmp) 2335c 2336c assign PME grid and perform 3-D FFT forward transform 2337c 2338 call grid_mpole (fmp) 2339 call fftfront 2340c 2341c make the scalar summation over reciprocal lattice 2342c 2343 qfac(1,1,1) = 0.0d0 2344 pterm = (pi/aewald)**2 2345 volterm = pi * volbox 2346 nf1 = (nfft1+1) / 2 2347 nf2 = (nfft2+1) / 2 2348 nf3 = (nfft3+1) / 2 2349 nff = nfft1 * nfft2 2350 ntot = nff * nfft3 2351 do i = 1, ntot-1 2352 k3 = i/nff + 1 2353 j = i - (k3-1)*nff 2354 k2 = j/nfft1 + 1 2355 k1 = j - (k2-1)*nfft1 + 1 2356 m1 = k1 - 1 2357 m2 = k2 - 1 2358 m3 = k3 - 1 2359 if (k1 .gt. nf1) m1 = m1 - nfft1 2360 if (k2 .gt. nf2) m2 = m2 - nfft2 2361 if (k3 .gt. nf3) m3 = m3 - nfft3 2362 r1 = dble(m1) 2363 r2 = dble(m2) 2364 r3 = dble(m3) 2365 h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3 2366 h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3 2367 h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3 2368 hsq = h1*h1 + h2*h2 + h3*h3 2369 term = -pterm * hsq 2370 expterm = 0.0d0 2371 if (term .gt. -50.0d0) then 2372 denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3) 2373 expterm = exp(term) / denom 2374 if (.not. use_bounds) then 2375 expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) 2376 else if (nonprism) then 2377 if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 2378 end if 2379 end if 2380 qfac(k1,k2,k3) = expterm 2381 end do 2382c 2383c account for zeroth grid point for nonperiodic system 2384c 2385 if (.not. use_bounds) then 2386 expterm = 0.5d0 * pi / xbox 2387 qfac(1,1,1) = expterm 2388 end if 2389c 2390c complete the transformation of the PME grid 2391c 2392 do k = 1, nfft3 2393 do j = 1, nfft2 2394 do i = 1, nfft1 2395 term = qfac(i,j,k) 2396 qgrid(1,i,j,k) = term * qgrid(1,i,j,k) 2397 qgrid(2,i,j,k) = term * qgrid(2,i,j,k) 2398 end do 2399 end do 2400 end do 2401c 2402c perform 3-D FFT backward transform and get field 2403c 2404 call fftback 2405 call fphi_mpole (fphi) 2406c 2407c convert the field from fractional to Cartesian 2408c 2409 call fphi_to_cphi (fphi,cphi) 2410c 2411c increment the field at each multipole site 2412c 2413 do ii = 1, npole 2414 field(1,ii) = field(1,ii) - cphi(2,ii) 2415 field(2,ii) = field(2,ii) - cphi(3,ii) 2416 field(3,ii) = field(3,ii) - cphi(4,ii) 2417 end do 2418c 2419c perform deallocation of some local arrays 2420c 2421 deallocate (cmp) 2422 deallocate (fmp) 2423 deallocate (cphi) 2424 deallocate (fphi) 2425 return 2426 end 2427c 2428c 2429c ################################################################## 2430c ## ## 2431c ## subroutine udirect2a -- Ewald real direct field via loop ## 2432c ## ## 2433c ################################################################## 2434c 2435c 2436c "udirect2a" computes the real space contribution of the permanent 2437c atomic multipole moments to the field via a double loop 2438c 2439c 2440 subroutine udirect2a (field,fieldp) 2441 use atoms 2442 use boxes 2443 use bound 2444 use cell 2445 use chgpen 2446 use couple 2447 use math 2448 use mplpot 2449 use mpole 2450 use polar 2451 use polgrp 2452 use polpot 2453 use shunt 2454 use units 2455 implicit none 2456 integer i,j,k,m 2457 integer ii,kk 2458 real*8 xr,yr,zr 2459 real*8 r,r2,rr1,rr2 2460 real*8 rr3,rr5,rr7 2461 real*8 rr3i,rr5i,rr7i 2462 real*8 rr3k,rr5k,rr7k 2463 real*8 ci,dix,diy,diz 2464 real*8 qixx,qiyy,qizz 2465 real*8 qixy,qixz,qiyz 2466 real*8 ck,dkx,dky,dkz 2467 real*8 qkxx,qkyy,qkzz 2468 real*8 qkxy,qkxz,qkyz 2469 real*8 dir,dkr 2470 real*8 qix,qiy,qiz,qir 2471 real*8 qkx,qky,qkz,qkr 2472 real*8 corei,corek 2473 real*8 vali,valk 2474 real*8 alphai,alphak 2475 real*8 scalek 2476 real*8 dmp3,dmp5,dmp7 2477 real*8 dsc3,dsc5,dsc7 2478 real*8 psc3,psc5,psc7 2479 real*8 fid(3),fkd(3) 2480 real*8 fip(3),fkp(3) 2481 real*8 dmpi(7),dmpk(7) 2482 real*8 dmpik(7),dmpe(7) 2483 real*8, allocatable :: pscale(:) 2484 real*8, allocatable :: dscale(:) 2485 real*8 field(3,*) 2486 real*8 fieldp(3,*) 2487 character*6 mode 2488c 2489c 2490c check for multipoles and set cutoff coefficients 2491c 2492 if (npole .eq. 0) return 2493 mode = 'EWALD' 2494 call switch (mode) 2495c 2496c perform dynamic allocation of some local arrays 2497c 2498 allocate (pscale(n)) 2499 allocate (dscale(n)) 2500c 2501c set arrays needed to scale connected atom interactions 2502c 2503 do i = 1, n 2504 pscale(i) = 1.0d0 2505 dscale(i) = 1.0d0 2506 end do 2507c 2508c compute real space Ewald field due to permanent multipoles 2509c 2510 do ii = 1, npole-1 2511 i = ipole(ii) 2512 ci = rpole(1,ii) 2513 dix = rpole(2,ii) 2514 diy = rpole(3,ii) 2515 diz = rpole(4,ii) 2516 qixx = rpole(5,ii) 2517 qixy = rpole(6,ii) 2518 qixz = rpole(7,ii) 2519 qiyy = rpole(9,ii) 2520 qiyz = rpole(10,ii) 2521 qizz = rpole(13,ii) 2522 if (use_chgpen) then 2523 corei = pcore(ii) 2524 vali = pval(ii) 2525 alphai = palpha(ii) 2526 end if 2527c 2528c set exclusion coefficients for connected atoms 2529c 2530 if (dpequal) then 2531 do j = 1, n12(i) 2532 pscale(i12(j,i)) = p2scale 2533 do k = 1, np11(i) 2534 if (i12(j,i) .eq. ip11(k,i)) 2535 & pscale(i12(j,i)) = p2iscale 2536 end do 2537 dscale(i12(j,i)) = pscale(i12(j,i)) 2538 end do 2539 do j = 1, n13(i) 2540 pscale(i13(j,i)) = p3scale 2541 do k = 1, np11(i) 2542 if (i13(j,i) .eq. ip11(k,i)) 2543 & pscale(i13(j,i)) = p3iscale 2544 end do 2545 dscale(i13(j,i)) = pscale(i13(j,i)) 2546 end do 2547 do j = 1, n14(i) 2548 pscale(i14(j,i)) = p4scale 2549 do k = 1, np11(i) 2550 if (i14(j,i) .eq. ip11(k,i)) 2551 & pscale(i14(j,i)) = p4iscale 2552 end do 2553 dscale(i14(j,i)) = pscale(i14(j,i)) 2554 end do 2555 do j = 1, n15(i) 2556 pscale(i15(j,i)) = p5scale 2557 do k = 1, np11(i) 2558 if (i15(j,i) .eq. ip11(k,i)) 2559 & pscale(i15(j,i)) = p5iscale 2560 end do 2561 dscale(i15(j,i)) = pscale(i15(j,i)) 2562 end do 2563 else 2564 do j = 1, n12(i) 2565 pscale(i12(j,i)) = p2scale 2566 do k = 1, np11(i) 2567 if (i12(j,i) .eq. ip11(k,i)) 2568 & pscale(i12(j,i)) = p2iscale 2569 end do 2570 end do 2571 do j = 1, n13(i) 2572 pscale(i13(j,i)) = p3scale 2573 do k = 1, np11(i) 2574 if (i13(j,i) .eq. ip11(k,i)) 2575 & pscale(i13(j,i)) = p3iscale 2576 end do 2577 end do 2578 do j = 1, n14(i) 2579 pscale(i14(j,i)) = p4scale 2580 do k = 1, np11(i) 2581 if (i14(j,i) .eq. ip11(k,i)) 2582 & pscale(i14(j,i)) = p4iscale 2583 end do 2584 end do 2585 do j = 1, n15(i) 2586 pscale(i15(j,i)) = p5scale 2587 do k = 1, np11(i) 2588 if (i15(j,i) .eq. ip11(k,i)) 2589 & pscale(i15(j,i)) = p5iscale 2590 end do 2591 end do 2592 do j = 1, np11(i) 2593 dscale(ip11(j,i)) = d1scale 2594 end do 2595 do j = 1, np12(i) 2596 dscale(ip12(j,i)) = d2scale 2597 end do 2598 do j = 1, np13(i) 2599 dscale(ip13(j,i)) = d3scale 2600 end do 2601 do j = 1, np14(i) 2602 dscale(ip14(j,i)) = d4scale 2603 end do 2604 end if 2605c 2606c evaluate all sites within the cutoff distance 2607c 2608 do kk = ii+1, npole 2609 k = ipole(kk) 2610 xr = x(k) - x(i) 2611 yr = y(k) - y(i) 2612 zr = z(k) - z(i) 2613 call image (xr,yr,zr) 2614 r2 = xr*xr + yr* yr + zr*zr 2615 if (r2 .le. off2) then 2616 r = sqrt(r2) 2617 rr1 = 1.0d0 / r 2618 rr2 = rr1 * rr1 2619 rr3 = rr2 * rr1 2620 rr5 = 3.0d0 * rr2 * rr3 2621 rr7 = 5.0d0 * rr2 * rr5 2622 ck = rpole(1,kk) 2623 dkx = rpole(2,kk) 2624 dky = rpole(3,kk) 2625 dkz = rpole(4,kk) 2626 qkxx = rpole(5,kk) 2627 qkxy = rpole(6,kk) 2628 qkxz = rpole(7,kk) 2629 qkyy = rpole(9,kk) 2630 qkyz = rpole(10,kk) 2631 qkzz = rpole(13,kk) 2632c 2633c intermediates involving moments and separation distance 2634c 2635 dir = dix*xr + diy*yr + diz*zr 2636 qix = qixx*xr + qixy*yr + qixz*zr 2637 qiy = qixy*xr + qiyy*yr + qiyz*zr 2638 qiz = qixz*xr + qiyz*yr + qizz*zr 2639 qir = qix*xr + qiy*yr + qiz*zr 2640 dkr = dkx*xr + dky*yr + dkz*zr 2641 qkx = qkxx*xr + qkxy*yr + qkxz*zr 2642 qky = qkxy*xr + qkyy*yr + qkyz*zr 2643 qkz = qkxz*xr + qkyz*yr + qkzz*zr 2644 qkr = qkx*xr + qky*yr + qkz*zr 2645c 2646c calculate real space Ewald error function damping 2647c 2648 call dampewald (7,r,r2,1.0d0,dmpe) 2649c 2650c find the field components for Thole polarization damping 2651c 2652 if (use_thole) then 2653 call dampthole (ii,kk,7,r,dmpik) 2654 scalek = dscale(k) 2655 dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 2656 dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 2657 dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7 2658 fid(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2659 & - dmp3*dkx + 2.0d0*dmp5*qkx 2660 fid(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2661 & - dmp3*dky + 2.0d0*dmp5*qky 2662 fid(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2663 & - dmp3*dkz + 2.0d0*dmp5*qkz 2664 fkd(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) 2665 & - dmp3*dix - 2.0d0*dmp5*qix 2666 fkd(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) 2667 & - dmp3*diy - 2.0d0*dmp5*qiy 2668 fkd(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) 2669 & - dmp3*diz - 2.0d0*dmp5*qiz 2670 scalek = pscale(k) 2671 dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 2672 dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 2673 dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7 2674 fip(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2675 & - dmp3*dkx + 2.0d0*dmp5*qkx 2676 fip(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2677 & - dmp3*dky + 2.0d0*dmp5*qky 2678 fip(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2679 & - dmp3*dkz + 2.0d0*dmp5*qkz 2680 fkp(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) 2681 & - dmp3*dix - 2.0d0*dmp5*qix 2682 fkp(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) 2683 & - dmp3*diy - 2.0d0*dmp5*qiy 2684 fkp(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) 2685 & - dmp3*diz - 2.0d0*dmp5*qiz 2686c 2687c find the field components for charge penetration damping 2688c 2689 else if (use_chgpen) then 2690 corek = pcore(kk) 2691 valk = pval(kk) 2692 alphak = palpha(kk) 2693 call dampdir (r,alphai,alphak,dmpi,dmpk) 2694 scalek = dscale(k) 2695 rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 2696 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 2697 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 2698 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 2699 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 2700 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 2701 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 2702 fid(1) = -xr*(rr3*corek + rr3k*valk 2703 & - rr5k*dkr + rr7k*qkr) 2704 & - rr3k*dkx + 2.0d0*rr5k*qkx 2705 fid(2) = -yr*(rr3*corek + rr3k*valk 2706 & - rr5k*dkr + rr7k*qkr) 2707 & - rr3k*dky + 2.0d0*rr5k*qky 2708 fid(3) = -zr*(rr3*corek + rr3k*valk 2709 & - rr5k*dkr + rr7k*qkr) 2710 & - rr3k*dkz + 2.0d0*rr5k*qkz 2711 fkd(1) = xr*(rr3*corei + rr3i*vali 2712 & + rr5i*dir + rr7i*qir) 2713 & - rr3i*dix - 2.0d0*rr5i*qix 2714 fkd(2) = yr*(rr3*corei + rr3i*vali 2715 & + rr5i*dir + rr7i*qir) 2716 & - rr3i*diy - 2.0d0*rr5i*qiy 2717 fkd(3) = zr*(rr3*corei + rr3i*vali 2718 & + rr5i*dir + rr7i*qir) 2719 & - rr3i*diz - 2.0d0*rr5i*qiz 2720 scalek = pscale(k) 2721 rr3 = rr2 * rr1 2722 rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 2723 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 2724 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 2725 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 2726 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 2727 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 2728 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 2729 fip(1) = -xr*(rr3*corek + rr3k*valk 2730 & - rr5k*dkr + rr7k*qkr) 2731 & - rr3k*dkx + 2.0d0*rr5k*qkx 2732 fip(2) = -yr*(rr3*corek + rr3k*valk 2733 & - rr5k*dkr + rr7k*qkr) 2734 & - rr3k*dky + 2.0d0*rr5k*qky 2735 fip(3) = -zr*(rr3*corek + rr3k*valk 2736 & - rr5k*dkr + rr7k*qkr) 2737 & - rr3k*dkz + 2.0d0*rr5k*qkz 2738 fkp(1) = xr*(rr3*corei + rr3i*vali 2739 & + rr5i*dir + rr7i*qir) 2740 & - rr3i*dix - 2.0d0*rr5i*qix 2741 fkp(2) = yr*(rr3*corei + rr3i*vali 2742 & + rr5i*dir + rr7i*qir) 2743 & - rr3i*diy - 2.0d0*rr5i*qiy 2744 fkp(3) = zr*(rr3*corei + rr3i*vali 2745 & + rr5i*dir + rr7i*qir) 2746 & - rr3i*diz - 2.0d0*rr5i*qiz 2747 end if 2748c 2749c increment the field at each site due to this interaction 2750c 2751 do j = 1, 3 2752 field(j,ii) = field(j,ii) + fid(j) 2753 field(j,kk) = field(j,kk) + fkd(j) 2754 fieldp(j,ii) = fieldp(j,ii) + fip(j) 2755 fieldp(j,kk) = fieldp(j,kk) + fkp(j) 2756 end do 2757 end if 2758 end do 2759c 2760c reset exclusion coefficients for connected atoms 2761c 2762 if (dpequal) then 2763 do j = 1, n12(i) 2764 pscale(i12(j,i)) = 1.0d0 2765 dscale(i12(j,i)) = 1.0d0 2766 end do 2767 do j = 1, n13(i) 2768 pscale(i13(j,i)) = 1.0d0 2769 dscale(i13(j,i)) = 1.0d0 2770 end do 2771 do j = 1, n14(i) 2772 pscale(i14(j,i)) = 1.0d0 2773 dscale(i14(j,i)) = 1.0d0 2774 end do 2775 do j = 1, n15(i) 2776 pscale(i15(j,i)) = 1.0d0 2777 dscale(i15(j,i)) = 1.0d0 2778 end do 2779 else 2780 do j = 1, n12(i) 2781 pscale(i12(j,i)) = 1.0d0 2782 end do 2783 do j = 1, n13(i) 2784 pscale(i13(j,i)) = 1.0d0 2785 end do 2786 do j = 1, n14(i) 2787 pscale(i14(j,i)) = 1.0d0 2788 end do 2789 do j = 1, n15(i) 2790 pscale(i15(j,i)) = 1.0d0 2791 end do 2792 do j = 1, np11(i) 2793 dscale(ip11(j,i)) = 1.0d0 2794 end do 2795 do j = 1, np12(i) 2796 dscale(ip12(j,i)) = 1.0d0 2797 end do 2798 do j = 1, np13(i) 2799 dscale(ip13(j,i)) = 1.0d0 2800 end do 2801 do j = 1, np14(i) 2802 dscale(ip14(j,i)) = 1.0d0 2803 end do 2804 end if 2805 end do 2806c 2807c periodic boundary for large cutoffs via replicates method 2808c 2809 if (use_replica) then 2810 do ii = 1, npole 2811 i = ipole(ii) 2812 ci = rpole(1,ii) 2813 dix = rpole(2,ii) 2814 diy = rpole(3,ii) 2815 diz = rpole(4,ii) 2816 qixx = rpole(5,ii) 2817 qixy = rpole(6,ii) 2818 qixz = rpole(7,ii) 2819 qiyy = rpole(9,ii) 2820 qiyz = rpole(10,ii) 2821 qizz = rpole(13,ii) 2822 if (use_chgpen) then 2823 corei = pcore(ii) 2824 vali = pval(ii) 2825 alphai = palpha(ii) 2826 end if 2827c 2828c set exclusion coefficients for connected atoms 2829c 2830 if (dpequal) then 2831 do j = 1, n12(i) 2832 pscale(i12(j,i)) = p2scale 2833 do k = 1, np11(i) 2834 if (i12(j,i) .eq. ip11(k,i)) 2835 & pscale(i12(j,i)) = p2iscale 2836 end do 2837 dscale(i12(j,i)) = pscale(i12(j,i)) 2838 end do 2839 do j = 1, n13(i) 2840 pscale(i13(j,i)) = p3scale 2841 do k = 1, np11(i) 2842 if (i13(j,i) .eq. ip11(k,i)) 2843 & pscale(i13(j,i)) = p3iscale 2844 end do 2845 dscale(i13(j,i)) = pscale(i13(j,i)) 2846 end do 2847 do j = 1, n14(i) 2848 pscale(i14(j,i)) = p4scale 2849 do k = 1, np11(i) 2850 if (i14(j,i) .eq. ip11(k,i)) 2851 & pscale(i14(j,i)) = p4iscale 2852 end do 2853 dscale(i14(j,i)) = pscale(i14(j,i)) 2854 end do 2855 do j = 1, n15(i) 2856 pscale(i15(j,i)) = p5scale 2857 do k = 1, np11(i) 2858 if (i15(j,i) .eq. ip11(k,i)) 2859 & pscale(i15(j,i)) = p5iscale 2860 end do 2861 dscale(i15(j,i)) = pscale(i15(j,i)) 2862 end do 2863 else 2864 do j = 1, n12(i) 2865 pscale(i12(j,i)) = p2scale 2866 do k = 1, np11(i) 2867 if (i12(j,i) .eq. ip11(k,i)) 2868 & pscale(i12(j,i)) = p2iscale 2869 end do 2870 end do 2871 do j = 1, n13(i) 2872 pscale(i13(j,i)) = p3scale 2873 do k = 1, np11(i) 2874 if (i13(j,i) .eq. ip11(k,i)) 2875 & pscale(i13(j,i)) = p3iscale 2876 end do 2877 end do 2878 do j = 1, n14(i) 2879 pscale(i14(j,i)) = p4scale 2880 do k = 1, np11(i) 2881 if (i14(j,i) .eq. ip11(k,i)) 2882 & pscale(i14(j,i)) = p4iscale 2883 end do 2884 end do 2885 do j = 1, n15(i) 2886 pscale(i15(j,i)) = p5scale 2887 do k = 1, np11(i) 2888 if (i15(j,i) .eq. ip11(k,i)) 2889 & pscale(i15(j,i)) = p5iscale 2890 end do 2891 end do 2892 do j = 1, np11(i) 2893 dscale(ip11(j,i)) = d1scale 2894 end do 2895 do j = 1, np12(i) 2896 dscale(ip12(j,i)) = d2scale 2897 end do 2898 do j = 1, np13(i) 2899 dscale(ip13(j,i)) = d3scale 2900 end do 2901 do j = 1, np14(i) 2902 dscale(ip14(j,i)) = d4scale 2903 end do 2904 end if 2905c 2906c evaluate all sites within the cutoff distance 2907c 2908 do kk = ii, npole 2909 k = ipole(kk) 2910 ck = rpole(1,kk) 2911 dkx = rpole(2,kk) 2912 dky = rpole(3,kk) 2913 dkz = rpole(4,kk) 2914 qkxx = rpole(5,kk) 2915 qkxy = rpole(6,kk) 2916 qkxz = rpole(7,kk) 2917 qkyy = rpole(9,kk) 2918 qkyz = rpole(10,kk) 2919 qkzz = rpole(13,kk) 2920 do m = 2, ncell 2921 xr = x(k) - x(i) 2922 yr = y(k) - y(i) 2923 zr = z(k) - z(i) 2924 call imager (xr,yr,zr,m) 2925 r2 = xr*xr + yr* yr + zr*zr 2926c 2927c calculate the error function damping factors 2928c 2929 if (r2 .le. off2) then 2930 r = sqrt(r2) 2931 rr1 = 1.0d0 / r 2932 rr2 = rr1 * rr1 2933 rr3 = rr2 * rr1 2934 rr5 = 3.0d0 * rr2 * rr3 2935 rr7 = 5.0d0 * rr2 * rr5 2936c 2937c intermediates involving moments and separation distance 2938c 2939 dir = dix*xr + diy*yr + diz*zr 2940 qix = qixx*xr + qixy*yr + qixz*zr 2941 qiy = qixy*xr + qiyy*yr + qiyz*zr 2942 qiz = qixz*xr + qiyz*yr + qizz*zr 2943 qir = qix*xr + qiy*yr + qiz*zr 2944 dkr = dkx*xr + dky*yr + dkz*zr 2945 qkx = qkxx*xr + qkxy*yr + qkxz*zr 2946 qky = qkxy*xr + qkyy*yr + qkyz*zr 2947 qkz = qkxz*xr + qkyz*yr + qkzz*zr 2948 qkr = qkx*xr + qky*yr + qkz*zr 2949c 2950c calculate real space Ewald error function damping 2951c 2952 call dampewald (7,r,r2,1.0d0,dmpe) 2953c 2954c find the field components for Thole polarization damping 2955c 2956 if (use_thole) then 2957 call dampthole (ii,kk,7,r,dmpik) 2958 dsc3 = dmpik(3) 2959 dsc5 = dmpik(5) 2960 dsc7 = dmpik(7) 2961 psc3 = dmpik(3) 2962 psc5 = dmpik(5) 2963 psc7 = dmpik(7) 2964 if (use_polymer) then 2965 if (r2 .le. polycut2) then 2966 dsc3 = dmpik(3) * dscale(k) 2967 dsc5 = dmpik(5) * dscale(k) 2968 dsc7 = dmpik(7) * dscale(k) 2969 psc3 = dmpik(3) * pscale(k) 2970 psc5 = dmpik(5) * pscale(k) 2971 psc7 = dmpik(7) * pscale(k) 2972 end if 2973 end if 2974 dmp3 = dmpe(3) - (1.0d0-dsc3)*rr3 2975 dmp5 = dmpe(5) - (1.0d0-dsc5)*rr5 2976 dmp7 = dmpe(7) - (1.0d0-dsc7)*rr7 2977 fid(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2978 & - dmp3*dkx + 2.0d0*dmp5*qkx 2979 fid(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2980 & - dmp3*dky + 2.0d0*dmp5*qky 2981 fid(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2982 & - dmp3*dkz + 2.0d0*dmp5*qkz 2983 fkd(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) 2984 & - dmp3*dix - 2.0d0*dmp5*qix 2985 fkd(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) 2986 & - dmp3*diy - 2.0d0*dmp5*qiy 2987 fkd(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) 2988 & - dmp3*diz - 2.0d0*dmp5*qiz 2989 dmp3 = dmpe(3) - (1.0d0-psc3)*rr3 2990 dmp5 = dmpe(5) - (1.0d0-psc5)*rr5 2991 dmp7 = dmpe(7) - (1.0d0-psc7)*rr7 2992 fip(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2993 & - dmp3*dkx + 2.0d0*dmp5*qkx 2994 fip(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2995 & - dmp3*dky + 2.0d0*dmp5*qky 2996 fip(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 2997 & - dmp3*dkz + 2.0d0*dmp5*qkz 2998 fkp(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) 2999 & - dmp3*dix - 2.0d0*dmp5*qix 3000 fkp(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) 3001 & - dmp3*diy - 2.0d0*dmp5*qiy 3002 fkp(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) 3003 & - dmp3*diz - 2.0d0*dmp5*qiz 3004c 3005c find the field components for charge penetration damping 3006c 3007 else if (use_chgpen) then 3008 corek = pcore(kk) 3009 valk = pval(kk) 3010 alphak = palpha(kk) 3011 call dampdir (r,alphai,alphak,dmpi,dmpk) 3012 scalek = 1.0d0 3013 if (use_polymer) then 3014 if (r2 .le. polycut2) then 3015 scalek = dscale(k) 3016 end if 3017 end if 3018 rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 3019 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 3020 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 3021 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 3022 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 3023 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 3024 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 3025 fid(1) = -xr*(rr3*corek + rr3k*valk 3026 & - rr5k*dkr + rr7k*qkr) 3027 & - rr3k*dkx + 2.0d0*rr5k*qkx 3028 fid(2) = -yr*(rr3*corek + rr3k*valk 3029 & - rr5k*dkr + rr7k*qkr) 3030 & - rr3k*dky + 2.0d0*rr5k*qky 3031 fid(3) = -zr*(rr3*corek + rr3k*valk 3032 & - rr5k*dkr + rr7k*qkr) 3033 & - rr3k*dkz + 2.0d0*rr5k*qkz 3034 fkd(1) = xr*(rr3*corei + rr3i*vali 3035 & + rr5i*dir + rr7i*qir) 3036 & - rr3i*dix - 2.0d0*rr5i*qix 3037 fkd(2) = yr*(rr3*corei + rr3i*vali 3038 & + rr5i*dir + rr7i*qir) 3039 & - rr3i*diy - 2.0d0*rr5i*qiy 3040 fkd(3) = zr*(rr3*corei + rr3i*vali 3041 & + rr5i*dir + rr7i*qir) 3042 & - rr3i*diz - 2.0d0*rr5i*qiz 3043 scalek = 1.0d0 3044 if (use_polymer) then 3045 if (r2 .le. polycut2) then 3046 scalek = pscale(k) 3047 end if 3048 end if 3049 rr3 = rr2 * rr1 3050 rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 3051 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 3052 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 3053 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 3054 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 3055 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 3056 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 3057 fip(1) = -xr*(rr3*corek + rr3k*valk 3058 & - rr5k*dkr + rr7k*qkr) 3059 & - rr3k*dkx + 2.0d0*rr5k*qkx 3060 fip(2) = -yr*(rr3*corek + rr3k*valk 3061 & - rr5k*dkr + rr7k*qkr) 3062 & - rr3k*dky + 2.0d0*rr5k*qky 3063 fip(3) = -zr*(rr3*corek + rr3k*valk 3064 & - rr5k*dkr + rr7k*qkr) 3065 & - rr3k*dkz + 2.0d0*rr5k*qkz 3066 fkp(1) = xr*(rr3*corei + rr3i*vali 3067 & + rr5i*dir + rr7i*qir) 3068 & - rr3i*dix - 2.0d0*rr5i*qix 3069 fkp(2) = yr*(rr3*corei + rr3i*vali 3070 & + rr5i*dir + rr7i*qir) 3071 & - rr3i*diy - 2.0d0*rr5i*qiy 3072 fkp(3) = zr*(rr3*corei + rr3i*vali 3073 & + rr5i*dir + rr7i*qir) 3074 & - rr3i*diz - 2.0d0*rr5i*qiz 3075 end if 3076c 3077c increment the field at each site due to this interaction 3078c 3079 do j = 1, 3 3080 field(j,ii) = field(j,ii) + fid(j) 3081 fieldp(j,ii) = fieldp(j,ii) + fid(j) 3082 if (i .ne. k) then 3083 field(j,kk) = field(j,kk) + fkp(j) 3084 fieldp(j,kk) = fieldp(j,kk) + fkp(j) 3085 end if 3086 end do 3087 end if 3088 end do 3089 end do 3090c 3091c reset exclusion coefficients for connected atoms 3092c 3093 if (dpequal) then 3094 do j = 1, n12(i) 3095 pscale(i12(j,i)) = 1.0d0 3096 dscale(i12(j,i)) = 1.0d0 3097 end do 3098 do j = 1, n13(i) 3099 pscale(i13(j,i)) = 1.0d0 3100 dscale(i13(j,i)) = 1.0d0 3101 end do 3102 do j = 1, n14(i) 3103 pscale(i14(j,i)) = 1.0d0 3104 dscale(i14(j,i)) = 1.0d0 3105 end do 3106 do j = 1, n15(i) 3107 pscale(i15(j,i)) = 1.0d0 3108 dscale(i15(j,i)) = 1.0d0 3109 end do 3110 else 3111 do j = 1, n12(i) 3112 pscale(i12(j,i)) = 1.0d0 3113 end do 3114 do j = 1, n13(i) 3115 pscale(i13(j,i)) = 1.0d0 3116 end do 3117 do j = 1, n14(i) 3118 pscale(i14(j,i)) = 1.0d0 3119 end do 3120 do j = 1, n15(i) 3121 pscale(i15(j,i)) = 1.0d0 3122 end do 3123 do j = 1, np11(i) 3124 dscale(ip11(j,i)) = 1.0d0 3125 end do 3126 do j = 1, np12(i) 3127 dscale(ip12(j,i)) = 1.0d0 3128 end do 3129 do j = 1, np13(i) 3130 dscale(ip13(j,i)) = 1.0d0 3131 end do 3132 do j = 1, np14(i) 3133 dscale(ip14(j,i)) = 1.0d0 3134 end do 3135 end if 3136 end do 3137 end if 3138c 3139c perform deallocation of some local arrays 3140c 3141 deallocate (dscale) 3142 deallocate (pscale) 3143 return 3144 end 3145c 3146c 3147c ################################################################## 3148c ## ## 3149c ## subroutine udirect2b -- Ewald real direct field via list ## 3150c ## ## 3151c ################################################################## 3152c 3153c 3154c "udirect2b" computes the real space contribution of the permanent 3155c atomic multipole moments to the field via a neighbor list 3156c 3157c 3158 subroutine udirect2b (field,fieldp) 3159 use atoms 3160 use boxes 3161 use bound 3162 use chgpen 3163 use couple 3164 use math 3165 use mplpot 3166 use mpole 3167 use neigh 3168 use openmp 3169 use polar 3170 use polgrp 3171 use polpot 3172 use shunt 3173 use tarray 3174 use units 3175 implicit none 3176 integer i,j,k,m 3177 integer ii,kk,kkk 3178 integer nlocal,nchunk 3179 integer tid,maxlocal 3180!$ integer omp_get_thread_num 3181 integer, allocatable :: toffset(:) 3182 integer, allocatable :: ilocal(:,:) 3183 real*8 xr,yr,zr 3184 real*8 r,r2,rr1,rr2 3185 real*8 rr3,rr5,rr7 3186 real*8 rr3i,rr5i,rr7i 3187 real*8 rr3k,rr5k,rr7k 3188 real*8 rr3ik,rr5ik 3189 real*8 ci,dix,diy,diz 3190 real*8 qixx,qiyy,qizz 3191 real*8 qixy,qixz,qiyz 3192 real*8 ck,dkx,dky,dkz 3193 real*8 qkxx,qkyy,qkzz 3194 real*8 qkxy,qkxz,qkyz 3195 real*8 dir,dkr 3196 real*8 qix,qiy,qiz,qir 3197 real*8 qkx,qky,qkz,qkr 3198 real*8 corei,corek 3199 real*8 vali,valk 3200 real*8 alphai,alphak 3201 real*8 scalek 3202 real*8 dmp3,dmp5,dmp7 3203 real*8 fid(3),fkd(3) 3204 real*8 fip(3),fkp(3) 3205 real*8 dmpi(7),dmpk(7) 3206 real*8 dmpik(7),dmpe(7) 3207 real*8, allocatable :: pscale(:) 3208 real*8, allocatable :: dscale(:) 3209 real*8, allocatable :: uscale(:) 3210 real*8, allocatable :: wscale(:) 3211 real*8 field(3,*) 3212 real*8 fieldp(3,*) 3213 real*8, allocatable :: fieldt(:,:) 3214 real*8, allocatable :: fieldtp(:,:) 3215 real*8, allocatable :: dlocal(:,:) 3216 character*6 mode 3217c 3218c 3219c check for multipoles and set cutoff coefficients 3220c 3221 if (npole .eq. 0) return 3222 mode = 'EWALD' 3223 call switch (mode) 3224c 3225c values for storage of mutual polarization intermediates 3226c 3227 nchunk = int(0.5d0*dble(npole)/dble(nthread)) + 1 3228 maxlocal = int(dble(npole)*dble(maxelst)/dble(nthread)) 3229 nlocal = 0 3230 ntpair = 0 3231c 3232c perform dynamic allocation of some local arrays 3233c 3234 allocate (pscale(n)) 3235 allocate (dscale(n)) 3236 allocate (uscale(n)) 3237 allocate (wscale(n)) 3238 allocate (fieldt(3,npole)) 3239 allocate (fieldtp(3,npole)) 3240 allocate (toffset(0:nthread-1)) 3241 if (poltyp .ne. 'DIRECT') then 3242 allocate (ilocal(2,maxlocal)) 3243 allocate (dlocal(6,maxlocal)) 3244 end if 3245c 3246c set arrays needed to scale connected atom interactions 3247c 3248 do i = 1, n 3249 pscale(i) = 1.0d0 3250 wscale(i) = 1.0d0 3251 dscale(i) = 1.0d0 3252 uscale(i) = 1.0d0 3253 end do 3254c 3255c initialize local variables for OpenMP calculation 3256c 3257 do ii = 1, npole 3258 do j = 1, 3 3259 fieldt(j,ii) = 0.0d0 3260 fieldtp(j,ii) = 0.0d0 3261 end do 3262 end do 3263c 3264c OpenMP directives for the major loop structure 3265c 3266!$OMP PARALLEL default(private) shared(npole,ipole,rpole,x,y,z,pcore, 3267!$OMP& pval,palpha,p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale, 3268!$OMP& p4iscale,p5iscale,w2scale,w3scale,w4scale,w5scale,d1scale, 3269!$OMP& d2scale,d3scale,d4scale,u1scale,u2scale,u3scale,u4scale,n12,i12, 3270!$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14, 3271!$OMP& nelst,elst,dpequal,use_thole,use_chgpen,use_bounds,off2,poltyp, 3272!$OMP& nchunk,ntpair,tindex,tdipdip,toffset,field,fieldp,fieldt,fieldtp) 3273!$OMP& firstprivate(pscale,dscale,uscale,wscale,nlocal) 3274!$OMP DO reduction(+:fieldt,fieldtp) schedule(static,nchunk) 3275c 3276c compute the real space portion of the Ewald summation 3277c 3278 do ii = 1, npole 3279 i = ipole(ii) 3280 ci = rpole(1,ii) 3281 dix = rpole(2,ii) 3282 diy = rpole(3,ii) 3283 diz = rpole(4,ii) 3284 qixx = rpole(5,ii) 3285 qixy = rpole(6,ii) 3286 qixz = rpole(7,ii) 3287 qiyy = rpole(9,ii) 3288 qiyz = rpole(10,ii) 3289 qizz = rpole(13,ii) 3290 if (use_chgpen) then 3291 corei = pcore(ii) 3292 vali = pval(ii) 3293 alphai = palpha(ii) 3294 end if 3295c 3296c set exclusion coefficients for connected atoms 3297c 3298 if (dpequal) then 3299 do j = 1, n12(i) 3300 pscale(i12(j,i)) = p2scale 3301 do k = 1, np11(i) 3302 if (i12(j,i) .eq. ip11(k,i)) 3303 & pscale(i12(j,i)) = p2iscale 3304 end do 3305 dscale(i12(j,i)) = pscale(i12(j,i)) 3306 wscale(i12(j,i)) = w2scale 3307 end do 3308 do j = 1, n13(i) 3309 pscale(i13(j,i)) = p3scale 3310 do k = 1, np11(i) 3311 if (i13(j,i) .eq. ip11(k,i)) 3312 & pscale(i13(j,i)) = p3iscale 3313 end do 3314 dscale(i13(j,i)) = pscale(i13(j,i)) 3315 wscale(i13(j,i)) = w3scale 3316 end do 3317 do j = 1, n14(i) 3318 pscale(i14(j,i)) = p4scale 3319 do k = 1, np11(i) 3320 if (i14(j,i) .eq. ip11(k,i)) 3321 & pscale(i14(j,i)) = p4iscale 3322 end do 3323 dscale(i14(j,i)) = pscale(i14(j,i)) 3324 wscale(i14(j,i)) = w4scale 3325 end do 3326 do j = 1, n15(i) 3327 pscale(i15(j,i)) = p5scale 3328 do k = 1, np11(i) 3329 if (i15(j,i) .eq. ip11(k,i)) 3330 & pscale(i15(j,i)) = p5iscale 3331 end do 3332 dscale(i15(j,i)) = pscale(i15(j,i)) 3333 wscale(i15(j,i)) = w5scale 3334 end do 3335 do j = 1, np11(i) 3336 uscale(ip11(j,i)) = u1scale 3337 end do 3338 do j = 1, np12(i) 3339 uscale(ip12(j,i)) = u2scale 3340 end do 3341 do j = 1, np13(i) 3342 uscale(ip13(j,i)) = u3scale 3343 end do 3344 do j = 1, np14(i) 3345 uscale(ip14(j,i)) = u4scale 3346 end do 3347 else 3348 do j = 1, n12(i) 3349 pscale(i12(j,i)) = p2scale 3350 do k = 1, np11(i) 3351 if (i12(j,i) .eq. ip11(k,i)) 3352 & pscale(i12(j,i)) = p2iscale 3353 end do 3354 wscale(i12(j,i)) = w2scale 3355 end do 3356 do j = 1, n13(i) 3357 pscale(i13(j,i)) = p3scale 3358 do k = 1, np11(i) 3359 if (i13(j,i) .eq. ip11(k,i)) 3360 & pscale(i13(j,i)) = p3iscale 3361 end do 3362 wscale(i13(j,i)) = w3scale 3363 end do 3364 do j = 1, n14(i) 3365 pscale(i14(j,i)) = p4scale 3366 do k = 1, np11(i) 3367 if (i14(j,i) .eq. ip11(k,i)) 3368 & pscale(i14(j,i)) = p4iscale 3369 end do 3370 wscale(i14(j,i)) = w4scale 3371 end do 3372 do j = 1, n15(i) 3373 pscale(i15(j,i)) = p5scale 3374 do k = 1, np11(i) 3375 if (i15(j,i) .eq. ip11(k,i)) 3376 & pscale(i15(j,i)) = p5iscale 3377 end do 3378 wscale(i15(j,i)) = w5scale 3379 end do 3380 do j = 1, np11(i) 3381 dscale(ip11(j,i)) = d1scale 3382 uscale(ip11(j,i)) = u1scale 3383 end do 3384 do j = 1, np12(i) 3385 dscale(ip12(j,i)) = d2scale 3386 uscale(ip12(j,i)) = u2scale 3387 end do 3388 do j = 1, np13(i) 3389 dscale(ip13(j,i)) = d3scale 3390 uscale(ip13(j,i)) = u3scale 3391 end do 3392 do j = 1, np14(i) 3393 dscale(ip14(j,i)) = d4scale 3394 uscale(ip14(j,i)) = u4scale 3395 end do 3396 end if 3397c 3398c evaluate all sites within the cutoff distance 3399c 3400 do kkk = 1, nelst(ii) 3401 kk = elst(kkk,ii) 3402 k = ipole(kk) 3403 xr = x(k) - x(i) 3404 yr = y(k) - y(i) 3405 zr = z(k) - z(i) 3406 if (use_bounds) call image (xr,yr,zr) 3407 r2 = xr*xr + yr* yr + zr*zr 3408 if (r2 .le. off2) then 3409 r = sqrt(r2) 3410 rr1 = 1.0d0 / r 3411 rr2 = rr1 * rr1 3412 rr3 = rr2 * rr1 3413 rr5 = 3.0d0 * rr2 * rr3 3414 rr7 = 5.0d0 * rr2 * rr5 3415 ck = rpole(1,kk) 3416 dkx = rpole(2,kk) 3417 dky = rpole(3,kk) 3418 dkz = rpole(4,kk) 3419 qkxx = rpole(5,kk) 3420 qkxy = rpole(6,kk) 3421 qkxz = rpole(7,kk) 3422 qkyy = rpole(9,kk) 3423 qkyz = rpole(10,kk) 3424 qkzz = rpole(13,kk) 3425c 3426c intermediates involving moments and separation distance 3427c 3428 dir = dix*xr + diy*yr + diz*zr 3429 qix = qixx*xr + qixy*yr + qixz*zr 3430 qiy = qixy*xr + qiyy*yr + qiyz*zr 3431 qiz = qixz*xr + qiyz*yr + qizz*zr 3432 qir = qix*xr + qiy*yr + qiz*zr 3433 dkr = dkx*xr + dky*yr + dkz*zr 3434 qkx = qkxx*xr + qkxy*yr + qkxz*zr 3435 qky = qkxy*xr + qkyy*yr + qkyz*zr 3436 qkz = qkxz*xr + qkyz*yr + qkzz*zr 3437 qkr = qkx*xr + qky*yr + qkz*zr 3438c 3439c calculate real space Ewald error function damping 3440c 3441 call dampewald (7,r,r2,1.0d0,dmpe) 3442c 3443c find the field components for Thole polarization damping 3444c 3445 if (use_thole) then 3446 call dampthole (ii,kk,7,r,dmpik) 3447 scalek = dscale(k) 3448 dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 3449 dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 3450 dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7 3451 fid(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 3452 & - dmp3*dkx + 2.0d0*dmp5*qkx 3453 fid(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 3454 & - dmp3*dky + 2.0d0*dmp5*qky 3455 fid(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 3456 & - dmp3*dkz + 2.0d0*dmp5*qkz 3457 fkd(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) 3458 & - dmp3*dix - 2.0d0*dmp5*qix 3459 fkd(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) 3460 & - dmp3*diy - 2.0d0*dmp5*qiy 3461 fkd(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) 3462 & - dmp3*diz - 2.0d0*dmp5*qiz 3463 scalek = pscale(k) 3464 dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 3465 dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 3466 dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7 3467 fip(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 3468 & - dmp3*dkx + 2.0d0*dmp5*qkx 3469 fip(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 3470 & - dmp3*dky + 2.0d0*dmp5*qky 3471 fip(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) 3472 & - dmp3*dkz + 2.0d0*dmp5*qkz 3473 fkp(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) 3474 & - dmp3*dix - 2.0d0*dmp5*qix 3475 fkp(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) 3476 & - dmp3*diy - 2.0d0*dmp5*qiy 3477 fkp(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) 3478 & - dmp3*diz - 2.0d0*dmp5*qiz 3479c 3480c find terms needed later to compute mutual polarization 3481c 3482 if (poltyp .ne. 'DIRECT') then 3483 call dampthole2 (ii,kk,5,r,dmpik) 3484 scalek = uscale(k) 3485 dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 3486 dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 3487 nlocal = nlocal + 1 3488 ilocal(1,nlocal) = ii 3489 ilocal(2,nlocal) = kk 3490 dlocal(1,nlocal) = -dmp3 + dmp5*xr*xr 3491 dlocal(2,nlocal) = dmp5*xr*yr 3492 dlocal(3,nlocal) = dmp5*xr*zr 3493 dlocal(4,nlocal) = -dmp3 + dmp5*yr*yr 3494 dlocal(5,nlocal) = dmp5*yr*zr 3495 dlocal(6,nlocal) = -dmp3 + dmp5*zr*zr 3496 end if 3497c 3498c find the field components for charge penetration damping 3499c 3500 else if (use_chgpen) then 3501 corek = pcore(kk) 3502 valk = pval(kk) 3503 alphak = palpha(kk) 3504 call dampdir (r,alphai,alphak,dmpi,dmpk) 3505 scalek = dscale(k) 3506 rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 3507 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 3508 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 3509 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 3510 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 3511 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 3512 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 3513 fid(1) = -xr*(rr3*corek + rr3k*valk 3514 & - rr5k*dkr + rr7k*qkr) 3515 & - rr3k*dkx + 2.0d0*rr5k*qkx 3516 fid(2) = -yr*(rr3*corek + rr3k*valk 3517 & - rr5k*dkr + rr7k*qkr) 3518 & - rr3k*dky + 2.0d0*rr5k*qky 3519 fid(3) = -zr*(rr3*corek + rr3k*valk 3520 & - rr5k*dkr + rr7k*qkr) 3521 & - rr3k*dkz + 2.0d0*rr5k*qkz 3522 fkd(1) = xr*(rr3*corei + rr3i*vali 3523 & + rr5i*dir + rr7i*qir) 3524 & - rr3i*dix - 2.0d0*rr5i*qix 3525 fkd(2) = yr*(rr3*corei + rr3i*vali 3526 & + rr5i*dir + rr7i*qir) 3527 & - rr3i*diy - 2.0d0*rr5i*qiy 3528 fkd(3) = zr*(rr3*corei + rr3i*vali 3529 & + rr5i*dir + rr7i*qir) 3530 & - rr3i*diz - 2.0d0*rr5i*qiz 3531 scalek = pscale(k) 3532 rr3 = rr2 * rr1 3533 rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 3534 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 3535 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 3536 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 3537 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 3538 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 3539 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 3540 fip(1) = -xr*(rr3*corek + rr3k*valk 3541 & - rr5k*dkr + rr7k*qkr) 3542 & - rr3k*dkx + 2.0d0*rr5k*qkx 3543 fip(2) = -yr*(rr3*corek + rr3k*valk 3544 & - rr5k*dkr + rr7k*qkr) 3545 & - rr3k*dky + 2.0d0*rr5k*qky 3546 fip(3) = -zr*(rr3*corek + rr3k*valk 3547 & - rr5k*dkr + rr7k*qkr) 3548 & - rr3k*dkz + 2.0d0*rr5k*qkz 3549 fkp(1) = xr*(rr3*corei + rr3i*vali 3550 & + rr5i*dir + rr7i*qir) 3551 & - rr3i*dix - 2.0d0*rr5i*qix 3552 fkp(2) = yr*(rr3*corei + rr3i*vali 3553 & + rr5i*dir + rr7i*qir) 3554 & - rr3i*diy - 2.0d0*rr5i*qiy 3555 fkp(3) = zr*(rr3*corei + rr3i*vali 3556 & + rr5i*dir + rr7i*qir) 3557 & - rr3i*diz - 2.0d0*rr5i*qiz 3558c 3559c find terms needed later to compute mutual polarization 3560c 3561 if (poltyp .ne. 'DIRECT') then 3562 call dampmut (r,alphai,alphak,dmpik) 3563 scalek = wscale(k) 3564 rr3 = rr2 * rr1 3565 rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 3566 rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 3567 nlocal = nlocal + 1 3568 ilocal(1,nlocal) = ii 3569 ilocal(2,nlocal) = kk 3570 dlocal(1,nlocal) = -rr3ik + rr5ik*xr*xr 3571 dlocal(2,nlocal) = rr5ik*xr*yr 3572 dlocal(3,nlocal) = rr5ik*xr*zr 3573 dlocal(4,nlocal) = -rr3ik + rr5ik*yr*yr 3574 dlocal(5,nlocal) = rr5ik*yr*zr 3575 dlocal(6,nlocal) = -rr3ik + rr5ik*zr*zr 3576 end if 3577 end if 3578c 3579c increment the field at each site due to this interaction 3580c 3581 do j = 1, 3 3582 fieldt(j,ii) = fieldt(j,ii) + fid(j) 3583 fieldt(j,kk) = fieldt(j,kk) + fkd(j) 3584 fieldtp(j,ii) = fieldtp(j,ii) + fip(j) 3585 fieldtp(j,kk) = fieldtp(j,kk) + fkp(j) 3586 end do 3587 end if 3588 end do 3589c 3590c reset exclusion coefficients for connected atoms 3591c 3592 if (dpequal) then 3593 do j = 1, n12(i) 3594 pscale(i12(j,i)) = 1.0d0 3595 dscale(i12(j,i)) = 1.0d0 3596 wscale(i12(j,i)) = 1.0d0 3597 end do 3598 do j = 1, n13(i) 3599 pscale(i13(j,i)) = 1.0d0 3600 dscale(i13(j,i)) = 1.0d0 3601 wscale(i13(j,i)) = 1.0d0 3602 end do 3603 do j = 1, n14(i) 3604 pscale(i14(j,i)) = 1.0d0 3605 dscale(i14(j,i)) = 1.0d0 3606 wscale(i14(j,i)) = 1.0d0 3607 end do 3608 do j = 1, n15(i) 3609 pscale(i15(j,i)) = 1.0d0 3610 dscale(i15(j,i)) = 1.0d0 3611 wscale(i15(j,i)) = 1.0d0 3612 end do 3613 do j = 1, np11(i) 3614 uscale(ip11(j,i)) = 1.0d0 3615 end do 3616 do j = 1, np12(i) 3617 uscale(ip12(j,i)) = 1.0d0 3618 end do 3619 do j = 1, np13(i) 3620 uscale(ip13(j,i)) = 1.0d0 3621 end do 3622 do j = 1, np14(i) 3623 uscale(ip14(j,i)) = 1.0d0 3624 end do 3625 else 3626 do j = 1, n12(i) 3627 pscale(i12(j,i)) = 1.0d0 3628 wscale(i12(j,i)) = 1.0d0 3629 end do 3630 do j = 1, n13(i) 3631 pscale(i13(j,i)) = 1.0d0 3632 wscale(i13(j,i)) = 1.0d0 3633 end do 3634 do j = 1, n14(i) 3635 pscale(i14(j,i)) = 1.0d0 3636 wscale(i14(j,i)) = 1.0d0 3637 end do 3638 do j = 1, n15(i) 3639 pscale(i15(j,i)) = 1.0d0 3640 wscale(i15(j,i)) = 1.0d0 3641 end do 3642 do j = 1, np11(i) 3643 dscale(ip11(j,i)) = 1.0d0 3644 uscale(ip11(j,i)) = 1.0d0 3645 end do 3646 do j = 1, np12(i) 3647 dscale(ip12(j,i)) = 1.0d0 3648 uscale(ip12(j,i)) = 1.0d0 3649 end do 3650 do j = 1, np13(i) 3651 dscale(ip13(j,i)) = 1.0d0 3652 uscale(ip13(j,i)) = 1.0d0 3653 end do 3654 do j = 1, np14(i) 3655 dscale(ip14(j,i)) = 1.0d0 3656 uscale(ip14(j,i)) = 1.0d0 3657 end do 3658 end if 3659 end do 3660!$OMP END DO 3661c 3662c find offset into global arrays for the current thread 3663c 3664!$OMP CRITICAL 3665 tid = 0 3666!$ tid = omp_get_thread_num () 3667 toffset(tid) = ntpair 3668 ntpair = ntpair + nlocal 3669!$OMP END CRITICAL 3670c 3671c store terms used later to compute mutual polarization 3672c 3673 if (poltyp .ne. 'DIRECT') then 3674 k = toffset(tid) 3675 do i = 1, nlocal 3676 m = k + i 3677 tindex(1,m) = ilocal(1,i) 3678 tindex(2,m) = ilocal(2,i) 3679 do j = 1, 6 3680 tdipdip(j,m) = dlocal(j,i) 3681 end do 3682 end do 3683 end if 3684c 3685c add local to global variables for OpenMP calculation 3686c 3687!$OMP DO 3688 do ii = 1, npole 3689 do j = 1, 3 3690 field(j,ii) = field(j,ii) + fieldt(j,ii) 3691 fieldp(j,ii) = fieldp(j,ii) + fieldtp(j,ii) 3692 end do 3693 end do 3694!$OMP END DO 3695!$OMP END PARALLEL 3696c 3697c perform deallocation of some local arrays 3698c 3699 deallocate (pscale) 3700 deallocate (wscale) 3701 deallocate (dscale) 3702 deallocate (uscale) 3703 deallocate (fieldt) 3704 deallocate (fieldtp) 3705 deallocate (toffset) 3706 if (allocated(ilocal)) deallocate (ilocal) 3707 if (allocated(dlocal)) deallocate (dlocal) 3708 return 3709 end 3710c 3711c 3712c ############################################################### 3713c ## ## 3714c ## subroutine ufield0c -- mutual induction via Ewald sum ## 3715c ## ## 3716c ############################################################### 3717c 3718c 3719c "ufield0c" computes the mutual electrostatic field due to 3720c induced dipole moments via Ewald summation 3721c 3722c 3723 subroutine ufield0c (field,fieldp) 3724 use atoms 3725 use boxes 3726 use ewald 3727 use limits 3728 use math 3729 use mpole 3730 use pme 3731 use polar 3732 implicit none 3733 integer ii,j 3734 real*8 term 3735 real*8 ucell(3) 3736 real*8 ucellp(3) 3737 real*8 field(3,*) 3738 real*8 fieldp(3,*) 3739c 3740c 3741c zero out the electrostatic field at each site 3742c 3743 do ii = 1, npole 3744 do j = 1, 3 3745 field(j,ii) = 0.0d0 3746 fieldp(j,ii) = 0.0d0 3747 end do 3748 end do 3749c 3750c set grid size, spline order and Ewald coefficient 3751c 3752 nfft1 = nefft1 3753 nfft2 = nefft2 3754 nfft3 = nefft3 3755 bsorder = bsporder 3756 aewald = apewald 3757c 3758c get the reciprocal space part of the mutual field 3759c 3760 call umutual1 (field,fieldp) 3761c 3762c get the real space portion of the mutual field 3763c 3764 if (use_mlist) then 3765 call umutual2b (field,fieldp) 3766 else 3767 call umutual2a (field,fieldp) 3768 end if 3769c 3770c get the self-energy portion of the mutual field 3771c 3772 term = (4.0d0/3.0d0) * aewald**3 / rootpi 3773 do ii = 1, npole 3774 do j = 1, 3 3775 field(j,ii) = field(j,ii) + term*uind(j,ii) 3776 fieldp(j,ii) = fieldp(j,ii) + term*uinp(j,ii) 3777 end do 3778 end do 3779c 3780c compute the cell dipole boundary correction to the field 3781c 3782 if (boundary .eq. 'VACUUM') then 3783 do j = 1, 3 3784 ucell(j) = 0.0d0 3785 ucellp(j) = 0.0d0 3786 end do 3787 do ii = 1, npole 3788 do j = 1, 3 3789 ucell(j) = ucell(j) + uind(j,ii) 3790 ucellp(j) = ucellp(j) + uinp(j,ii) 3791 end do 3792 end do 3793 term = (4.0d0/3.0d0) * pi/volbox 3794 do ii = 1, npole 3795 do j = 1, 3 3796 field(j,ii) = field(j,ii) - term*ucell(j) 3797 fieldp(j,ii) = fieldp(j,ii) - term*ucellp(j) 3798 end do 3799 end do 3800 end if 3801 return 3802 end 3803c 3804c 3805c ################################################################# 3806c ## ## 3807c ## subroutine umutual1 -- Ewald recip mutual induced field ## 3808c ## ## 3809c ################################################################# 3810c 3811c 3812c "umutual1" computes the reciprocal space contribution of the 3813c induced atomic dipole moments to the field 3814c 3815c 3816 subroutine umutual1 (field,fieldp) 3817 use boxes 3818 use ewald 3819 use math 3820 use mpole 3821 use pme 3822 use polar 3823 use polopt 3824 use polpot 3825 implicit none 3826 integer i,j,k,ii 3827 real*8 term 3828 real*8 a(3,3) 3829 real*8 field(3,*) 3830 real*8 fieldp(3,*) 3831 real*8, allocatable :: fuind(:,:) 3832 real*8, allocatable :: fuinp(:,:) 3833 real*8, allocatable :: fdip_phi1(:,:) 3834 real*8, allocatable :: fdip_phi2(:,:) 3835 real*8, allocatable :: fdip_sum_phi(:,:) 3836 real*8, allocatable :: dipfield1(:,:) 3837 real*8, allocatable :: dipfield2(:,:) 3838c 3839c 3840c return if the Ewald coefficient is zero 3841c 3842 if (aewald .lt. 1.0d-6) return 3843c 3844c perform dynamic allocation of some local arrays 3845c 3846 allocate (fuind(3,npole)) 3847 allocate (fuinp(3,npole)) 3848 allocate (fdip_phi1(10,npole)) 3849 allocate (fdip_phi2(10,npole)) 3850 allocate (fdip_sum_phi(20,npole)) 3851 allocate (dipfield1(3,npole)) 3852 allocate (dipfield2(3,npole)) 3853c 3854c convert Cartesian dipoles to fractional coordinates 3855c 3856 do i = 1, 3 3857 a(1,i) = dble(nfft1) * recip(i,1) 3858 a(2,i) = dble(nfft2) * recip(i,2) 3859 a(3,i) = dble(nfft3) * recip(i,3) 3860 end do 3861 do ii = 1, npole 3862 do j = 1, 3 3863 fuind(j,ii) = a(j,1)*uind(1,ii) + a(j,2)*uind(2,ii) 3864 & + a(j,3)*uind(3,ii) 3865 fuinp(j,ii) = a(j,1)*uinp(1,ii) + a(j,2)*uinp(2,ii) 3866 & + a(j,3)*uinp(3,ii) 3867 end do 3868 end do 3869c 3870c assign PME grid and perform 3-D FFT forward transform 3871c 3872 call grid_uind (fuind,fuinp) 3873 call fftfront 3874c 3875c complete the transformation of the PME grid 3876c 3877 do k = 1, nfft3 3878 do j = 1, nfft2 3879 do i = 1, nfft1 3880 term = qfac(i,j,k) 3881 qgrid(1,i,j,k) = term * qgrid(1,i,j,k) 3882 qgrid(2,i,j,k) = term * qgrid(2,i,j,k) 3883 end do 3884 end do 3885 end do 3886c 3887c perform 3-D FFT backward transform and get field 3888c 3889 call fftback 3890 call fphi_uind (fdip_phi1,fdip_phi2,fdip_sum_phi) 3891c 3892c store fractional reciprocal potentials for OPT method 3893c 3894 if (poltyp .eq. 'OPT') then 3895 do ii = 1, npole 3896 do j = 1, 10 3897 fopt(optlevel,j,ii) = fdip_phi1(j,ii) 3898 foptp(optlevel,j,ii) = fdip_phi2(j,ii) 3899 end do 3900 end do 3901 end if 3902c 3903c convert the dipole fields from fractional to Cartesian 3904c 3905 do i = 1, 3 3906 a(i,1) = dble(nfft1) * recip(i,1) 3907 a(i,2) = dble(nfft2) * recip(i,2) 3908 a(i,3) = dble(nfft3) * recip(i,3) 3909 end do 3910 do ii = 1, npole 3911 do j = 1, 3 3912 dipfield1(j,ii) = a(j,1)*fdip_phi1(2,ii) 3913 & + a(j,2)*fdip_phi1(3,ii) 3914 & + a(j,3)*fdip_phi1(4,ii) 3915 dipfield2(j,ii) = a(j,1)*fdip_phi2(2,ii) 3916 & + a(j,2)*fdip_phi2(3,ii) 3917 & + a(j,3)*fdip_phi2(4,ii) 3918 end do 3919 end do 3920c 3921c increment the field at each multipole site 3922c 3923 do ii = 1, npole 3924 do j = 1, 3 3925 field(j,ii) = field(j,ii) - dipfield1(j,ii) 3926 fieldp(j,ii) = fieldp(j,ii) - dipfield2(j,ii) 3927 end do 3928 end do 3929c 3930c perform deallocation of some local arrays 3931c 3932 deallocate (fuind) 3933 deallocate (fuinp) 3934 deallocate (fdip_phi1) 3935 deallocate (fdip_phi2) 3936 deallocate (fdip_sum_phi) 3937 deallocate (dipfield1) 3938 deallocate (dipfield2) 3939 return 3940 end 3941c 3942c 3943c ################################################################## 3944c ## ## 3945c ## subroutine umutual2a -- Ewald real mutual field via loop ## 3946c ## ## 3947c ################################################################## 3948c 3949c 3950c "umutual2a" computes the real space contribution of the induced 3951c atomic dipole moments to the field via a double loop 3952c 3953c 3954 subroutine umutual2a (field,fieldp) 3955 use atoms 3956 use boxes 3957 use bound 3958 use cell 3959 use chgpen 3960 use couple 3961 use math 3962 use mplpot 3963 use mpole 3964 use polar 3965 use polgrp 3966 use polpot 3967 use shunt 3968 use units 3969 implicit none 3970 integer i,j,k,m 3971 integer ii,kk 3972 real*8 xr,yr,zr 3973 real*8 r,r2,rr1 3974 real*8 rr2,rr3,rr5 3975 real*8 dix,diy,diz 3976 real*8 pix,piy,piz 3977 real*8 dkx,dky,dkz 3978 real*8 pkx,pky,pkz 3979 real*8 dir,dkr 3980 real*8 pir,pkr 3981 real*8 corei,corek 3982 real*8 vali,valk 3983 real*8 alphai,alphak 3984 real*8 fid(3),fkd(3) 3985 real*8 fip(3),fkp(3) 3986 real*8 dmpik(5),dmpe(5) 3987 real*8, allocatable :: uscale(:) 3988 real*8, allocatable :: wscale(:) 3989 real*8 field(3,*) 3990 real*8 fieldp(3,*) 3991 character*6 mode 3992c 3993c 3994c check for multipoles and set cutoff coefficients 3995c 3996 if (npole .eq. 0) return 3997 mode = 'EWALD' 3998 call switch (mode) 3999c 4000c perform dynamic allocation of some local arrays 4001c 4002 allocate (uscale(n)) 4003 allocate (wscale(n)) 4004c 4005c set array needed to scale connected atom interactions 4006c 4007 do i = 1, n 4008 uscale(i) = 1.0d0 4009 wscale(i) = 1.0d0 4010 end do 4011c 4012c compute the real space portion of the Ewald summation 4013c 4014 do ii = 1, npole-1 4015 i = ipole(ii) 4016 dix = uind(1,ii) 4017 diy = uind(2,ii) 4018 diz = uind(3,ii) 4019 pix = uinp(1,ii) 4020 piy = uinp(2,ii) 4021 piz = uinp(3,ii) 4022 if (use_chgpen) then 4023 corei = pcore(ii) 4024 vali = pval(ii) 4025 alphai = palpha(ii) 4026 end if 4027c 4028c set exclusion coefficients for connected atoms 4029c 4030 do j = 1, np11(i) 4031 uscale(ip11(j,i)) = u1scale 4032 end do 4033 do j = 1, np12(i) 4034 uscale(ip12(j,i)) = u2scale 4035 end do 4036 do j = 1, np13(i) 4037 uscale(ip13(j,i)) = u3scale 4038 end do 4039 do j = 1, np14(i) 4040 uscale(ip14(j,i)) = u4scale 4041 end do 4042 do j = 1, n12(i) 4043 wscale(i12(j,i)) = w2scale 4044 end do 4045 do j = 1, n13(i) 4046 wscale(i13(j,i)) = w3scale 4047 end do 4048 do j = 1, n14(i) 4049 wscale(i14(j,i)) = w4scale 4050 end do 4051 do j = 1, n15(i) 4052 wscale(i15(j,i)) = w5scale 4053 end do 4054c 4055c evaluate all sites within the cutoff distance 4056c 4057 do kk = ii+1, npole 4058 k = ipole(kk) 4059 xr = x(k) - x(i) 4060 yr = y(k) - y(i) 4061 zr = z(k) - z(i) 4062 call image (xr,yr,zr) 4063 r2 = xr*xr + yr* yr + zr*zr 4064 if (r2 .le. off2) then 4065 r = sqrt(r2) 4066 rr1 = 1.0d0 / r 4067 rr2 = rr1 * rr1 4068 rr3 = rr2 * rr1 4069 rr5 = rr2 * rr3 4070 dkx = uind(1,k) 4071 dky = uind(2,k) 4072 dkz = uind(3,k) 4073 pkx = uinp(1,k) 4074 pky = uinp(2,k) 4075 pkz = uinp(3,k) 4076c 4077c intermediates involving moments and separation distance 4078c 4079 dir = dix*xr + diy*yr + diz*zr 4080 dkr = dkx*xr + dky*yr + dkz*zr 4081 pir = pix*xr + piy*yr + piz*zr 4082 pkr = pkx*xr + pky*yr + pkz*zr 4083c 4084c calculate real space Ewald error function damping 4085c 4086 call dampewald (5,r,r2,1.0d0,dmpe) 4087c 4088c find the field components for Thole polarization damping 4089c 4090 if (use_thole) then 4091 call dampthole2 (ii,kk,5,r,dmpik) 4092 dmpik(3) = uscale(k) * dmpik(3) 4093 dmpik(5) = uscale(k) * dmpik(5) 4094c 4095c find the field components for charge penetration damping 4096c 4097 else if (use_chgpen) then 4098 corek = pcore(kk) 4099 valk = pval(kk) 4100 alphak = palpha(kk) 4101 call dampmut (r,alphai,alphak,dmpik) 4102 dmpik(3) = wscale(k) * dmpik(3) 4103 dmpik(5) = wscale(k) * dmpik(5) 4104 end if 4105c 4106c find the field terms for the current interaction 4107c 4108 rr3 = -dmpe(3) + (1.0d0-dmpik(3))*rr3 4109 rr5 = dmpe(5) - 3.0d0*(1.0d0-dmpik(5))*rr5 4110 fid(1) = rr3*dkx + rr5*dkr*xr 4111 fid(2) = rr3*dky + rr5*dkr*yr 4112 fid(3) = rr3*dkz + rr5*dkr*zr 4113 fkd(1) = rr3*dix + rr5*dir*xr 4114 fkd(2) = rr3*diy + rr5*dir*yr 4115 fkd(3) = rr3*diz + rr5*dir*zr 4116 fip(1) = rr3*pkx + rr5*pkr*xr 4117 fip(2) = rr3*pky + rr5*pkr*yr 4118 fip(3) = rr3*pkz + rr5*pkr*zr 4119 fkp(1) = rr3*pix + rr5*pir*xr 4120 fkp(2) = rr3*piy + rr5*pir*yr 4121 fkp(3) = rr3*piz + rr5*pir*zr 4122c 4123c increment the field at each site due to this interaction 4124c 4125 do j = 1, 3 4126 field(j,ii) = field(j,ii) + fid(j) 4127 field(j,kk) = field(j,kk) + fkd(j) 4128 fieldp(j,ii) = fieldp(j,ii) + fip(j) 4129 fieldp(j,kk) = fieldp(j,kk) + fkp(j) 4130 end do 4131 end if 4132 end do 4133c 4134c reset exclusion coefficients for connected atoms 4135c 4136 do j = 1, np11(i) 4137 uscale(ip11(j,i)) = 1.0d0 4138 end do 4139 do j = 1, np12(i) 4140 uscale(ip12(j,i)) = 1.0d0 4141 end do 4142 do j = 1, np13(i) 4143 uscale(ip13(j,i)) = 1.0d0 4144 end do 4145 do j = 1, np14(i) 4146 uscale(ip14(j,i)) = 1.0d0 4147 end do 4148 do j = 1, n12(i) 4149 wscale(i12(j,i)) = 1.0d0 4150 end do 4151 do j = 1, n13(i) 4152 wscale(i13(j,i)) = 1.0d0 4153 end do 4154 do j = 1, n14(i) 4155 wscale(i14(j,i)) = 1.0d0 4156 end do 4157 do j = 1, n15(i) 4158 wscale(i15(j,i)) = 1.0d0 4159 end do 4160 end do 4161c 4162c periodic boundary for large cutoffs via replicates method 4163c 4164 if (use_replica) then 4165 do ii = 1, npole 4166 i = ipole(ii) 4167 dix = uind(1,ii) 4168 diy = uind(2,ii) 4169 diz = uind(3,ii) 4170 pix = uinp(1,ii) 4171 piy = uinp(2,ii) 4172 piz = uinp(3,ii) 4173 if (use_chgpen) then 4174 corei = pcore(ii) 4175 vali = pval(ii) 4176 alphai = palpha(ii) 4177 end if 4178c 4179c set exclusion coefficients for connected atoms 4180c 4181 do j = 1, np11(i) 4182 uscale(ip11(j,i)) = u1scale 4183 end do 4184 do j = 1, np12(i) 4185 uscale(ip12(j,i)) = u2scale 4186 end do 4187 do j = 1, np13(i) 4188 uscale(ip13(j,i)) = u3scale 4189 end do 4190 do j = 1, np14(i) 4191 uscale(ip14(j,i)) = u4scale 4192 end do 4193 do j = 1, n12(i) 4194 wscale(i12(j,i)) = w2scale 4195 end do 4196 do j = 1, n13(i) 4197 wscale(i13(j,i)) = w3scale 4198 end do 4199 do j = 1, n14(i) 4200 wscale(i14(j,i)) = w4scale 4201 end do 4202 do j = 1, n15(i) 4203 wscale(i15(j,i)) = w5scale 4204 end do 4205c 4206c evaluate all sites within the cutoff distance 4207c 4208 do kk = ii, npole 4209 k = ipole(kk) 4210 dkx = uind(1,kk) 4211 dky = uind(2,kk) 4212 dkz = uind(3,kk) 4213 pkx = uinp(1,kk) 4214 pky = uinp(2,kk) 4215 pkz = uinp(3,kk) 4216 do m = 2, ncell 4217 xr = x(k) - x(i) 4218 yr = y(k) - y(i) 4219 zr = z(k) - z(i) 4220 call imager (xr,yr,zr,m) 4221 r2 = xr*xr + yr* yr + zr*zr 4222 if (r2 .le. off2) then 4223 r = sqrt(r2) 4224 rr1 = 1.0d0 / r 4225 rr2 = rr1 * rr1 4226 rr3 = rr2 * rr1 4227 rr5 = rr2 * rr3 4228c 4229c intermediates involving moments and separation distance 4230c 4231 dir = dix*xr + diy*yr + diz*zr 4232 dkr = dkx*xr + dky*yr + dkz*zr 4233 pir = pix*xr + piy*yr + piz*zr 4234 pkr = pkx*xr + pky*yr + pkz*zr 4235c 4236c calculate real space Ewald error function damping 4237c 4238 call dampewald (5,r,r2,1.0d0,dmpe) 4239c 4240c find the field components for Thole polarization damping 4241c 4242 if (use_thole) then 4243 call dampthole2 (ii,kk,5,r,dmpik) 4244 dmpik(3) = uscale(k) * dmpik(3) 4245 dmpik(5) = uscale(k) * dmpik(5) 4246c 4247c find the field components for charge penetration damping 4248c 4249 else if (use_chgpen) then 4250 corek = pcore(kk) 4251 valk = pval(kk) 4252 alphak = palpha(kk) 4253 call dampmut (r,alphai,alphak,dmpik) 4254 dmpik(3) = wscale(k) * dmpik(3) 4255 dmpik(5) = wscale(k) * dmpik(5) 4256 end if 4257c 4258c find the field terms for the current interaction 4259c 4260 rr3 = -dmpe(3) + (1.0d0-dmpik(3))*rr3 4261 rr5 = dmpe(5) - 3.0d0*(1.0d0-dmpik(5))*rr5 4262 fid(1) = rr3*dkx + rr5*dkr*xr 4263 fid(2) = rr3*dky + rr5*dkr*yr 4264 fid(3) = rr3*dkz + rr5*dkr*zr 4265 fkd(1) = rr3*dix + rr5*dir*xr 4266 fkd(2) = rr3*diy + rr5*dir*yr 4267 fkd(3) = rr3*diz + rr5*dir*zr 4268 fip(1) = rr3*pkx + rr5*pkr*xr 4269 fip(2) = rr3*pky + rr5*pkr*yr 4270 fip(3) = rr3*pkz + rr5*pkr*zr 4271 fkp(1) = rr3*pix + rr5*pir*xr 4272 fkp(2) = rr3*piy + rr5*pir*yr 4273 fkp(3) = rr3*piz + rr5*pir*zr 4274c 4275c increment the field at each site due to this interaction 4276c 4277 do j = 1, 3 4278 field(j,ii) = field(j,ii) + fid(j) 4279 fieldp(j,ii) = fieldp(j,ii) + fip(j) 4280 if (ii .ne. kk) then 4281 field(j,kk) = field(j,kk) + fkd(j) 4282 fieldp(j,kk) = fieldp(j,kk) + fkp(j) 4283 end if 4284 end do 4285 end if 4286 end do 4287 end do 4288c 4289c reset exclusion coefficients for connected atoms 4290c 4291 do j = 1, np11(i) 4292 uscale(ip11(j,i)) = 1.0d0 4293 end do 4294 do j = 1, np12(i) 4295 uscale(ip12(j,i)) = 1.0d0 4296 end do 4297 do j = 1, np13(i) 4298 uscale(ip13(j,i)) = 1.0d0 4299 end do 4300 do j = 1, np14(i) 4301 uscale(ip14(j,i)) = 1.0d0 4302 end do 4303 do j = 1, n12(i) 4304 wscale(i12(j,i)) = 1.0d0 4305 end do 4306 do j = 1, n13(i) 4307 wscale(i13(j,i)) = 1.0d0 4308 end do 4309 do j = 1, n14(i) 4310 wscale(i14(j,i)) = 1.0d0 4311 end do 4312 do j = 1, n15(i) 4313 wscale(i15(j,i)) = 1.0d0 4314 end do 4315 end do 4316 end if 4317c 4318c perform deallocation of some local arrays 4319c 4320 deallocate (uscale) 4321 deallocate (wscale) 4322 return 4323 end 4324c 4325c 4326c ################################################################## 4327c ## ## 4328c ## subroutine umutual2b -- Ewald real mutual field via list ## 4329c ## ## 4330c ################################################################## 4331c 4332c 4333c "umutual2b" computes the real space contribution of the induced 4334c atomic dipole moments to the field via a neighbor list 4335c 4336c 4337 subroutine umutual2b (field,fieldp) 4338 use mpole 4339 use polar 4340 use tarray 4341 implicit none 4342 integer i,j,k,m,ii 4343 real*8 fid(3),fkd(3) 4344 real*8 fip(3),fkp(3) 4345 real*8 field(3,*) 4346 real*8 fieldp(3,*) 4347 real*8, allocatable :: fieldt(:,:) 4348 real*8, allocatable :: fieldtp(:,:) 4349c 4350c 4351c check for multipoles and set cutoff coefficients 4352c 4353 if (npole .eq. 0) return 4354c 4355c perform dynamic allocation of some local arrays 4356c 4357 allocate (fieldt(3,npole)) 4358 allocate (fieldtp(3,npole)) 4359c 4360c initialize local variables for OpenMP calculation 4361c 4362 do ii = 1, npole 4363 do j = 1, 3 4364 fieldt(j,ii) = 0.0d0 4365 fieldtp(j,ii) = 0.0d0 4366 end do 4367 end do 4368c 4369c OpenMP directives for the major loop structure 4370c 4371!$OMP PARALLEL default(private) shared(npole,uind,uinp,ntpair, 4372!$OMP& tindex,tdipdip,field,fieldp,fieldt,fieldtp) 4373!$OMP DO reduction(+:fieldt,fieldtp) schedule(guided) 4374c 4375c find the field terms for each pairwise interaction 4376c 4377 do m = 1, ntpair 4378 i = tindex(1,m) 4379 k = tindex(2,m) 4380 fid(1) = tdipdip(1,m)*uind(1,k) + tdipdip(2,m)*uind(2,k) 4381 & + tdipdip(3,m)*uind(3,k) 4382 fid(2) = tdipdip(2,m)*uind(1,k) + tdipdip(4,m)*uind(2,k) 4383 & + tdipdip(5,m)*uind(3,k) 4384 fid(3) = tdipdip(3,m)*uind(1,k) + tdipdip(5,m)*uind(2,k) 4385 & + tdipdip(6,m)*uind(3,k) 4386 fkd(1) = tdipdip(1,m)*uind(1,i) + tdipdip(2,m)*uind(2,i) 4387 & + tdipdip(3,m)*uind(3,i) 4388 fkd(2) = tdipdip(2,m)*uind(1,i) + tdipdip(4,m)*uind(2,i) 4389 & + tdipdip(5,m)*uind(3,i) 4390 fkd(3) = tdipdip(3,m)*uind(1,i) + tdipdip(5,m)*uind(2,i) 4391 & + tdipdip(6,m)*uind(3,i) 4392 fip(1) = tdipdip(1,m)*uinp(1,k) + tdipdip(2,m)*uinp(2,k) 4393 & + tdipdip(3,m)*uinp(3,k) 4394 fip(2) = tdipdip(2,m)*uinp(1,k) + tdipdip(4,m)*uinp(2,k) 4395 & + tdipdip(5,m)*uinp(3,k) 4396 fip(3) = tdipdip(3,m)*uinp(1,k) + tdipdip(5,m)*uinp(2,k) 4397 & + tdipdip(6,m)*uinp(3,k) 4398 fkp(1) = tdipdip(1,m)*uinp(1,i) + tdipdip(2,m)*uinp(2,i) 4399 & + tdipdip(3,m)*uinp(3,i) 4400 fkp(2) = tdipdip(2,m)*uinp(1,i) + tdipdip(4,m)*uinp(2,i) 4401 & + tdipdip(5,m)*uinp(3,i) 4402 fkp(3) = tdipdip(3,m)*uinp(1,i) + tdipdip(5,m)*uinp(2,i) 4403 & + tdipdip(6,m)*uinp(3,i) 4404c 4405c increment the field at each site due to this interaction 4406c 4407 do j = 1, 3 4408 fieldt(j,i) = fieldt(j,i) + fid(j) 4409 fieldt(j,k) = fieldt(j,k) + fkd(j) 4410 fieldtp(j,i) = fieldtp(j,i) + fip(j) 4411 fieldtp(j,k) = fieldtp(j,k) + fkp(j) 4412 end do 4413 end do 4414!$OMP END DO 4415c 4416c add local to global variables for OpenMP calculation 4417c 4418!$OMP DO 4419 do ii = 1, npole 4420 do j = 1, 3 4421 field(j,ii) = field(j,ii) + fieldt(j,ii) 4422 fieldp(j,ii) = fieldp(j,ii) + fieldtp(j,ii) 4423 end do 4424 end do 4425!$OMP END DO 4426!$OMP END PARALLEL 4427c 4428c perform deallocation of some local arrays 4429c 4430 deallocate (fieldt) 4431 deallocate (fieldtp) 4432 return 4433 end 4434c 4435c 4436c ############################################################## 4437c ## ## 4438c ## subroutine induce0c -- Kirkwood SCRF induced dipoles ## 4439c ## ## 4440c ############################################################## 4441c 4442c 4443c "induce0c" computes the induced dipole moments at polarizable 4444c sites for generalized Kirkwood SCRF and vacuum environments 4445c 4446c 4447 subroutine induce0c 4448 use atoms 4449 use inform 4450 use iounit 4451 use mpole 4452 use polar 4453 use polopt 4454 use polpot 4455 use potent 4456 use units 4457 use uprior 4458 implicit none 4459 integer i,j,k,iter 4460 integer miniter 4461 integer maxiter 4462 real*8 polmin 4463 real*8 eps,epsold 4464 real*8 epsd,epsp 4465 real*8 epsds,epsps 4466 real*8 udsum,upsum 4467 real*8 ussum,upssum 4468 real*8 a,ap,as,aps 4469 real*8 b,bp,bs,bps 4470 real*8 sum,sump 4471 real*8 sums,sumps 4472 real*8, allocatable :: poli(:) 4473 real*8, allocatable :: field(:,:) 4474 real*8, allocatable :: fieldp(:,:) 4475 real*8, allocatable :: fields(:,:) 4476 real*8, allocatable :: fieldps(:,:) 4477 real*8, allocatable :: rsd(:,:) 4478 real*8, allocatable :: rsdp(:,:) 4479 real*8, allocatable :: rsds(:,:) 4480 real*8, allocatable :: rsdps(:,:) 4481 real*8, allocatable :: zrsd(:,:) 4482 real*8, allocatable :: zrsdp(:,:) 4483 real*8, allocatable :: zrsds(:,:) 4484 real*8, allocatable :: zrsdps(:,:) 4485 real*8, allocatable :: conj(:,:) 4486 real*8, allocatable :: conjp(:,:) 4487 real*8, allocatable :: conjs(:,:) 4488 real*8, allocatable :: conjps(:,:) 4489 real*8, allocatable :: vec(:,:) 4490 real*8, allocatable :: vecp(:,:) 4491 real*8, allocatable :: vecs(:,:) 4492 real*8, allocatable :: vecps(:,:) 4493 real*8, allocatable :: usum(:,:) 4494 real*8, allocatable :: usump(:,:) 4495 real*8, allocatable :: usums(:,:) 4496 real*8, allocatable :: usumps(:,:) 4497 logical done 4498 character*6 mode 4499c 4500c 4501c zero out the induced dipoles at each site; uind and uinp are 4502c vacuum dipoles, uinds and uinps are SCRF dipoles 4503c 4504 do i = 1, npole 4505 do j = 1, 3 4506 uind(j,i) = 0.0d0 4507 uinp(j,i) = 0.0d0 4508 uinds(j,i) = 0.0d0 4509 uinps(j,i) = 0.0d0 4510 end do 4511 end do 4512 if (.not.use_polar .and. .not.use_solv) return 4513c 4514c set the switching function coefficients 4515c 4516 mode = 'MPOLE' 4517 call switch (mode) 4518c 4519c perform dynamic allocation of some local arrays 4520c 4521 allocate (field(3,npole)) 4522 allocate (fieldp(3,npole)) 4523 allocate (fields(3,npole)) 4524 allocate (fieldps(3,npole)) 4525c 4526c compute the direct induced dipole moment at each atom, and 4527c another set that also includes RF due to permanent multipoles 4528c 4529 call dfield0d (field,fieldp,fields,fieldps) 4530c 4531c set vacuum induced dipoles to polarizability times direct field; 4532c set SCRF induced dipoles to polarizability times direct field 4533c plus the GK reaction field due to permanent multipoles 4534c 4535 do i = 1, npole 4536 if (douind(ipole(i))) then 4537 do j = 1, 3 4538 udir(j,i) = polarity(i) * field(j,i) 4539 udirp(j,i) = polarity(i) * fieldp(j,i) 4540 udirs(j,i) = polarity(i) * fields(j,i) 4541 udirps(j,i) = polarity(i) * fieldps(j,i) 4542 uind(j,i) = udir(j,i) 4543 uinp(j,i) = udirp(j,i) 4544 uinds(j,i) = udirs(j,i) 4545 uinps(j,i) = udirps(j,i) 4546 end do 4547 end if 4548 end do 4549c 4550c get induced dipoles via the OPT extrapolation method 4551c 4552 if (poltyp .eq. 'OPT') then 4553 do i = 1, npole 4554 if (douind(ipole(i))) then 4555 do j = 1, 3 4556 uopt(0,j,i) = udir(j,i) 4557 uoptp(0,j,i) = udirp(j,i) 4558 uopts(0,j,i) = udirs(j,i) 4559 uoptps(0,j,i) = udirps(j,i) 4560 end do 4561 end if 4562 end do 4563 do k = 1, optorder 4564 call ufield0d (field,fieldp,fields,fieldps) 4565 do i = 1, npole 4566 if (douind(ipole(i))) then 4567 do j = 1, 3 4568 uopt(k,j,i) = polarity(i) * field(j,i) 4569 uoptp(k,j,i) = polarity(i) * fieldp(j,i) 4570 uopts(k,j,i) = polarity(i) * fields(j,i) 4571 uoptps(k,j,i) = polarity(i) * fieldps(j,i) 4572 uind(j,i) = uopt(k,j,i) 4573 uinp(j,i) = uoptp(k,j,i) 4574 uinds(j,i) = uopts(k,j,i) 4575 uinps(j,i) = uoptps(k,j,i) 4576 end do 4577 end if 4578 end do 4579 end do 4580 allocate (usum(3,n)) 4581 allocate (usump(3,n)) 4582 allocate (usums(3,n)) 4583 allocate (usumps(3,n)) 4584 do i = 1, npole 4585 if (douind(ipole(i))) then 4586 do j = 1, 3 4587 uind(j,i) = 0.0d0 4588 uinp(j,i) = 0.0d0 4589 uinds(j,i) = 0.0d0 4590 uinps(j,i) = 0.0d0 4591 usum(j,i) = 0.0d0 4592 usump(j,i) = 0.0d0 4593 usums(j,i) = 0.0d0 4594 usumps(j,i) = 0.0d0 4595 do k = 0, optorder 4596 usum(j,i) = usum(j,i) + uopt(k,j,i) 4597 usump(j,i) = usump(j,i) + uoptp(k,j,i) 4598 usums(j,i) = usums(j,i) + uopts(k,j,i) 4599 usumps(j,i) = usumps(j,i) + uoptps(k,j,i) 4600 uind(j,i) = uind(j,i) + copt(k)*usum(j,i) 4601 uinp(j,i) = uinp(j,i) + copt(k)*usump(j,i) 4602 uinds(j,i) = uinds(j,i) + copt(k)*usums(j,i) 4603 uinps(j,i) = uinps(j,i) + copt(k)*usumps(j,i) 4604 end do 4605 end do 4606 end if 4607 end do 4608 deallocate (usum) 4609 deallocate (usump) 4610 deallocate (usums) 4611 deallocate (usumps) 4612 end if 4613c 4614c set tolerances for computation of mutual induced dipoles 4615c 4616 if (poltyp .eq. 'MUTUAL') then 4617 done = .false. 4618 miniter = min(3,npole) 4619 maxiter = 100 4620 iter = 0 4621 polmin = 0.00000001d0 4622 eps = 100.0d0 4623c 4624c estimated induced dipoles from polynomial predictor 4625c 4626 if (use_pred .and. nualt.eq.maxualt) then 4627 do i = 1, npole 4628 do j = 1, 3 4629 udsum = 0.0d0 4630 upsum = 0.0d0 4631 ussum = 0.0d0 4632 upssum = 0.0d0 4633 do k = 1, nualt-1 4634 udsum = udsum + bpred(k)*udalt(k,j,i) 4635 upsum = upsum + bpredp(k)*upalt(k,j,i) 4636 ussum = ussum + bpreds(k)*usalt(k,j,i) 4637 upssum = upssum + bpredps(k)*upsalt(k,j,i) 4638 end do 4639 uind(j,i) = udsum 4640 uinp(j,i) = upsum 4641 uinds(j,i) = ussum 4642 uinps(j,i) = upssum 4643 end do 4644 end do 4645 end if 4646c 4647c perform dynamic allocation of some local arrays 4648c 4649 allocate (poli(npole)) 4650 allocate (rsd(3,npole)) 4651 allocate (rsdp(3,npole)) 4652 allocate (rsds(3,npole)) 4653 allocate (rsdps(3,npole)) 4654 allocate (zrsd(3,npole)) 4655 allocate (zrsdp(3,npole)) 4656 allocate (zrsds(3,npole)) 4657 allocate (zrsdps(3,npole)) 4658 allocate (conj(3,npole)) 4659 allocate (conjp(3,npole)) 4660 allocate (conjs(3,npole)) 4661 allocate (conjps(3,npole)) 4662 allocate (vec(3,npole)) 4663 allocate (vecp(3,npole)) 4664 allocate (vecs(3,npole)) 4665 allocate (vecps(3,npole)) 4666c 4667c set initial conjugate gradient residual and conjugate vector 4668c 4669 call ufield0d (field,fieldp,fields,fieldps) 4670 do i = 1, npole 4671 if (douind(ipole(i))) then 4672 poli(i) = max(polmin,polarity(i)) 4673 do j = 1, 3 4674 rsd(j,i) = (udir(j,i)-uind(j,i))/poli(i) 4675 & + field(j,i) 4676 rsdp(j,i) = (udirp(j,i)-uinp(j,i))/poli(i) 4677 & + fieldp(j,i) 4678 rsds(j,i) = (udirs(j,i)-uinds(j,i))/poli(i) 4679 & + fields(j,i) 4680 rsdps(j,i) = (udirps(j,i)-uinps(j,i))/poli(i) 4681 & + fieldps(j,i) 4682 zrsd(j,i) = rsd(j,i) * poli(i) 4683 zrsdp(j,i) = rsdp(j,i) * poli(i) 4684 zrsds(j,i) = rsds(j,i) * poli(i) 4685 zrsdps(j,i) = rsdps(j,i) * poli(i) 4686 conj(j,i) = zrsd(j,i) 4687 conjp(j,i) = zrsdp(j,i) 4688 conjs(j,i) = zrsds(j,i) 4689 conjps(j,i) = zrsdps(j,i) 4690 end do 4691 end if 4692 end do 4693c 4694c conjugate gradient iteration of the mutual induced dipoles 4695c 4696 do while (.not. done) 4697 iter = iter + 1 4698 do i = 1, npole 4699 if (douind(ipole(i))) then 4700 do j = 1, 3 4701 vec(j,i) = uind(j,i) 4702 vecp(j,i) = uinp(j,i) 4703 vecs(j,i) = uinds(j,i) 4704 vecps(j,i) = uinps(j,i) 4705 uind(j,i) = conj(j,i) 4706 uinp(j,i) = conjp(j,i) 4707 uinds(j,i) = conjs(j,i) 4708 uinps(j,i) = conjps(j,i) 4709 end do 4710 end if 4711 end do 4712 call ufield0d (field,fieldp,fields,fieldps) 4713 do i = 1, npole 4714 if (douind(ipole(i))) then 4715 do j = 1, 3 4716 uind(j,i) = vec(j,i) 4717 uinp(j,i) = vecp(j,i) 4718 uinds(j,i) = vecs(j,i) 4719 uinps(j,i) = vecps(j,i) 4720 vec(j,i) = conj(j,i)/poli(i) - field(j,i) 4721 vecp(j,i) = conjp(j,i)/poli(i) - fieldp(j,i) 4722 vecs(j,i) = conjs(j,i)/poli(i) - fields(j,i) 4723 vecps(j,i) = conjps(j,i)/poli(i) - fieldps(j,i) 4724 end do 4725 end if 4726 end do 4727 a = 0.0d0 4728 ap = 0.0d0 4729 as = 0.0d0 4730 aps = 0.0d0 4731 sum = 0.0d0 4732 sump = 0.0d0 4733 sums = 0.0d0 4734 sumps = 0.0d0 4735 do i = 1, npole 4736 if (douind(ipole(i))) then 4737 do j = 1, 3 4738 a = a + conj(j,i)*vec(j,i) 4739 ap = ap + conjp(j,i)*vecp(j,i) 4740 as = as + conjs(j,i)*vecs(j,i) 4741 aps = aps + conjps(j,i)*vecps(j,i) 4742 sum = sum + rsd(j,i)*zrsd(j,i) 4743 sump = sump + rsdp(j,i)*zrsdp(j,i) 4744 sums = sums + rsds(j,i)*zrsds(j,i) 4745 sumps = sumps + rsdps(j,i)*zrsdps(j,i) 4746 end do 4747 end if 4748 end do 4749 if (a .ne. 0.0d0) a = sum / a 4750 if (ap .ne. 0.0d0) ap = sump / ap 4751 if (as .ne. 0.0d0) as = sums / as 4752 if (aps .ne. 0.0d0) aps = sumps / aps 4753 do i = 1, npole 4754 if (douind(ipole(i))) then 4755 do j = 1, 3 4756 uind(j,i) = uind(j,i) + a*conj(j,i) 4757 uinp(j,i) = uinp(j,i) + ap*conjp(j,i) 4758 uinds(j,i) = uinds(j,i) + as*conjs(j,i) 4759 uinps(j,i) = uinps(j,i) + aps*conjps(j,i) 4760 rsd(j,i) = rsd(j,i) - a*vec(j,i) 4761 rsdp(j,i) = rsdp(j,i) - ap*vecp(j,i) 4762 rsds(j,i) = rsds(j,i) - as*vecs(j,i) 4763 rsdps(j,i) = rsdps(j,i) - aps*vecps(j,i) 4764 end do 4765 end if 4766 end do 4767 b = 0.0d0 4768 bp = 0.0d0 4769 bs = 0.0d0 4770 bps = 0.0d0 4771 do i = 1, npole 4772 if (douind(ipole(i))) then 4773 do j = 1, 3 4774 zrsd(j,i) = rsd(j,i) * poli(i) 4775 zrsdp(j,i) = rsdp(j,i) * poli(i) 4776 zrsds(j,i) = rsds(j,i) * poli(i) 4777 zrsdps(j,i) = rsdps(j,i) * poli(i) 4778 b = b + rsd(j,i)*zrsd(j,i) 4779 bp = bp + rsdp(j,i)*zrsdp(j,i) 4780 bs = bs + rsds(j,i)*zrsds(j,i) 4781 bps = bps + rsdps(j,i)*zrsdps(j,i) 4782 end do 4783 end if 4784 end do 4785 if (sum .ne. 0.0d0) b = b / sum 4786 if (sump .ne. 0.0d0) bp = bp / sump 4787 if (sums .ne. 0.0d0) bs = bs / sums 4788 if (sumps .ne. 0.0d0) bps = bps / sumps 4789 epsd = 0.0d0 4790 epsp = 0.0d0 4791 epsds = 0.0d0 4792 epsps = 0.0d0 4793 do i = 1, npole 4794 if (douind(ipole(i))) then 4795 do j = 1, 3 4796 conj(j,i) = zrsd(j,i) + b*conj(j,i) 4797 conjp(j,i) = zrsdp(j,i) + bp*conjp(j,i) 4798 conjs(j,i) = zrsds(j,i) + bs*conjs(j,i) 4799 conjps(j,i) = zrsdps(j,i) + bps*conjps(j,i) 4800 epsd = epsd + rsd(j,i)*rsd(j,i) 4801 epsp = epsp + rsdp(j,i)*rsdp(j,i) 4802 epsds = epsds + rsds(j,i)*rsds(j,i) 4803 epsps = epsps + rsdps(j,i)*rsdps(j,i) 4804 end do 4805 end if 4806 end do 4807c 4808c check the convergence of the mutual induced dipoles 4809c 4810 epsold = eps 4811 eps = max(epsd,epsp,epsds,epsps) 4812 eps = debye * sqrt(eps/dble(npolar)) 4813 if (debug) then 4814 if (iter .eq. 1) then 4815 write (iout,10) 4816 10 format (/,' Determination of Induced Dipole', 4817 & ' Moments :', 4818 & //,4x,'Iter',8x,'RMS Change (Debye)',/) 4819 end if 4820 write (iout,20) iter,eps 4821 20 format (i8,7x,f16.10) 4822 end if 4823 if (eps .lt. poleps) done = .true. 4824 if (eps .gt. epsold) done = .true. 4825 if (iter .lt. miniter) done = .false. 4826 if (iter .ge. politer) done = .true. 4827c 4828c apply a "peek" iteration to the mutual induced dipoles 4829c 4830 if (done) then 4831 do i = 1, npole 4832 if (douind(ipole(i))) then 4833 do j = 1, 3 4834 uind(j,i) = uind(j,i) + poli(i)*rsd(j,i) 4835 uinp(j,i) = uinp(j,i) + poli(i)*rsdp(j,i) 4836 uinds(j,i) = uinds(j,i) + poli(i)*rsds(j,i) 4837 uinps(j,i) = uinps(j,i) + poli(i)*rsdps(j,i) 4838 end do 4839 end if 4840 end do 4841 end if 4842 end do 4843c 4844c perform deallocation of some local arrays 4845c 4846 deallocate (poli) 4847 deallocate (rsd) 4848 deallocate (rsdp) 4849 deallocate (rsds) 4850 deallocate (rsdps) 4851 deallocate (zrsd) 4852 deallocate (zrsdp) 4853 deallocate (zrsds) 4854 deallocate (zrsdps) 4855 deallocate (conj) 4856 deallocate (conjp) 4857 deallocate (conjs) 4858 deallocate (conjps) 4859 deallocate (vec) 4860 deallocate (vecp) 4861 deallocate (vecs) 4862 deallocate (vecps) 4863c 4864c print the results from the conjugate gradient iteration 4865c 4866 if (debug) then 4867 write (iout,30) iter,eps 4868 30 format (/,' Induced Dipoles :',6x,'Iterations',i5, 4869 & 6x,'RMS Change',f15.10) 4870 end if 4871c 4872c terminate the calculation if dipoles failed to converge 4873c 4874 if (iter.ge.maxiter .or. eps.gt.epsold) then 4875 write (iout,40) 4876 40 format (/,' INDUCE -- Warning, Induced Dipoles', 4877 & ' are not Converged') 4878 call prterr 4879 call fatal 4880 end if 4881 end if 4882c 4883c perform deallocation of some local arrays 4884c 4885 deallocate (field) 4886 deallocate (fieldp) 4887 deallocate (fields) 4888 deallocate (fieldps) 4889 return 4890 end 4891c 4892c 4893c ################################################################## 4894c ## ## 4895c ## subroutine dfield0d -- generalized Kirkwood direct field ## 4896c ## ## 4897c ################################################################## 4898c 4899c 4900c "dfield0d" computes the direct electrostatic field due to 4901c permanent multipole moments for use with with generalized 4902c Kirkwood implicit solvation 4903c 4904c 4905 subroutine dfield0d (field,fieldp,fields,fieldps) 4906 use atoms 4907 use couple 4908 use gkstuf 4909 use group 4910 use mpole 4911 use polar 4912 use polgrp 4913 use polpot 4914 use shunt 4915 use solute 4916 implicit none 4917 integer i,j,k 4918 integer ii,kk 4919 real*8 xr,yr,zr 4920 real*8 xr2,yr2,zr2 4921 real*8 fgrp,r,r2 4922 real*8 rr3,rr5,rr7 4923 real*8 ci,uxi,uyi,uzi 4924 real*8 qxxi,qxyi,qxzi 4925 real*8 qyyi,qyzi,qzzi 4926 real*8 ck,uxk,uyk,uzk 4927 real*8 qxxk,qxyk,qxzk 4928 real*8 qyyk,qyzk,qzzk 4929 real*8 dir,dkr 4930 real*8 qix,qiy,qiz,qir 4931 real*8 qkx,qky,qkz,qkr 4932 real*8 rb2,rbi,rbk 4933 real*8 dwater,fc,fd,fq 4934 real*8 gf,gf2,gf3,gf5,gf7 4935 real*8 expterm,expc,expc1 4936 real*8 dexpc,expcdexpc 4937 real*8 a(0:3,0:2) 4938 real*8 gc(4),gux(10) 4939 real*8 guy(10),guz(10) 4940 real*8 gqxx(4),gqxy(4) 4941 real*8 gqxz(4),gqyy(4) 4942 real*8 gqyz(4),gqzz(4) 4943 real*8 fid(3),fkd(3) 4944 real*8 dmpik(7) 4945 real*8, allocatable :: dscale(:) 4946 real*8, allocatable :: pscale(:) 4947 real*8 field(3,*) 4948 real*8 fieldp(3,*) 4949 real*8 fields(3,*) 4950 real*8 fieldps(3,*) 4951 real*8, allocatable :: fieldt(:,:) 4952 real*8, allocatable :: fieldtp(:,:) 4953 real*8, allocatable :: fieldts(:,:) 4954 real*8, allocatable :: fieldtps(:,:) 4955 logical proceed 4956c 4957c 4958c zero out the value of the field at each site 4959c 4960 do ii = 1, npole 4961 do j = 1, 3 4962 field(j,ii) = 0.0d0 4963 fieldp(j,ii) = 0.0d0 4964 fields(j,ii) = 0.0d0 4965 fieldps(j,ii) = 0.0d0 4966 end do 4967 end do 4968c 4969c set dielectric constant and scaling factors for water 4970c 4971 dwater = 78.3d0 4972 fc = 1.0d0 * (1.0d0-dwater) / (1.0d0*dwater) 4973 fd = 2.0d0 * (1.0d0-dwater) / (1.0d0+2.0d0*dwater) 4974 fq = 3.0d0 * (1.0d0-dwater) / (2.0d0+3.0d0*dwater) 4975c 4976c perform dynamic allocation of some local arrays 4977c 4978 allocate (dscale(n)) 4979 allocate (pscale(n)) 4980c 4981c set arrays needed to scale connected atom interactions 4982c 4983 do i = 1, n 4984 dscale(i) = 1.0d0 4985 pscale(i) = 1.0d0 4986 end do 4987c 4988c perform dynamic allocation of some local arrays 4989c 4990 allocate (fieldt(3,npole)) 4991 allocate (fieldtp(3,npole)) 4992 allocate (fieldts(3,npole)) 4993 allocate (fieldtps(3,npole)) 4994c 4995c initialize local variables for OpenMP calculation 4996c 4997 do ii = 1, npole 4998 do j = 1, 3 4999 fieldt(j,ii) = 0.0d0 5000 fieldtp(j,ii) = 0.0d0 5001 fieldts(j,ii) = 0.0d0 5002 fieldtps(j,ii) = 0.0d0 5003 end do 5004 end do 5005c 5006c OpenMP directives for the major loop structure 5007c 5008!$OMP PARALLEL default(private) shared(npole,ipole,rpole,rborn,n12,n13, 5009!$OMP& n14,n15,np11,np12,np13,np14,i12,i13,i14,i15,ip11,ip12,ip13,ip14, 5010!$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale, 5011!$OMP& p5iscale,d1scale,d2scale,d3scale,d4scale,dpequal,use_intra, 5012!$OMP& x,y,z,off2,fc,fd,fq,gkc,field,fieldp,fields,fieldps) 5013!$OMP& firstprivate(dscale,pscale) 5014!$OMP& shared(fieldt,fieldtp,fieldts,fieldtps) 5015!$OMP DO reduction(+:fieldt,fieldtp,fieldts,fieldtps) schedule(guided) 5016c 5017c find the field terms for each pairwise interaction 5018c 5019 do ii = 1, npole 5020 i = ipole(ii) 5021 ci = rpole(1,ii) 5022 uxi = rpole(2,ii) 5023 uyi = rpole(3,ii) 5024 uzi = rpole(4,ii) 5025 qxxi = rpole(5,ii) 5026 qxyi = rpole(6,ii) 5027 qxzi = rpole(7,ii) 5028 qyyi = rpole(9,ii) 5029 qyzi = rpole(10,ii) 5030 qzzi = rpole(13,ii) 5031 rbi = rborn(i) 5032c 5033c set exclusion coefficients for connected atoms 5034c 5035 if (dpequal) then 5036 do j = 1, n12(i) 5037 pscale(i12(j,i)) = p2scale 5038 do k = 1, np11(i) 5039 if (i12(j,i) .eq. ip11(k,i)) 5040 & pscale(i12(j,i)) = p2iscale 5041 end do 5042 dscale(i12(j,i)) = pscale(i12(j,i)) 5043 end do 5044 do j = 1, n13(i) 5045 pscale(i13(j,i)) = p3scale 5046 do k = 1, np11(i) 5047 if (i13(j,i) .eq. ip11(k,i)) 5048 & pscale(i13(j,i)) = p3iscale 5049 end do 5050 dscale(i13(j,i)) = pscale(i13(j,i)) 5051 end do 5052 do j = 1, n14(i) 5053 pscale(i14(j,i)) = p4scale 5054 do k = 1, np11(i) 5055 if (i14(j,i) .eq. ip11(k,i)) 5056 & pscale(i14(j,i)) = p4iscale 5057 end do 5058 dscale(i14(j,i)) = pscale(i14(j,i)) 5059 end do 5060 do j = 1, n15(i) 5061 pscale(i15(j,i)) = p5scale 5062 do k = 1, np11(i) 5063 if (i15(j,i) .eq. ip11(k,i)) 5064 & pscale(i15(j,i)) = p5iscale 5065 end do 5066 dscale(i15(j,i)) = pscale(i15(j,i)) 5067 end do 5068 else 5069 do j = 1, n12(i) 5070 pscale(i12(j,i)) = p2scale 5071 do k = 1, np11(i) 5072 if (i12(j,i) .eq. ip11(k,i)) 5073 & pscale(i12(j,i)) = p2iscale 5074 end do 5075 end do 5076 do j = 1, n13(i) 5077 pscale(i13(j,i)) = p3scale 5078 do k = 1, np11(i) 5079 if (i13(j,i) .eq. ip11(k,i)) 5080 & pscale(i13(j,i)) = p3iscale 5081 end do 5082 end do 5083 do j = 1, n14(i) 5084 pscale(i14(j,i)) = p4scale 5085 do k = 1, np11(i) 5086 if (i14(j,i) .eq. ip11(k,i)) 5087 & pscale(i14(j,i)) = p4iscale 5088 end do 5089 end do 5090 do j = 1, n15(i) 5091 pscale(i15(j,i)) = p5scale 5092 do k = 1, np11(i) 5093 if (i15(j,i) .eq. ip11(k,i)) 5094 & pscale(i15(j,i)) = p5iscale 5095 end do 5096 end do 5097 do j = 1, np11(i) 5098 dscale(ip11(j,i)) = d1scale 5099 end do 5100 do j = 1, np12(i) 5101 dscale(ip12(j,i)) = d2scale 5102 end do 5103 do j = 1, np13(i) 5104 dscale(ip13(j,i)) = d3scale 5105 end do 5106 do j = 1, np14(i) 5107 dscale(ip14(j,i)) = d4scale 5108 end do 5109 end if 5110c 5111c evaluate all sites within the cutoff distance 5112c 5113 do kk = ii, npole 5114 k = ipole(kk) 5115 proceed = .true. 5116 if (use_intra) call groups (proceed,fgrp,i,k,0,0,0,0) 5117 if (proceed) then 5118 xr = x(k) - x(i) 5119 yr = y(k) - y(i) 5120 zr = z(k) - z(i) 5121 xr2 = xr * xr 5122 yr2 = yr * yr 5123 zr2 = zr * zr 5124 r2 = xr2 + yr2 + zr2 5125 if (r2 .le. off2) then 5126 r = sqrt(r2) 5127 ck = rpole(1,kk) 5128 uxk = rpole(2,kk) 5129 uyk = rpole(3,kk) 5130 uzk = rpole(4,kk) 5131 qxxk = rpole(5,kk) 5132 qxyk = rpole(6,kk) 5133 qxzk = rpole(7,kk) 5134 qyyk = rpole(9,kk) 5135 qyzk = rpole(10,kk) 5136 qzzk = rpole(13,kk) 5137 rbk = rborn(k) 5138c 5139c self-interactions for the solute field are skipped 5140c 5141 if (i .ne. k) then 5142 call dampthole (ii,kk,7,r,dmpik) 5143 rr3 = dmpik(3) / (r*r2) 5144 rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) 5145 rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2) 5146 dir = uxi*xr + uyi*yr + uzi*zr 5147 qix = qxxi*xr + qxyi*yr + qxzi*zr 5148 qiy = qxyi*xr + qyyi*yr + qyzi*zr 5149 qiz = qxzi*xr + qyzi*yr + qzzi*zr 5150 qir = qix*xr + qiy*yr + qiz*zr 5151 dkr = uxk*xr + uyk*yr + uzk*zr 5152 qkx = qxxk*xr + qxyk*yr + qxzk*zr 5153 qky = qxyk*xr + qyyk*yr + qyzk*zr 5154 qkz = qxzk*xr + qyzk*yr + qzzk*zr 5155 qkr = qkx*xr + qky*yr + qkz*zr 5156 fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) 5157 & - rr3*uxk + 2.0d0*rr5*qkx 5158 fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) 5159 & - rr3*uyk + 2.0d0*rr5*qky 5160 fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) 5161 & - rr3*uzk + 2.0d0*rr5*qkz 5162 fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) 5163 & - rr3*uxi - 2.0d0*rr5*qix 5164 fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) 5165 & - rr3*uyi - 2.0d0*rr5*qiy 5166 fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) 5167 & - rr3*uzi - 2.0d0*rr5*qiz 5168 do j = 1, 3 5169 fieldt(j,ii) = fieldt(j,ii) + fid(j)*dscale(k) 5170 fieldt(j,kk) = fieldt(j,kk) + fkd(j)*dscale(k) 5171 fieldtp(j,ii) = fieldtp(j,ii) + fid(j)*pscale(k) 5172 fieldtp(j,kk) = fieldtp(j,kk) + fkd(j)*pscale(k) 5173 end do 5174 end if 5175c 5176c set the reaction potential auxiliary terms 5177c 5178 rb2 = rbi * rbk 5179 expterm = exp(-r2/(gkc*rb2)) 5180 expc = expterm / gkc 5181 dexpc = -2.0d0 / (gkc*rb2) 5182 gf2 = 1.0d0 / (r2+rb2*expterm) 5183 gf = sqrt(gf2) 5184 gf3 = gf2 * gf 5185 gf5 = gf3 * gf2 5186 gf7 = gf5 * gf2 5187 a(0,0) = gf 5188 a(1,0) = -gf3 5189 a(2,0) = 3.0d0 * gf5 5190 a(3,0) = -15.0d0 * gf7 5191c 5192c set the reaction potential gradient auxiliary terms 5193c 5194 expc1 = 1.0d0 - expc 5195 a(0,1) = expc1 * a(1,0) 5196 a(1,1) = expc1 * a(2,0) 5197 a(2,1) = expc1 * a(3,0) 5198c 5199c dipole second reaction potential gradient auxiliary term 5200c 5201 expcdexpc = -expc * dexpc 5202 a(1,2) = expc1*a(2,1) + expcdexpc*a(2,0) 5203c 5204c multiply the auxiliary terms by dielectric functions 5205c 5206 a(0,1) = fc * a(0,1) 5207 a(1,0) = fd * a(1,0) 5208 a(1,1) = fd * a(1,1) 5209 a(1,2) = fd * a(1,2) 5210 a(2,0) = fq * a(2,0) 5211 a(2,1) = fq * a(2,1) 5212c 5213c unweighted dipole reaction potential tensor 5214c 5215 gux(1) = xr * a(1,0) 5216 guy(1) = yr * a(1,0) 5217 guz(1) = zr * a(1,0) 5218c 5219c unweighted reaction potential gradient tensor 5220c 5221 gc(2) = xr * a(0,1) 5222 gc(3) = yr * a(0,1) 5223 gc(4) = zr * a(0,1) 5224 gux(2) = a(1,0) + xr2*a(1,1) 5225 gux(3) = xr * yr * a(1,1) 5226 gux(4) = xr * zr * a(1,1) 5227 guy(2) = gux(3) 5228 guy(3) = a(1,0) + yr2*a(1,1) 5229 guy(4) = yr * zr * a(1,1) 5230 guz(2) = gux(4) 5231 guz(3) = guy(4) 5232 guz(4) = a(1,0) + zr2*a(1,1) 5233 gqxx(2) = xr * (2.0d0*a(2,0)+xr2*a(2,1)) 5234 gqxx(3) = yr * xr2*a(2,1) 5235 gqxx(4) = zr * xr2*a(2,1) 5236 gqyy(2) = xr * yr2*a(2,1) 5237 gqyy(3) = yr * (2.0d0*a(2,0)+yr2*a(2,1)) 5238 gqyy(4) = zr * yr2 * a(2,1) 5239 gqzz(2) = xr * zr2 * a(2,1) 5240 gqzz(3) = yr * zr2 * a(2,1) 5241 gqzz(4) = zr * (2.0d0*a(2,0)+zr2*a(2,1)) 5242 gqxy(2) = yr * (a(2,0)+xr2*a(2,1)) 5243 gqxy(3) = xr * (a(2,0)+yr2*a(2,1)) 5244 gqxy(4) = zr * xr * yr * a(2,1) 5245 gqxz(2) = zr * (a(2,0)+xr2*a(2,1)) 5246 gqxz(3) = gqxy(4) 5247 gqxz(4) = xr * (a(2,0)+zr2*a(2,1)) 5248 gqyz(2) = gqxy(4) 5249 gqyz(3) = zr * (a(2,0)+yr2*a(2,1)) 5250 gqyz(4) = yr * (a(2,0)+zr2*a(2,1)) 5251c 5252c unweighted dipole second reaction potential gradient tensor 5253c 5254 gux(5) = xr * (3.0d0*a(1,1)+xr2*a(1,2)) 5255 gux(6) = yr * (a(1,1)+xr2*a(1,2)) 5256 gux(7) = zr * (a(1,1)+xr2*a(1,2)) 5257 gux(8) = xr * (a(1,1)+yr2*a(1,2)) 5258 gux(9) = zr * xr * yr * a(1,2) 5259 gux(10) = xr * (a(1,1)+zr2*a(1,2)) 5260 guy(5) = yr * (a(1,1)+xr2*a(1,2)) 5261 guy(6) = xr * (a(1,1)+yr2*a(1,2)) 5262 guy(7) = gux(9) 5263 guy(8) = yr * (3.0d0*a(1,1)+yr2*a(1,2)) 5264 guy(9) = zr * (a(1,1)+yr2*a(1,2)) 5265 guy(10) = yr * (a(1,1)+zr2*a(1,2)) 5266 guz(5) = zr * (a(1,1)+xr2*a(1,2)) 5267 guz(6) = gux(9) 5268 guz(7) = xr * (a(1,1)+zr2*a(1,2)) 5269 guz(8) = zr * (a(1,1)+yr2*a(1,2)) 5270 guz(9) = yr * (a(1,1)+zr2*a(1,2)) 5271 guz(10) = zr * (3.0d0*a(1,1)+zr2*a(1,2)) 5272c 5273c generalized Kirkwood permanent reaction field 5274c 5275 fid(1) = uxk*gux(2) + uyk*gux(3) + uzk*gux(4) 5276 & + 0.5d0 * (ck*gux(1) + qxxk*gux(5) 5277 & + qyyk*gux(8) + qzzk*gux(10) 5278 & + 2.0d0*(qxyk*gux(6)+qxzk*gux(7) 5279 & +qyzk*gux(9))) 5280 & + 0.5d0 * (ck*gc(2) + qxxk*gqxx(2) 5281 & + qyyk*gqyy(2) + qzzk*gqzz(2) 5282 & + 2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2) 5283 & +qyzk*gqyz(2))) 5284 fid(2) = uxk*guy(2) + uyk*guy(3) + uzk*guy(4) 5285 & + 0.5d0 * (ck*guy(1) + qxxk*guy(5) 5286 & + qyyk*guy(8) + qzzk*guy(10) 5287 & + 2.0d0*(qxyk*guy(6)+qxzk*guy(7) 5288 & +qyzk*guy(9))) 5289 & + 0.5d0 * (ck*gc(3) + qxxk*gqxx(3) 5290 & + qyyk*gqyy(3) + qzzk*gqzz(3) 5291 & + 2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3) 5292 & +qyzk*gqyz(3))) 5293 fid(3) = uxk*guz(2) + uyk*guz(3) + uzk*guz(4) 5294 & + 0.5d0 * (ck*guz(1) + qxxk*guz(5) 5295 & + qyyk*guz(8) + qzzk*guz(10) 5296 & + 2.0d0*(qxyk*guz(6)+qxzk*guz(7) 5297 & +qyzk*guz(9))) 5298 & + 0.5d0 * (ck*gc(4) + qxxk*gqxx(4) 5299 & + qyyk*gqyy(4) + qzzk*gqzz(4) 5300 & + 2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4) 5301 & +qyzk*gqyz(4))) 5302 fkd(1) = uxi*gux(2) + uyi*gux(3) + uzi*gux(4) 5303 & - 0.5d0 * (ci*gux(1) + qxxi*gux(5) 5304 & + qyyi*gux(8) + qzzi*gux(10) 5305 & + 2.0d0*(qxyi*gux(6)+qxzi*gux(7) 5306 & +qyzi*gux(9))) 5307 & - 0.5d0 * (ci*gc(2) + qxxi*gqxx(2) 5308 & + qyyi*gqyy(2) + qzzi*gqzz(2) 5309 & + 2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2) 5310 & +qyzi*gqyz(2))) 5311 fkd(2) = uxi*guy(2) + uyi*guy(3) + uzi*guy(4) 5312 & - 0.5d0 * (ci*guy(1) + qxxi*guy(5) 5313 & + qyyi*guy(8) + qzzi*guy(10) 5314 & + 2.0d0*(qxyi*guy(6)+qxzi*guy(7) 5315 & +qyzi*guy(9))) 5316 & - 0.5d0 * (ci*gc(3) + qxxi*gqxx(3) 5317 & + qyyi*gqyy(3) + qzzi*gqzz(3) 5318 & + 2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3) 5319 & +qyzi*gqyz(3))) 5320 fkd(3) = uxi*guz(2) + uyi*guz(3) + uzi*guz(4) 5321 & - 0.5d0 * (ci*guz(1) + qxxi*guz(5) 5322 & + qyyi*guz(8) + qzzi*guz(10) 5323 & + 2.0d0*(qxyi*guz(6)+qxzi*guz(7) 5324 & +qyzi*guz(9))) 5325 & - 0.5d0 * (ci*gc(4) + qxxi*gqxx(4) 5326 & + qyyi*gqyy(4) + qzzi*gqzz(4) 5327 & + 2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4) 5328 & +qyzi*gqyz(4))) 5329c 5330c scale the self-field by half, such that it sums to one below 5331c 5332 if (i .eq. k) then 5333 do j = 1, 3 5334 fid(j) = 0.5d0 * fid(j) 5335 fkd(j) = 0.5d0 * fkd(j) 5336 end do 5337 end if 5338 do j = 1, 3 5339 fieldts(j,ii) = fieldts(j,ii) + fid(j) 5340 fieldts(j,kk) = fieldts(j,kk) + fkd(j) 5341 fieldtps(j,ii) = fieldtps(j,ii) + fid(j) 5342 fieldtps(j,kk) = fieldtps(j,kk) + fkd(j) 5343 end do 5344 end if 5345 end if 5346 end do 5347c 5348c reset exclusion coefficients for connected atoms 5349c 5350 if (dpequal) then 5351 do j = 1, n12(i) 5352 pscale(i12(j,i)) = 1.0d0 5353 dscale(i12(j,i)) = 1.0d0 5354 end do 5355 do j = 1, n13(i) 5356 pscale(i13(j,i)) = 1.0d0 5357 dscale(i13(j,i)) = 1.0d0 5358 end do 5359 do j = 1, n14(i) 5360 pscale(i14(j,i)) = 1.0d0 5361 dscale(i14(j,i)) = 1.0d0 5362 end do 5363 do j = 1, n15(i) 5364 pscale(i15(j,i)) = 1.0d0 5365 dscale(i15(j,i)) = 1.0d0 5366 end do 5367 else 5368 do j = 1, n12(i) 5369 pscale(i12(j,i)) = 1.0d0 5370 end do 5371 do j = 1, n13(i) 5372 pscale(i13(j,i)) = 1.0d0 5373 end do 5374 do j = 1, n14(i) 5375 pscale(i14(j,i)) = 1.0d0 5376 end do 5377 do j = 1, n15(i) 5378 pscale(i15(j,i)) = 1.0d0 5379 end do 5380 do j = 1, np11(i) 5381 dscale(ip11(j,i)) = 1.0d0 5382 end do 5383 do j = 1, np12(i) 5384 dscale(ip12(j,i)) = 1.0d0 5385 end do 5386 do j = 1, np13(i) 5387 dscale(ip13(j,i)) = 1.0d0 5388 end do 5389 do j = 1, np14(i) 5390 dscale(ip14(j,i)) = 1.0d0 5391 end do 5392 end if 5393 end do 5394!$OMP END DO 5395c 5396c add local to global variables for OpenMP calculation 5397c 5398!$OMP DO 5399 do ii = 1, npole 5400 do j = 1, 3 5401 field(j,ii) = field(j,ii) + fieldt(j,ii) 5402 fieldp(j,ii) = fieldp(j,ii) + fieldtp(j,ii) 5403 fields(j,ii) = fields(j,ii) + fieldts(j,ii) 5404 fieldps(j,ii) = fieldps(j,ii) + fieldtps(j,ii) 5405 end do 5406 end do 5407!$OMP END DO 5408c 5409c combine permanent multipole field and GK reaction field 5410c 5411!$OMP DO 5412 do ii = 1, npole 5413 do j = 1, 3 5414 fields(j,ii) = field(j,ii) + fields(j,ii) 5415 fieldps(j,ii) = fieldp(j,ii) + fieldps(j,ii) 5416 end do 5417 end do 5418!$OMP END DO 5419!$OMP END PARALLEL 5420c 5421c perform deallocation of some local arrays 5422c 5423 deallocate (dscale) 5424 deallocate (pscale) 5425 deallocate (fieldt) 5426 deallocate (fieldtp) 5427 deallocate (fieldts) 5428 deallocate (fieldtps) 5429 return 5430 end 5431c 5432c 5433c ################################################################## 5434c ## ## 5435c ## subroutine ufield0d -- generalized Kirkwood mutual field ## 5436c ## ## 5437c ################################################################## 5438c 5439c 5440c "ufield0d" computes the mutual electrostatic field due to 5441c induced dipole moments for use with with generalized Kirkwood 5442c implicit solvation 5443c 5444c 5445 subroutine ufield0d (field,fieldp,fields,fieldps) 5446 use atoms 5447 use gkstuf 5448 use group 5449 use mpole 5450 use polar 5451 use polgrp 5452 use polpot 5453 use shunt 5454 use solute 5455 implicit none 5456 integer i,j,k 5457 integer ii,kk 5458 real*8 xr,yr,zr 5459 real*8 xr2,yr2,zr2 5460 real*8 fgrp,r,r2 5461 real*8 rr3,rr5 5462 real*8 duix,duiy,duiz 5463 real*8 puix,puiy,puiz 5464 real*8 dukx,duky,dukz 5465 real*8 pukx,puky,pukz 5466 real*8 duir,dukr 5467 real*8 puir,pukr 5468 real*8 duixs,duiys,duizs 5469 real*8 puixs,puiys,puizs 5470 real*8 dukxs,dukys,dukzs 5471 real*8 pukxs,pukys,pukzs 5472 real*8 duirs,puirs 5473 real*8 dukrs,pukrs 5474 real*8 rb2,rbi,rbk 5475 real*8 dwater,fd 5476 real*8 gf,gf2,gf3,gf5 5477 real*8 expterm,expc 5478 real*8 expc1,dexpc 5479 real*8 a(0:3,0:2) 5480 real*8 gux(10),guy(10) 5481 real*8 guz(10) 5482 real*8 fid(3),fkd(3) 5483 real*8 fip(3),fkp(3) 5484 real*8 fids(3),fkds(3) 5485 real*8 fips(3),fkps(3) 5486 real*8 dmpik(5) 5487 real*8, allocatable :: uscale(:) 5488 real*8 field(3,*) 5489 real*8 fieldp(3,*) 5490 real*8 fields(3,*) 5491 real*8 fieldps(3,*) 5492 real*8, allocatable :: fieldt(:,:) 5493 real*8, allocatable :: fieldtp(:,:) 5494 real*8, allocatable :: fieldts(:,:) 5495 real*8, allocatable :: fieldtps(:,:) 5496 logical proceed 5497c 5498c 5499c zero out the value of the field at each site 5500c 5501 do ii = 1, npole 5502 do j = 1, 3 5503 field(j,ii) = 0.0d0 5504 fieldp(j,ii) = 0.0d0 5505 fields(j,ii) = 0.0d0 5506 fieldps(j,ii) = 0.0d0 5507 end do 5508 end do 5509c 5510c set dielectric constant and scaling factor for water 5511c 5512 dwater = 78.3d0 5513 fd = 2.0d0 * (1.0d0-dwater) / (1.0d0+2.0d0*dwater) 5514c 5515c perform dynamic allocation of some local arrays 5516c 5517 allocate (uscale(n)) 5518c 5519c set array needed to scale connected atom interactions 5520c 5521 do i = 1, n 5522 uscale(i) = 1.0d0 5523 end do 5524c 5525c perform dynamic allocation of some local arrays 5526c 5527 allocate (fieldt(3,npole)) 5528 allocate (fieldtp(3,npole)) 5529 allocate (fieldts(3,npole)) 5530 allocate (fieldtps(3,npole)) 5531c 5532c initialize local variables for OpenMP calculation 5533c 5534 do ii = 1, npole 5535 do j = 1, 3 5536 fieldt(j,ii) = 0.0d0 5537 fieldtp(j,ii) = 0.0d0 5538 fieldts(j,ii) = 0.0d0 5539 fieldtps(j,ii) = 0.0d0 5540 end do 5541 end do 5542c 5543c OpenMP directives for the major loop structure 5544c 5545!$OMP PARALLEL default(private) shared(npole,ipole,rborn,uind,uinp, 5546!$OMP& uinds,uinps,np11,np12,np13,np14,ip11,ip12,ip13,ip14,u1scale, 5547!$OMP& u2scale,u3scale,u4scale,use_intra,x,y,z,off2,fd,gkc,field, 5548!$OMP& fieldp,fields,fieldps) 5549!$OMP& firstprivate(uscale) shared(fieldt,fieldtp,fieldts,fieldtps) 5550!$OMP DO reduction(+:fieldt,fieldtp,fieldts,fieldtps) schedule(guided) 5551c 5552c find the field terms for each pairwise interaction 5553c 5554 do ii = 1, npole 5555 i = ipole(ii) 5556 duix = uind(1,ii) 5557 duiy = uind(2,ii) 5558 duiz = uind(3,ii) 5559 puix = uinp(1,ii) 5560 puiy = uinp(2,ii) 5561 puiz = uinp(3,ii) 5562 duixs = uinds(1,ii) 5563 duiys = uinds(2,ii) 5564 duizs = uinds(3,ii) 5565 puixs = uinps(1,ii) 5566 puiys = uinps(2,ii) 5567 puizs = uinps(3,ii) 5568 rbi = rborn(i) 5569c 5570c set exclusion coefficients for connected atoms 5571c 5572 do j = 1, np11(i) 5573 uscale(ip11(j,i)) = u1scale 5574 end do 5575 do j = 1, np12(i) 5576 uscale(ip12(j,i)) = u2scale 5577 end do 5578 do j = 1, np13(i) 5579 uscale(ip13(j,i)) = u3scale 5580 end do 5581 do j = 1, np14(i) 5582 uscale(ip14(j,i)) = u4scale 5583 end do 5584c 5585c evaluate all sites within the cutoff distance 5586c 5587 do kk = ii, npole 5588 k = ipole(kk) 5589 proceed = .true. 5590 if (use_intra) call groups (proceed,fgrp,i,k,0,0,0,0) 5591 if (proceed) then 5592 xr = x(k) - x(i) 5593 yr = y(k) - y(i) 5594 zr = z(k) - z(i) 5595 xr2 = xr * xr 5596 yr2 = yr * yr 5597 zr2 = zr * zr 5598 r2 = xr2 + yr2 + zr2 5599 if (r2 .le. off2) then 5600 r = sqrt(r2) 5601 dukx = uind(1,kk) 5602 duky = uind(2,kk) 5603 dukz = uind(3,kk) 5604 pukx = uinp(1,kk) 5605 puky = uinp(2,kk) 5606 pukz = uinp(3,kk) 5607 dukxs = uinds(1,kk) 5608 dukys = uinds(2,kk) 5609 dukzs = uinds(3,kk) 5610 pukxs = uinps(1,kk) 5611 pukys = uinps(2,kk) 5612 pukzs = uinps(3,kk) 5613 rbk = rborn(k) 5614 if (i .ne. k) then 5615 call dampthole2 (ii,kk,5,r,dmpik) 5616 dmpik(3) = uscale(k) * dmpik(3) 5617 dmpik(5) = uscale(k) * dmpik(5) 5618 rr3 = -dmpik(3) / (r*r2) 5619 rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) 5620 duir = xr*duix + yr*duiy + zr*duiz 5621 dukr = xr*dukx + yr*duky + zr*dukz 5622 puir = xr*puix + yr*puiy + zr*puiz 5623 pukr = xr*pukx + yr*puky + zr*pukz 5624 duirs = xr*duixs + yr*duiys + zr*duizs 5625 dukrs = xr*dukxs + yr*dukys + zr*dukzs 5626 puirs = xr*puixs + yr*puiys + zr*puizs 5627 pukrs = xr*pukxs + yr*pukys + zr*pukzs 5628 fid(1) = rr3*dukx + rr5*dukr*xr 5629 fid(2) = rr3*duky + rr5*dukr*yr 5630 fid(3) = rr3*dukz + rr5*dukr*zr 5631 fkd(1) = rr3*duix + rr5*duir*xr 5632 fkd(2) = rr3*duiy + rr5*duir*yr 5633 fkd(3) = rr3*duiz + rr5*duir*zr 5634 fip(1) = rr3*pukx + rr5*pukr*xr 5635 fip(2) = rr3*puky + rr5*pukr*yr 5636 fip(3) = rr3*pukz + rr5*pukr*zr 5637 fkp(1) = rr3*puix + rr5*puir*xr 5638 fkp(2) = rr3*puiy + rr5*puir*yr 5639 fkp(3) = rr3*puiz + rr5*puir*zr 5640 fids(1) = rr3*dukxs + rr5*dukrs*xr 5641 fids(2) = rr3*dukys + rr5*dukrs*yr 5642 fids(3) = rr3*dukzs + rr5*dukrs*zr 5643 fkds(1) = rr3*duixs + rr5*duirs*xr 5644 fkds(2) = rr3*duiys + rr5*duirs*yr 5645 fkds(3) = rr3*duizs + rr5*duirs*zr 5646 fips(1) = rr3*pukxs + rr5*pukrs*xr 5647 fips(2) = rr3*pukys + rr5*pukrs*yr 5648 fips(3) = rr3*pukzs + rr5*pukrs*zr 5649 fkps(1) = rr3*puixs + rr5*puirs*xr 5650 fkps(2) = rr3*puiys + rr5*puirs*yr 5651 fkps(3) = rr3*puizs + rr5*puirs*zr 5652 do j = 1, 3 5653 fieldt(j,ii) = fieldt(j,ii) + fid(j) 5654 fieldt(j,kk) = fieldt(j,kk) + fkd(j) 5655 fieldtp(j,ii) = fieldtp(j,ii) + fip(j) 5656 fieldtp(j,kk) = fieldtp(j,kk) + fkp(j) 5657 fieldts(j,ii) = fieldts(j,ii) + fids(j) 5658 fieldts(j,kk) = fieldts(j,kk) + fkds(j) 5659 fieldtps(j,ii) = fieldtps(j,ii) + fips(j) 5660 fieldtps(j,kk) = fieldtps(j,kk) + fkps(j) 5661 end do 5662 end if 5663c 5664c unweighted dipole reaction potential gradient tensor 5665c 5666 rb2 = rbi * rbk 5667 expterm = exp(-r2/(gkc*rb2)) 5668 expc = expterm / gkc 5669 dexpc = -2.0d0 / (gkc*rbi*rbk) 5670 gf2 = 1.0d0 / (r2+rb2*expterm) 5671 gf = sqrt(gf2) 5672 gf3 = gf2 * gf 5673 gf5 = gf3 * gf2 5674 a(1,0) = -gf3 5675 a(2,0) = 3.0d0 * gf5 5676 expc1 = 1.0d0 - expc 5677 a(1,1) = expc1 * a(2,0) 5678 gux(2) = fd * (a(1,0) + xr2*a(1,1)) 5679 gux(3) = fd * xr*yr*a(1,1) 5680 gux(4) = fd * xr*zr*a(1,1) 5681 guy(2) = gux(3) 5682 guy(3) = fd * (a(1,0) + yr2*a(1,1)) 5683 guy(4) = fd * yr*zr*a(1,1) 5684 guz(2) = gux(4) 5685 guz(3) = guy(4) 5686 guz(4) = fd * (a(1,0) + zr2*a(1,1)) 5687 fids(1) = dukxs*gux(2) + dukys*guy(2) + dukzs*guz(2) 5688 fids(2) = dukxs*gux(3) + dukys*guy(3) + dukzs*guz(3) 5689 fids(3) = dukxs*gux(4) + dukys*guy(4) + dukzs*guz(4) 5690 fkds(1) = duixs*gux(2) + duiys*guy(2) + duizs*guz(2) 5691 fkds(2) = duixs*gux(3) + duiys*guy(3) + duizs*guz(3) 5692 fkds(3) = duixs*gux(4) + duiys*guy(4) + duizs*guz(4) 5693 fips(1) = pukxs*gux(2) + pukys*guy(2) + pukzs*guz(2) 5694 fips(2) = pukxs*gux(3) + pukys*guy(3) + pukzs*guz(3) 5695 fips(3) = pukxs*gux(4) + pukys*guy(4) + pukzs*guz(4) 5696 fkps(1) = puixs*gux(2) + puiys*guy(2) + puizs*guz(2) 5697 fkps(2) = puixs*gux(3) + puiys*guy(3) + puizs*guz(3) 5698 fkps(3) = puixs*gux(4) + puiys*guy(4) + puizs*guz(4) 5699 if (i .eq. k) then 5700 do j = 1, 3 5701 fids(j) = 0.5d0 * fids(j) 5702 fkds(j) = 0.5d0 * fkds(j) 5703 fips(j) = 0.5d0 * fips(j) 5704 fkps(j) = 0.5d0 * fkps(j) 5705 end do 5706 end if 5707 do j = 1, 3 5708 fieldts(j,ii) = fieldts(j,ii) + fids(j) 5709 fieldts(j,kk) = fieldts(j,kk) + fkds(j) 5710 fieldtps(j,ii) = fieldtps(j,ii) + fips(j) 5711 fieldtps(j,kk) = fieldtps(j,kk) + fkps(j) 5712 end do 5713 end if 5714 end if 5715 end do 5716c 5717c reset exclusion coefficients for connected atoms 5718c 5719 do j = 1, np11(i) 5720 uscale(ip11(j,i)) = 1.0d0 5721 end do 5722 do j = 1, np12(i) 5723 uscale(ip12(j,i)) = 1.0d0 5724 end do 5725 do j = 1, np13(i) 5726 uscale(ip13(j,i)) = 1.0d0 5727 end do 5728 do j = 1, np14(i) 5729 uscale(ip14(j,i)) = 1.0d0 5730 end do 5731 end do 5732!$OMP END DO 5733c 5734c add local to global variables for OpenMP calculation 5735c 5736!$OMP DO 5737 do ii = 1, npole 5738 do j = 1, 3 5739 field(j,ii) = field(j,ii) + fieldt(j,ii) 5740 fieldp(j,ii) = fieldp(j,ii) + fieldtp(j,ii) 5741 fields(j,ii) = fields(j,ii) + fieldts(j,ii) 5742 fieldps(j,ii) = fieldps(j,ii) + fieldtps(j,ii) 5743 end do 5744 end do 5745!$OMP END DO 5746!$OMP END PARALLEL 5747c 5748c perform deallocation of some local arrays 5749c 5750 deallocate (uscale) 5751 deallocate (fieldt) 5752 deallocate (fieldtp) 5753 deallocate (fieldts) 5754 deallocate (fieldtps) 5755 return 5756 end 5757c 5758c 5759c ################################################################## 5760c ## ## 5761c ## subroutine induce0d -- Poisson-Boltzmann induced dipoles ## 5762c ## ## 5763c ################################################################## 5764c 5765c 5766c "induce0d" computes the induced dipole moments at polarizable 5767c sites for Poisson-Boltzmann SCRF and vacuum environments 5768c 5769c 5770 subroutine induce0d 5771 use atoms 5772 use inform 5773 use iounit 5774 use mpole 5775 use polar 5776 use polopt 5777 use polpot 5778 use potent 5779 use units 5780 use uprior 5781 implicit none 5782 integer i,j,k,iter 5783 integer miniter 5784 integer maxiter 5785 real*8 polmin 5786 real*8 eps,epsold 5787 real*8 epsd,epsp 5788 real*8 epsds,epsps 5789 real*8 udsum,upsum 5790 real*8 ussum,upssum 5791 real*8 a,ap,as,aps 5792 real*8 b,bp,bs,bps 5793 real*8 sum,sump 5794 real*8 sums,sumps 5795 real*8, allocatable :: poli(:) 5796 real*8, allocatable :: field(:,:) 5797 real*8, allocatable :: fieldp(:,:) 5798 real*8, allocatable :: fields(:,:) 5799 real*8, allocatable :: fieldps(:,:) 5800 real*8, allocatable :: rsd(:,:) 5801 real*8, allocatable :: rsdp(:,:) 5802 real*8, allocatable :: rsds(:,:) 5803 real*8, allocatable :: rsdps(:,:) 5804 real*8, allocatable :: zrsd(:,:) 5805 real*8, allocatable :: zrsdp(:,:) 5806 real*8, allocatable :: zrsds(:,:) 5807 real*8, allocatable :: zrsdps(:,:) 5808 real*8, allocatable :: conj(:,:) 5809 real*8, allocatable :: conjp(:,:) 5810 real*8, allocatable :: conjs(:,:) 5811 real*8, allocatable :: conjps(:,:) 5812 real*8, allocatable :: vec(:,:) 5813 real*8, allocatable :: vecp(:,:) 5814 real*8, allocatable :: vecs(:,:) 5815 real*8, allocatable :: vecps(:,:) 5816 real*8, allocatable :: usum(:,:) 5817 real*8, allocatable :: usump(:,:) 5818 real*8, allocatable :: usums(:,:) 5819 real*8, allocatable :: usumps(:,:) 5820 logical done 5821 character*6 mode 5822c 5823c 5824c zero out the induced dipoles; uind and uinp are vacuum dipoles, 5825c uinds and uinps are Poisson-Boltzmann SCRF dipoles 5826c 5827 do i = 1, npole 5828 do j = 1, 3 5829 uind(j,i) = 0.0d0 5830 uinp(j,i) = 0.0d0 5831 uinds(j,i) = 0.0d0 5832 uinps(j,i) = 0.0d0 5833 end do 5834 end do 5835 if (.not.use_polar .or. .not.use_solv) return 5836c 5837c set the switching function coefficients 5838c 5839 mode = 'MPOLE' 5840 call switch (mode) 5841c 5842c perform dynamic allocation of some local arrays 5843c 5844 allocate (field(3,npole)) 5845 allocate (fieldp(3,npole)) 5846 allocate (fields(3,npole)) 5847 allocate (fieldps(3,npole)) 5848c 5849c compute the direct induced dipole moment at each atom, and 5850c another set that also includes RF due to permanent multipoles 5851c 5852 call dfield0e (field,fieldp,fields,fieldps) 5853c 5854c set vacuum induced dipoles to polarizability times direct field; 5855c SCRF induced dipoles are polarizability times direct field 5856c plus the reaction field due to permanent multipoles 5857c 5858 do i = 1, npole 5859 if (douind(ipole(i))) then 5860 do j = 1, 3 5861 udir(j,i) = polarity(i) * field(j,i) 5862 udirp(j,i) = polarity(i) * fieldp(j,i) 5863 udirs(j,i) = polarity(i) * fields(j,i) 5864 udirps(j,i) = polarity(i) * fieldps(j,i) 5865 uind(j,i) = udir(j,i) 5866 uinp(j,i) = udirp(j,i) 5867 uinds(j,i) = udirs(j,i) 5868 uinps(j,i) = udirps(j,i) 5869 end do 5870 end if 5871 end do 5872c 5873c get induced dipoles via the OPT extrapolation method 5874c 5875 if (poltyp .eq. 'OPT') then 5876 do i = 1, npole 5877 if (douind(ipole(i))) then 5878 do j = 1, 3 5879 uopt(0,j,i) = udir(j,i) 5880 uoptp(0,j,i) = udirp(j,i) 5881 uopts(0,j,i) = udirs(j,i) 5882 uoptps(0,j,i) = udirps(j,i) 5883 end do 5884 end if 5885 end do 5886 do k = 1, optorder 5887 call ufield0e (field,fieldp,fields,fieldps) 5888 do i = 1, npole 5889 if (douind(ipole(i))) then 5890 do j = 1, 3 5891 uopt(k,j,i) = polarity(i) * field(j,i) 5892 uoptp(k,j,i) = polarity(i) * fieldp(j,i) 5893 uopts(k,j,i) = polarity(i) * fields(j,i) 5894 uoptps(k,j,i) = polarity(i) * fieldps(j,i) 5895 uind(j,i) = uopt(k,j,i) 5896 uinp(j,i) = uoptp(k,j,i) 5897 uinds(j,i) = uopts(k,j,i) 5898 uinps(j,i) = uoptps(k,j,i) 5899 end do 5900 end if 5901 end do 5902 end do 5903 allocate (usum(3,n)) 5904 allocate (usump(3,n)) 5905 allocate (usums(3,n)) 5906 allocate (usumps(3,n)) 5907 do i = 1, npole 5908 if (douind(ipole(i))) then 5909 do j = 1, 3 5910 uind(j,i) = 0.0d0 5911 uinp(j,i) = 0.0d0 5912 uinds(j,i) = 0.0d0 5913 uinps(j,i) = 0.0d0 5914 usum(j,i) = 0.0d0 5915 usump(j,i) = 0.0d0 5916 usums(j,i) = 0.0d0 5917 usumps(j,i) = 0.0d0 5918 do k = 0, optorder 5919 usum(j,i) = usum(j,i) + uopt(k,j,i) 5920 usump(j,i) = usump(j,i) + uoptp(k,j,i) 5921 usums(j,i) = usums(j,i) + uopts(k,j,i) 5922 usumps(j,i) = usumps(j,i) + uoptps(k,j,i) 5923 uind(j,i) = uind(j,i) + copt(k)*usum(j,i) 5924 uinp(j,i) = uinp(j,i) + copt(k)*usump(j,i) 5925 uinds(j,i) = uinds(j,i) + copt(k)*usums(j,i) 5926 uinps(j,i) = uinps(j,i) + copt(k)*usumps(j,i) 5927 end do 5928 end do 5929 end if 5930 end do 5931 deallocate (usum) 5932 deallocate (usump) 5933 deallocate (usums) 5934 deallocate (usumps) 5935 end if 5936c 5937c set tolerances for computation of mutual induced dipoles 5938c 5939 if (poltyp .eq. 'MUTUAL') then 5940 done = .false. 5941 miniter = min(3,npole) 5942 maxiter = 100 5943 iter = 0 5944 polmin = 0.00000001d0 5945 eps = 100.0d0 5946c 5947c estimated induced dipoles from polynomial predictor 5948c 5949 if (use_pred .and. nualt.eq.maxualt) then 5950 do i = 1, npole 5951 do j = 1, 3 5952 udsum = 0.0d0 5953 upsum = 0.0d0 5954 ussum = 0.0d0 5955 upssum = 0.0d0 5956 do k = 1, nualt-1 5957 udsum = udsum + bpred(k)*udalt(k,j,i) 5958 upsum = upsum + bpredp(k)*upalt(k,j,i) 5959 ussum = ussum + bpreds(k)*usalt(k,j,i) 5960 upssum = upssum + bpredps(k)*upsalt(k,j,i) 5961 end do 5962 uind(j,i) = udsum 5963 uinp(j,i) = upsum 5964 uinds(j,i) = ussum 5965 uinps(j,i) = upssum 5966 end do 5967 end do 5968 end if 5969c 5970c perform dynamic allocation of some local arrays 5971c 5972 allocate (poli(npole)) 5973 allocate (rsd(3,npole)) 5974 allocate (rsdp(3,npole)) 5975 allocate (rsds(3,npole)) 5976 allocate (rsdps(3,npole)) 5977 allocate (zrsd(3,npole)) 5978 allocate (zrsdp(3,npole)) 5979 allocate (zrsds(3,npole)) 5980 allocate (zrsdps(3,npole)) 5981 allocate (conj(3,npole)) 5982 allocate (conjp(3,npole)) 5983 allocate (conjs(3,npole)) 5984 allocate (conjps(3,npole)) 5985 allocate (vec(3,npole)) 5986 allocate (vecp(3,npole)) 5987 allocate (vecs(3,npole)) 5988 allocate (vecps(3,npole)) 5989c 5990c set initial conjugate gradient residual and conjugate vector 5991c 5992 call ufield0e (field,fieldp,fields,fieldps) 5993 do i = 1, npole 5994 if (douind(ipole(i))) then 5995 poli(i) = max(polmin,polarity(i)) 5996 do j = 1, 3 5997 rsd(j,i) = (udir(j,i)-uind(j,i))/poli(i) 5998 & + field(j,i) 5999 rsdp(j,i) = (udirp(j,i)-uinp(j,i))/poli(i) 6000 & + fieldp(j,i) 6001 rsds(j,i) = (udirs(j,i)-uinds(j,i))/poli(i) 6002 & + fields(j,i) 6003 rsdps(j,i) = (udirps(j,i)-uinps(j,i))/poli(i) 6004 & + fieldps(j,i) 6005 zrsd(j,i) = rsd(j,i) * poli(i) 6006 zrsdp(j,i) = rsdp(j,i) * poli(i) 6007 zrsds(j,i) = rsds(j,i) * poli(i) 6008 zrsdps(j,i) = rsdps(j,i) * poli(i) 6009 conj(j,i) = zrsd(j,i) 6010 conjp(j,i) = zrsdp(j,i) 6011 conjs(j,i) = zrsds(j,i) 6012 conjps(j,i) = zrsdps(j,i) 6013 end do 6014 end if 6015 end do 6016c 6017c conjugate gradient iteration of the mutual induced dipoles 6018c 6019 do while (.not. done) 6020 iter = iter + 1 6021 do i = 1, npole 6022 if (douind(ipole(i))) then 6023 do j = 1, 3 6024 vec(j,i) = uind(j,i) 6025 vecp(j,i) = uinp(j,i) 6026 vecs(j,i) = uinds(j,i) 6027 vecps(j,i) = uinps(j,i) 6028 uind(j,i) = conj(j,i) 6029 uinp(j,i) = conjp(j,i) 6030 uinds(j,i) = conjs(j,i) 6031 uinps(j,i) = conjps(j,i) 6032 end do 6033 end if 6034 end do 6035 call ufield0e (field,fieldp,fields,fieldps) 6036 do i = 1, npole 6037 if (douind(ipole(i))) then 6038 do j = 1, 3 6039 uind(j,i) = vec(j,i) 6040 uinp(j,i) = vecp(j,i) 6041 uinds(j,i) = vecs(j,i) 6042 uinps(j,i) = vecps(j,i) 6043 vec(j,i) = conj(j,i)/poli(i) - field(j,i) 6044 vecp(j,i) = conjp(j,i)/poli(i) - fieldp(j,i) 6045 vecs(j,i) = conjs(j,i)/poli(i) - fields(j,i) 6046 vecps(j,i) = conjps(j,i)/poli(i) - fieldps(j,i) 6047 end do 6048 end if 6049 end do 6050 a = 0.0d0 6051 ap = 0.0d0 6052 as = 0.0d0 6053 aps = 0.0d0 6054 sum = 0.0d0 6055 sump = 0.0d0 6056 sums = 0.0d0 6057 sumps = 0.0d0 6058 do i = 1, npole 6059 if (douind(ipole(i))) then 6060 do j = 1, 3 6061 a = a + conj(j,i)*vec(j,i) 6062 ap = ap + conjp(j,i)*vecp(j,i) 6063 as = as + conjs(j,i)*vecs(j,i) 6064 aps = aps + conjps(j,i)*vecps(j,i) 6065 sum = sum + rsd(j,i)*zrsd(j,i) 6066 sump = sump + rsdp(j,i)*zrsdp(j,i) 6067 sums = sums + rsds(j,i)*zrsds(j,i) 6068 sumps = sumps + rsdps(j,i)*zrsdps(j,i) 6069 end do 6070 end if 6071 end do 6072 if (a .ne. 0.0d0) a = sum / a 6073 if (ap .ne. 0.0d0) ap = sump / ap 6074 if (as .ne. 0.0d0) as = sums / as 6075 if (aps .ne. 0.0d0) aps = sumps / aps 6076 do i = 1, npole 6077 if (douind(ipole(i))) then 6078 do j = 1, 3 6079 uind(j,i) = uind(j,i) + a*conj(j,i) 6080 uinp(j,i) = uinp(j,i) + ap*conjp(j,i) 6081 uinds(j,i) = uinds(j,i) + as*conjs(j,i) 6082 uinps(j,i) = uinps(j,i) + aps*conjps(j,i) 6083 rsd(j,i) = rsd(j,i) - a*vec(j,i) 6084 rsdp(j,i) = rsdp(j,i) - ap*vecp(j,i) 6085 rsds(j,i) = rsds(j,i) - as*vecs(j,i) 6086 rsdps(j,i) = rsdps(j,i) - aps*vecps(j,i) 6087 end do 6088 end if 6089 end do 6090 b = 0.0d0 6091 bp = 0.0d0 6092 bs = 0.0d0 6093 bps = 0.0d0 6094 do i = 1, npole 6095 if (douind(ipole(i))) then 6096 do j = 1, 3 6097 zrsd(j,i) = rsd(j,i) * poli(i) 6098 zrsdp(j,i) = rsdp(j,i) * poli(i) 6099 zrsds(j,i) = rsds(j,i) * poli(i) 6100 zrsdps(j,i) = rsdps(j,i) * poli(i) 6101 b = b + rsd(j,i)*zrsd(j,i) 6102 bp = bp + rsdp(j,i)*zrsdp(j,i) 6103 bs = bs + rsds(j,i)*zrsds(j,i) 6104 bps = bps + rsdps(j,i)*zrsdps(j,i) 6105 end do 6106 end if 6107 end do 6108 if (sum .ne. 0.0d0) b = b / sum 6109 if (sump .ne. 0.0d0) bp = bp / sump 6110 if (sums .ne. 0.0d0) bs = bs / sums 6111 if (sumps .ne. 0.0d0) bps = bps / sumps 6112 epsd = 0.0d0 6113 epsp = 0.0d0 6114 epsds = 0.0d0 6115 epsps = 0.0d0 6116 do i = 1, npole 6117 if (douind(ipole(i))) then 6118 do j = 1, 3 6119 conj(j,i) = zrsd(j,i) + b*conj(j,i) 6120 conjp(j,i) = zrsdp(j,i) + bp*conjp(j,i) 6121 conjs(j,i) = zrsds(j,i) + bs*conjs(j,i) 6122 conjps(j,i) = zrsdps(j,i) + bps*conjps(j,i) 6123 epsd = epsd + rsd(j,i)*rsd(j,i) 6124 epsp = epsp + rsdp(j,i)*rsdp(j,i) 6125 epsds = epsds + rsds(j,i)*rsds(j,i) 6126 epsps = epsps + rsdps(j,i)*rsdps(j,i) 6127 end do 6128 end if 6129 end do 6130c 6131c check the convergence of the mutual induced dipoles 6132c 6133 epsold = eps 6134 eps = max(epsd,epsp,epsds,epsps) 6135 eps = debye * sqrt(eps/dble(npolar)) 6136 if (debug) then 6137 if (iter .eq. 1) then 6138 write (iout,10) 6139 10 format (/,' Determination of Induced Dipole', 6140 & ' Moments :', 6141 & //,4x,'Iter',8x,'RMS Change (Debye)',/) 6142 end if 6143 write (iout,20) iter,eps 6144 20 format (i8,7x,f16.10) 6145 end if 6146 if (eps .lt. poleps) done = .true. 6147 if (eps .gt. epsold) done = .true. 6148 if (iter .lt. miniter) done = .false. 6149 if (iter .ge. politer) done = .true. 6150c 6151c apply a "peek" iteration to the mutual induced dipoles 6152c 6153 if (done) then 6154 do i = 1, npole 6155 if (douind(ipole(i))) then 6156 do j = 1, 3 6157 uind(j,i) = uind(j,i) + poli(i)*rsd(j,i) 6158 uinp(j,i) = uinp(j,i) + poli(i)*rsdp(j,i) 6159 uinds(j,i) = uinds(j,i) + poli(i)*rsds(j,i) 6160 uinps(j,i) = uinps(j,i) + poli(i)*rsdps(j,i) 6161 end do 6162 end if 6163 end do 6164 end if 6165 end do 6166c 6167c perform deallocation of some local arrays 6168c 6169 deallocate (poli) 6170 deallocate (rsd) 6171 deallocate (rsdp) 6172 deallocate (rsds) 6173 deallocate (rsdps) 6174 deallocate (zrsd) 6175 deallocate (zrsdp) 6176 deallocate (zrsds) 6177 deallocate (zrsdps) 6178 deallocate (conj) 6179 deallocate (conjp) 6180 deallocate (conjs) 6181 deallocate (conjps) 6182 deallocate (vec) 6183 deallocate (vecp) 6184 deallocate (vecs) 6185 deallocate (vecps) 6186c 6187c print the results from the conjugate gradient iteration 6188c 6189 if (debug) then 6190 write (iout,30) iter,eps 6191 30 format (/,' Induced Dipoles :',6x,'Iterations',i5, 6192 & 6x,'RMS Change',f15.10) 6193 end if 6194c 6195c terminate the calculation if dipoles failed to converge 6196c 6197 if (iter.ge.maxiter .or. eps.gt.epsold) then 6198 write (iout,40) 6199 40 format (/,' INDUCE -- Warning, Induced Dipoles', 6200 & ' are not Converged') 6201 call prterr 6202 call fatal 6203 end if 6204 end if 6205c 6206c perform deallocation of some local arrays 6207c 6208 deallocate (field) 6209 deallocate (fieldp) 6210 deallocate (fields) 6211 deallocate (fieldps) 6212 return 6213 end 6214c 6215c 6216c ############################################################### 6217c ## ## 6218c ## subroutine dfield0e -- Poisson-Boltzmann direct field ## 6219c ## ## 6220c ############################################################### 6221c 6222c 6223c "dfield0e" computes the direct electrostatic field due to 6224c permanent multipole moments for use with in Poisson-Boltzmann 6225c 6226c 6227 subroutine dfield0e (field,fieldp,fields,fieldps) 6228 use atoms 6229 use couple 6230 use group 6231 use mpole 6232 use pbstuf 6233 use polar 6234 use polgrp 6235 use polpot 6236 use shunt 6237 use solpot 6238 implicit none 6239 integer i,j,k 6240 integer ii,kk 6241 real*8 xr,yr,zr 6242 real*8 xr2,yr2,zr2 6243 real*8 fgrp,r,r2 6244 real*8 rr3,rr5,rr7 6245 real*8 ci,dix,diy,diz 6246 real*8 qixx,qixy,qixz 6247 real*8 qiyy,qiyz,qizz 6248 real*8 ck,dkx,dky,dkz 6249 real*8 qkxx,qkxy,qkxz 6250 real*8 qkyy,qkyz,qkzz 6251 real*8 dir,dkr 6252 real*8 qix,qiy,qiz,qir 6253 real*8 qkx,qky,qkz,qkr 6254 real*8 fid(3),fkd(3) 6255 real*8 dmpik(7) 6256 real*8 field(3,*) 6257 real*8 fieldp(3,*) 6258 real*8 fields(3,*) 6259 real*8 fieldps(3,*) 6260 real*8, allocatable :: dscale(:) 6261 real*8, allocatable :: pscale(:) 6262 logical proceed 6263c 6264c 6265c zero out the value of the field at each site 6266c 6267 do ii = 1, npole 6268 do j = 1, 3 6269 field(j,ii) = 0.0d0 6270 fieldp(j,ii) = 0.0d0 6271 end do 6272 end do 6273c 6274c perform dynamic allocation of some local arrays 6275c 6276 allocate (dscale(n)) 6277 allocate (pscale(n)) 6278c 6279c set arrays needed to scale connected atom interactions 6280c 6281 do i = 1, n 6282 pscale(i) = 1.0d0 6283 dscale(i) = 1.0d0 6284 end do 6285c 6286c compute the direct electrostatic field at each atom, and 6287c another field including RF due to permanent multipoles; 6288c note self-interactions for the solute field are skipped 6289c 6290 do ii = 1, npole 6291 i = ipole(ii) 6292 ci = rpole(1,ii) 6293 dix = rpole(2,ii) 6294 diy = rpole(3,ii) 6295 diz = rpole(4,ii) 6296 qixx = rpole(5,ii) 6297 qixy = rpole(6,ii) 6298 qixz = rpole(7,ii) 6299 qiyy = rpole(9,ii) 6300 qiyz = rpole(10,ii) 6301 qizz = rpole(13,ii) 6302c 6303c set exclusion coefficients for connected atoms 6304c 6305 if (dpequal) then 6306 do j = 1, n12(i) 6307 pscale(i12(j,i)) = p2scale 6308 do k = 1, np11(i) 6309 if (i12(j,i) .eq. ip11(k,i)) 6310 & pscale(i12(j,i)) = p2iscale 6311 end do 6312 dscale(i12(j,i)) = pscale(i12(j,i)) 6313 end do 6314 do j = 1, n13(i) 6315 pscale(i13(j,i)) = p3scale 6316 do k = 1, np11(i) 6317 if (i13(j,i) .eq. ip11(k,i)) 6318 & pscale(i13(j,i)) = p3iscale 6319 end do 6320 dscale(i13(j,i)) = pscale(i13(j,i)) 6321 end do 6322 do j = 1, n14(i) 6323 pscale(i14(j,i)) = p4scale 6324 do k = 1, np11(i) 6325 if (i14(j,i) .eq. ip11(k,i)) 6326 & pscale(i14(j,i)) = p4iscale 6327 end do 6328 dscale(i14(j,i)) = pscale(i14(j,i)) 6329 end do 6330 do j = 1, n15(i) 6331 pscale(i15(j,i)) = p5scale 6332 do k = 1, np11(i) 6333 if (i15(j,i) .eq. ip11(k,i)) 6334 & pscale(i15(j,i)) = p5iscale 6335 end do 6336 dscale(i15(j,i)) = pscale(i15(j,i)) 6337 end do 6338 else 6339 do j = 1, n12(i) 6340 pscale(i12(j,i)) = p2scale 6341 do k = 1, np11(i) 6342 if (i12(j,i) .eq. ip11(k,i)) 6343 & pscale(i12(j,i)) = p2iscale 6344 end do 6345 end do 6346 do j = 1, n13(i) 6347 pscale(i13(j,i)) = p3scale 6348 do k = 1, np11(i) 6349 if (i13(j,i) .eq. ip11(k,i)) 6350 & pscale(i13(j,i)) = p3iscale 6351 end do 6352 end do 6353 do j = 1, n14(i) 6354 pscale(i14(j,i)) = p4scale 6355 do k = 1, np11(i) 6356 if (i14(j,i) .eq. ip11(k,i)) 6357 & pscale(i14(j,i)) = p4iscale 6358 end do 6359 end do 6360 do j = 1, n15(i) 6361 pscale(i15(j,i)) = p5scale 6362 do k = 1, np11(i) 6363 if (i15(j,i) .eq. ip11(k,i)) 6364 & pscale(i15(j,i)) = p5iscale 6365 end do 6366 end do 6367 do j = 1, np11(i) 6368 dscale(ip11(j,i)) = d1scale 6369 end do 6370 do j = 1, np12(i) 6371 dscale(ip12(j,i)) = d2scale 6372 end do 6373 do j = 1, np13(i) 6374 dscale(ip13(j,i)) = d3scale 6375 end do 6376 do j = 1, np14(i) 6377 dscale(ip14(j,i)) = d4scale 6378 end do 6379 end if 6380c 6381c evaluate all sites within the cutoff distance 6382c 6383 do kk = ii+1, npole 6384 k = ipole(kk) 6385 proceed = .true. 6386 if (use_intra) call groups (proceed,fgrp,i,k,0,0,0,0) 6387 if (proceed) then 6388 xr = x(k) - x(i) 6389 yr = y(k) - y(i) 6390 zr = z(k) - z(i) 6391 xr2 = xr * xr 6392 yr2 = yr * yr 6393 zr2 = zr * zr 6394 r2 = xr2 + yr2 + zr2 6395 if (r2 .le. off2) then 6396 r = sqrt(r2) 6397 ck = rpole(1,kk) 6398 dkx = rpole(2,kk) 6399 dky = rpole(3,kk) 6400 dkz = rpole(4,kk) 6401 qkxx = rpole(5,kk) 6402 qkxy = rpole(6,kk) 6403 qkxz = rpole(7,kk) 6404 qkyy = rpole(9,kk) 6405 qkyz = rpole(10,kk) 6406 qkzz = rpole(13,kk) 6407 call dampthole (ii,kk,7,r,dmpik) 6408 rr3 = dmpik(3) / (r*r2) 6409 rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) 6410 rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2) 6411 dir = dix*xr + diy*yr + diz*zr 6412 qix = qixx*xr + qixy*yr + qixz*zr 6413 qiy = qixy*xr + qiyy*yr + qiyz*zr 6414 qiz = qixz*xr + qiyz*yr + qizz*zr 6415 qir = qix*xr + qiy*yr + qiz*zr 6416 dkr = dkx*xr + dky*yr + dkz*zr 6417 qkx = qkxx*xr + qkxy*yr + qkxz*zr 6418 qky = qkxy*xr + qkyy*yr + qkyz*zr 6419 qkz = qkxz*xr + qkyz*yr + qkzz*zr 6420 qkr = qkx*xr + qky*yr + qkz*zr 6421 fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) 6422 & - rr3*dkx + 2.0d0*rr5*qkx 6423 fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) 6424 & - rr3*dky + 2.0d0*rr5*qky 6425 fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) 6426 & - rr3*dkz + 2.0d0*rr5*qkz 6427 fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) 6428 & - rr3*dix - 2.0d0*rr5*qix 6429 fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) 6430 & - rr3*diy - 2.0d0*rr5*qiy 6431 fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) 6432 & - rr3*diz - 2.0d0*rr5*qiz 6433 do j = 1, 3 6434 field(j,ii) = field(j,ii) + fid(j)*dscale(k) 6435 field(j,kk) = field(j,kk) + fkd(j)*dscale(k) 6436 fieldp(j,ii) = fieldp(j,ii) + fid(j)*pscale(k) 6437 fieldp(j,kk) = fieldp(j,kk) + fkd(j)*pscale(k) 6438 end do 6439 end if 6440 end if 6441 end do 6442c 6443c reset exclusion coefficients for connected atoms 6444c 6445 if (dpequal) then 6446 do j = 1, n12(i) 6447 pscale(i12(j,i)) = 1.0d0 6448 dscale(i12(j,i)) = 1.0d0 6449 end do 6450 do j = 1, n13(i) 6451 pscale(i13(j,i)) = 1.0d0 6452 dscale(i13(j,i)) = 1.0d0 6453 end do 6454 do j = 1, n14(i) 6455 pscale(i14(j,i)) = 1.0d0 6456 dscale(i14(j,i)) = 1.0d0 6457 end do 6458 do j = 1, n15(i) 6459 pscale(i15(j,i)) = 1.0d0 6460 dscale(i15(j,i)) = 1.0d0 6461 end do 6462 else 6463 do j = 1, n12(i) 6464 pscale(i12(j,i)) = 1.0d0 6465 end do 6466 do j = 1, n13(i) 6467 pscale(i13(j,i)) = 1.0d0 6468 end do 6469 do j = 1, n14(i) 6470 pscale(i14(j,i)) = 1.0d0 6471 end do 6472 do j = 1, n15(i) 6473 pscale(i15(j,i)) = 1.0d0 6474 end do 6475 do j = 1, np11(i) 6476 dscale(ip11(j,i)) = 1.0d0 6477 end do 6478 do j = 1, np12(i) 6479 dscale(ip12(j,i)) = 1.0d0 6480 end do 6481 do j = 1, np13(i) 6482 dscale(ip13(j,i)) = 1.0d0 6483 end do 6484 do j = 1, np14(i) 6485 dscale(ip14(j,i)) = 1.0d0 6486 end do 6487 end if 6488 end do 6489c 6490c perform deallocation of some local arrays 6491c 6492 deallocate (dscale) 6493 deallocate (pscale) 6494c 6495c find the Poisson-Boltzmann reaction field at each site 6496c 6497 call pbempole 6498c 6499c combine permanent multipole field and PB reaction field 6500c 6501 do ii = 1, npole 6502 i = ipole(ii) 6503 do j = 1, 3 6504 fields(j,ii) = field(j,ii) + pbep(j,i) 6505 fieldps(j,ii) = fieldp(j,ii) + pbep(j,i) 6506 end do 6507 end do 6508 return 6509 end 6510c 6511c 6512c ############################################################### 6513c ## ## 6514c ## subroutine ufield0e -- Poisson-Boltzmann mutual field ## 6515c ## ## 6516c ############################################################### 6517c 6518c 6519c "ufield0e" computes the mutual electrostatic field due to 6520c induced dipole moments via a Poisson-Boltzmann solver 6521c 6522c 6523 subroutine ufield0e (field,fieldp,fields,fieldps) 6524 use atoms 6525 use group 6526 use mpole 6527 use pbstuf 6528 use polar 6529 use polgrp 6530 use polpot 6531 use shunt 6532 use solpot 6533 implicit none 6534 integer i,j,k 6535 integer ii,kk 6536 real*8 xr,yr,zr 6537 real*8 xr2,yr2,zr2 6538 real*8 fgrp,r,r2 6539 real*8 rr3,rr5 6540 real*8 duix,duiy,duiz 6541 real*8 puix,puiy,puiz 6542 real*8 dukx,duky,dukz 6543 real*8 pukx,puky,pukz 6544 real*8 duir,puir 6545 real*8 dukr,pukr 6546 real*8 duixs,duiys,duizs 6547 real*8 puixs,puiys,puizs 6548 real*8 dukxs,dukys,dukzs 6549 real*8 pukxs,pukys,pukzs 6550 real*8 duirs,puirs 6551 real*8 dukrs,pukrs 6552 real*8 fid(3),fkd(3) 6553 real*8 fip(3),fkp(3) 6554 real*8 fids(3),fkds(3) 6555 real*8 fips(3),fkps(3) 6556 real*8 dmpik(5) 6557 real*8 field(3,*) 6558 real*8 fieldp(3,*) 6559 real*8 fields(3,*) 6560 real*8 fieldps(3,*) 6561 real*8, allocatable :: uscale(:) 6562 real*8, allocatable :: indpole(:,:) 6563 real*8, allocatable :: inppole(:,:) 6564 logical proceed 6565c 6566c 6567c zero out the value of the field at each site 6568c 6569 do ii = 1, npole 6570 do j = 1, 3 6571 field(j,ii) = 0.0d0 6572 fieldp(j,ii) = 0.0d0 6573 fields(j,ii) = 0.0d0 6574 fieldps(j,ii) = 0.0d0 6575 end do 6576 end do 6577c 6578c perform dynamic allocation of some local arrays 6579c 6580 allocate (uscale(n)) 6581c 6582c set array needed to scale connected atom interactions 6583c 6584 do i = 1, n 6585 uscale(i) = 1.0d0 6586 end do 6587c 6588c compute the mutual electrostatic field at each atom, 6589c and another field including RF due to induced dipoles 6590c 6591 do ii = 1, npole 6592 i = ipole(ii) 6593 duix = uind(1,ii) 6594 duiy = uind(2,ii) 6595 duiz = uind(3,ii) 6596 puix = uinp(1,ii) 6597 puiy = uinp(2,ii) 6598 puiz = uinp(3,ii) 6599 duixs = uinds(1,ii) 6600 duiys = uinds(2,ii) 6601 duizs = uinds(3,ii) 6602 puixs = uinps(1,ii) 6603 puiys = uinps(2,ii) 6604 puizs = uinps(3,ii) 6605c 6606c set exclusion coefficients for connected atoms 6607c 6608 do j = 1, np11(i) 6609 uscale(ip11(j,i)) = u1scale 6610 end do 6611 do j = 1, np12(i) 6612 uscale(ip12(j,i)) = u2scale 6613 end do 6614 do j = 1, np13(i) 6615 uscale(ip13(j,i)) = u3scale 6616 end do 6617 do j = 1, np14(i) 6618 uscale(ip14(j,i)) = u4scale 6619 end do 6620c 6621c evaluate all sites within the cutoff distance 6622c 6623 do kk = ii+1, npole 6624 k = ipole(kk) 6625 proceed = .true. 6626 if (use_intra) call groups (proceed,fgrp,i,k,0,0,0,0) 6627 if (proceed) then 6628 xr = x(k) - x(i) 6629 yr = y(k) - y(i) 6630 zr = z(k) - z(i) 6631 xr2 = xr * xr 6632 yr2 = yr * yr 6633 zr2 = zr * zr 6634 r2 = xr2 + yr2 + zr2 6635 if (r2 .le. off2) then 6636 r = sqrt(r2) 6637 dukx = uind(1,kk) 6638 duky = uind(2,kk) 6639 dukz = uind(3,kk) 6640 pukx = uinp(1,kk) 6641 puky = uinp(2,kk) 6642 pukz = uinp(3,kk) 6643 dukxs = uinds(1,kk) 6644 dukys = uinds(2,kk) 6645 dukzs = uinds(3,kk) 6646 pukxs = uinps(1,kk) 6647 pukys = uinps(2,kk) 6648 pukzs = uinps(3,kk) 6649 call dampthole2 (ii,kk,5,r,dmpik) 6650 dmpik(3) = uscale(k) * dmpik(3) 6651 dmpik(5) = uscale(k) * dmpik(5) 6652 rr3 = -dmpik(3) / (r*r2) 6653 rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) 6654 duir = xr*duix + yr*duiy + zr*duiz 6655 dukr = xr*dukx + yr*duky + zr*dukz 6656 puir = xr*puix + yr*puiy + zr*puiz 6657 pukr = xr*pukx + yr*puky + zr*pukz 6658 duirs = xr*duixs + yr*duiys + zr*duizs 6659 dukrs = xr*dukxs + yr*dukys + zr*dukzs 6660 puirs = xr*puixs + yr*puiys + zr*puizs 6661 pukrs = xr*pukxs + yr*pukys + zr*pukzs 6662 fid(1) = rr3*dukx + rr5*dukr*xr 6663 fid(2) = rr3*duky + rr5*dukr*yr 6664 fid(3) = rr3*dukz + rr5*dukr*zr 6665 fkd(1) = rr3*duix + rr5*duir*xr 6666 fkd(2) = rr3*duiy + rr5*duir*yr 6667 fkd(3) = rr3*duiz + rr5*duir*zr 6668 fip(1) = rr3*pukx + rr5*pukr*xr 6669 fip(2) = rr3*puky + rr5*pukr*yr 6670 fip(3) = rr3*pukz + rr5*pukr*zr 6671 fkp(1) = rr3*puix + rr5*puir*xr 6672 fkp(2) = rr3*puiy + rr5*puir*yr 6673 fkp(3) = rr3*puiz + rr5*puir*zr 6674 fids(1) = rr3*dukxs + rr5*dukrs*xr 6675 fids(2) = rr3*dukys + rr5*dukrs*yr 6676 fids(3) = rr3*dukzs + rr5*dukrs*zr 6677 fkds(1) = rr3*duixs + rr5*duirs*xr 6678 fkds(2) = rr3*duiys + rr5*duirs*yr 6679 fkds(3) = rr3*duizs + rr5*duirs*zr 6680 fips(1) = rr3*pukxs + rr5*pukrs*xr 6681 fips(2) = rr3*pukys + rr5*pukrs*yr 6682 fips(3) = rr3*pukzs + rr5*pukrs*zr 6683 fkps(1) = rr3*puixs + rr5*puirs*xr 6684 fkps(2) = rr3*puiys + rr5*puirs*yr 6685 fkps(3) = rr3*puizs + rr5*puirs*zr 6686 do j = 1, 3 6687 field(j,ii) = field(j,ii) + fid(j) 6688 field(j,kk) = field(j,kk) + fkd(j) 6689 fieldp(j,ii) = fieldp(j,ii) + fip(j) 6690 fieldp(j,kk) = fieldp(j,kk) + fkp(j) 6691 fields(j,ii) = fields(j,ii) + fids(j) 6692 fields(j,kk) = fields(j,kk) + fkds(j) 6693 fieldps(j,ii) = fieldps(j,ii) + fips(j) 6694 fieldps(j,kk) = fieldps(j,kk) + fkps(j) 6695 end do 6696 end if 6697 end if 6698 end do 6699c 6700c reset exclusion coefficients for connected atoms 6701c 6702 do j = 1, np11(i) 6703 uscale(ip11(j,i)) = 1.0d0 6704 end do 6705 do j = 1, np12(i) 6706 uscale(ip12(j,i)) = 1.0d0 6707 end do 6708 do j = 1, np13(i) 6709 uscale(ip13(j,i)) = 1.0d0 6710 end do 6711 do j = 1, np14(i) 6712 uscale(ip14(j,i)) = 1.0d0 6713 end do 6714 end do 6715c 6716c perform deallocation of some local arrays 6717c 6718 deallocate (uscale) 6719c 6720c perform dynamic allocation of some global arrays 6721c 6722 if (.not. allocated(pbeuind)) allocate (pbeuind(3,n)) 6723 if (.not. allocated(pbeuinp)) allocate (pbeuinp(3,n)) 6724c 6725c perform dynamic allocation of some local arrays 6726c 6727 allocate (indpole(3,n)) 6728 allocate (inppole(3,n)) 6729c 6730c zero out the PB reaction field at each atomic site 6731c 6732 do i = 1, n 6733 do j = 1, 3 6734 indpole(j,i) = 0.0d0 6735 inppole(j,i) = 0.0d0 6736 pbeuind(j,i) = 0.0d0 6737 pbeuinp(j,i) = 0.0d0 6738 end do 6739 end do 6740c 6741c find the Poisson-Boltzmann reaction field at each site 6742c 6743 do ii = 1, npole 6744 i = ipole(ii) 6745 do j = 1, 3 6746 indpole(j,i) = uinds(j,ii) 6747 inppole(j,i) = uinps(j,ii) 6748 end do 6749 end do 6750 call apbsinduce (indpole,pbeuind) 6751 call apbsnlinduce (inppole,pbeuinp) 6752c 6753c perform deallocation of some local arrays 6754c 6755 deallocate (indpole) 6756 deallocate (inppole) 6757c 6758c combine mutual induced dipole field and PB reaction field 6759c 6760 do ii = 1, npole 6761 i = ipole(ii) 6762 do j = 1, 3 6763 fields(j,ii) = fields(j,ii) + pbeuind(j,i) 6764 fieldps(j,ii) = fieldps(j,ii) + pbeuinp(j,i) 6765 end do 6766 end do 6767 return 6768 end 6769c 6770c 6771c ################################################################ 6772c ## ## 6773c ## subroutine ulspred -- induced dipole prediction coeffs ## 6774c ## ## 6775c ################################################################ 6776c 6777c 6778c "ulspred" uses an ASPC or Gear extrapolation method, or a least 6779c squares fit, to set coefficients of an induced dipole predictor 6780c polynomial 6781c 6782c literature references: 6783c 6784c J. Kolafa, "Time-Reversible Always Stable Predictor-Corrector 6785c Method for Molecular Dynamics of Polarizable Molecules", Journal 6786c of Computational Chemistry, 25, 335-342 (2004) 6787c 6788c D. Nocito and G. J. O. Beran, Reduced Computational Cost 6789c of Polarizable Force Fields by a Modification of the Always 6790c Stable Predictor-Corrector, Journal of Chemical Physics, 150, 6791c 151103 (2019) 6792c 6793c W. Wang and R. D. Skeel, "Fast Evaluation of Polarizable Forces", 6794c Journal of Chemical Physics, 123, 164107 (2005) 6795c 6796c 6797 subroutine ulspred 6798 use mpole 6799 use uprior 6800 implicit none 6801 integer i,j,k,m 6802 real*8 coeff,udk,upk 6803 real*8 amax,apmax 6804 real*8 b(maxualt) 6805 real*8 bp(maxualt) 6806 real*8 a(maxualt*(maxualt+1)/2) 6807 real*8 ap(maxualt*(maxualt+1)/2) 6808 real*8 c(maxualt,maxualt) 6809 real*8 cp(maxualt,maxualt) 6810c 6811c 6812c set always stable predictor-corrector (ASPC) coefficients 6813c 6814 if (polpred .eq. 'ASPC') then 6815 do i = 1, nualt 6816 coeff = aspc(i) 6817 bpred(i) = coeff 6818 bpredp(i) = coeff 6819 bpreds(i) = coeff 6820 bpredps(i) = coeff 6821 end do 6822c 6823c set the Gear predictor binomial coefficients 6824c 6825 else if (polpred .eq. 'GEAR') then 6826 do i = 1, nualt 6827 coeff = gear(i) 6828 bpred(i) = coeff 6829 bpredp(i) = coeff 6830 bpreds(i) = coeff 6831 bpredps(i) = coeff 6832 end do 6833c 6834c derive normal equations corresponding to least squares fit 6835c 6836 else if (polpred .eq. 'LSQR') then 6837 do k = 1, nualt 6838 b(k) = 0.0d0 6839 bp(k) = 0.0d0 6840 do m = k, nualt 6841 c(k,m) = 0.0d0 6842 cp(k,m) = 0.0d0 6843 end do 6844 end do 6845 do i = 1, npole 6846 do j = 1, 3 6847 do k = 1, nualt 6848 udk = udalt(k,j,i) 6849 upk = upalt(k,j,i) 6850 do m = k, nualt 6851 c(k,m) = c(k,m) + udk*udalt(m,j,i) 6852 cp(k,m) = cp(k,m) + upk*upalt(m,j,i) 6853 end do 6854 end do 6855 end do 6856 end do 6857 i = 0 6858 do k = 2, nualt 6859 b(k-1) = c(1,k) 6860 bp(k-1) = cp(1,k) 6861 do m = k, nualt 6862 i = i + 1 6863 a(i) = c(k,m) 6864 ap(i) = cp(k,m) 6865 end do 6866 end do 6867c 6868c check for nonzero coefficients of the normal equations 6869c 6870 k = nualt - 1 6871 amax = 0.0d0 6872 apmax = 0.0d0 6873 do i = 1, k*(k+1)/2 6874 amax = max(amax,a(i)) 6875 apmax = max(apmax,ap(i)) 6876 end do 6877c 6878c solve the normal equations via LU matrix factorization 6879c 6880 if (amax .ne. 0.0d0) call lusolve (k,a,b) 6881 if (apmax .ne. 0.0d0) call lusolve (k,ap,bp) 6882c 6883c transfer the final solution to the coefficient vector 6884c 6885 do k = 1, nualt-1 6886 bpred(k) = b(k) 6887 bpredp(k) = bp(k) 6888 bpreds(k) = b(k) 6889 bpredps(k) = bp(k) 6890 end do 6891 bpred(nualt) = 0.0d0 6892 bpredp(nualt) = 0.0d0 6893 bpreds(nualt) = 0.0d0 6894 bpredps(nualt) = 0.0d0 6895 end if 6896 return 6897 end 6898c 6899c 6900c ############################################################### 6901c ## ## 6902c ## subroutine uscale0a -- dipole preconditioner via loop ## 6903c ## ## 6904c ############################################################### 6905c 6906c 6907c "uscale0a" builds and applies a preconditioner for the conjugate 6908c gradient induced dipole solver using a double loop 6909c 6910c 6911 subroutine uscale0a (mode,rsd,rsdp,zrsd,zrsdp) 6912 use atoms 6913 use chgpen 6914 use couple 6915 use limits 6916 use mplpot 6917 use mpole 6918 use polar 6919 use polgrp 6920 use polpcg 6921 use polpot 6922 implicit none 6923 integer i,j,k,m 6924 integer ii,kk 6925 real*8 xi,yi,zi 6926 real*8 xr,yr,zr 6927 real*8 r,r2,rr3,rr5 6928 real*8 polmin 6929 real*8 poli,polik 6930 real*8 alphai,alphak 6931 real*8 off2 6932 real*8 m1,m2,m3 6933 real*8 m4,m5,m6 6934 real*8 dmpik(5) 6935 real*8, allocatable :: uscale(:) 6936 real*8, allocatable :: wscale(:) 6937 real*8 rsd(3,*) 6938 real*8 rsdp(3,*) 6939 real*8 zrsd(3,*) 6940 real*8 zrsdp(3,*) 6941 character*6 mode 6942c 6943c 6944c apply the preconditioning matrix to the current residual 6945c 6946 if (mode .eq. 'APPLY') then 6947c 6948c use diagonal preconditioner elements as first approximation 6949c 6950 polmin = 0.00000001d0 6951 do ii = 1, npole 6952 poli = udiag * max(polmin,polarity(ii)) 6953 do j = 1, 3 6954 zrsd(j,ii) = poli * rsd(j,ii) 6955 zrsdp(j,ii) = poli * rsdp(j,ii) 6956 end do 6957 end do 6958c 6959c use the off-diagonal preconditioner elements in second phase 6960c 6961 off2 = usolvcut * usolvcut 6962 j = 0 6963 do ii = 1, npole-1 6964 i = ipole(ii) 6965 do kk = ii+1, npole 6966 k = ipole(kk) 6967 xr = x(k) - x(i) 6968 yr = y(k) - y(i) 6969 zr = z(k) - z(i) 6970 call image (xr,yr,zr) 6971 r2 = xr*xr + yr* yr + zr*zr 6972 if (r2 .le. off2) then 6973 m1 = minv(j+1) 6974 m2 = minv(j+2) 6975 m3 = minv(j+3) 6976 m4 = minv(j+4) 6977 m5 = minv(j+5) 6978 m6 = minv(j+6) 6979 j = j + 6 6980 zrsd(1,ii) = zrsd(1,ii) + m1*rsd(1,kk) 6981 & + m2*rsd(2,kk) + m3*rsd(3,kk) 6982 zrsd(2,ii) = zrsd(2,ii) + m2*rsd(1,kk) 6983 & + m4*rsd(2,kk) + m5*rsd(3,kk) 6984 zrsd(3,ii) = zrsd(3,ii) + m3*rsd(1,kk) 6985 & + m5*rsd(2,kk) + m6*rsd(3,kk) 6986 zrsd(1,kk) = zrsd(1,kk) + m1*rsd(1,ii) 6987 & + m2*rsd(2,ii) + m3*rsd(3,ii) 6988 zrsd(2,kk) = zrsd(2,kk) + m2*rsd(1,ii) 6989 & + m4*rsd(2,ii) + m5*rsd(3,ii) 6990 zrsd(3,kk) = zrsd(3,kk) + m3*rsd(1,ii) 6991 & + m5*rsd(2,ii) + m6*rsd(3,ii) 6992 zrsdp(1,ii) = zrsdp(1,ii) + m1*rsdp(1,kk) 6993 & + m2*rsdp(2,kk) + m3*rsdp(3,kk) 6994 zrsdp(2,ii) = zrsdp(2,ii) + m2*rsdp(1,kk) 6995 & + m4*rsdp(2,kk) + m5*rsdp(3,kk) 6996 zrsdp(3,ii) = zrsdp(3,ii) + m3*rsdp(1,kk) 6997 & + m5*rsdp(2,kk) + m6*rsdp(3,kk) 6998 zrsdp(1,kk) = zrsdp(1,kk) + m1*rsdp(1,ii) 6999 & + m2*rsdp(2,ii) + m3*rsdp(3,ii) 7000 zrsdp(2,kk) = zrsdp(2,kk) + m2*rsdp(1,ii) 7001 & + m4*rsdp(2,ii) + m5*rsdp(3,ii) 7002 zrsdp(3,kk) = zrsdp(3,kk) + m3*rsdp(1,ii) 7003 & + m5*rsdp(2,ii) + m6*rsdp(3,ii) 7004 end if 7005 end do 7006 end do 7007c 7008c construct off-diagonal elements of preconditioning matrix 7009c 7010 else if (mode .eq. 'BUILD') then 7011c 7012c perform dynamic allocation of some local arrays 7013c 7014 allocate (uscale(n)) 7015 allocate (wscale(n)) 7016c 7017c set array needed to scale connected atom interactions 7018c 7019 do i = 1, n 7020 uscale(i) = 1.0d0 7021 wscale(i) = 1.0d0 7022 end do 7023c 7024c determine the off-diagonal elements of the preconditioner 7025c 7026 off2 = usolvcut * usolvcut 7027 m = 0 7028 do ii = 1, npole-1 7029 i = ipole(ii) 7030 xi = x(i) 7031 yi = y(i) 7032 zi = z(i) 7033 poli = polarity(ii) 7034 if (use_chgpen) alphai = palpha(ii) 7035c 7036c set exclusion coefficients for connected atoms 7037c 7038 do j = 1, np11(i) 7039 uscale(ip11(j,i)) = u1scale 7040 end do 7041 do j = 1, np12(i) 7042 uscale(ip12(j,i)) = u2scale 7043 end do 7044 do j = 1, np13(i) 7045 uscale(ip13(j,i)) = u3scale 7046 end do 7047 do j = 1, np14(i) 7048 uscale(ip14(j,i)) = u4scale 7049 end do 7050 do j = 1, n12(i) 7051 wscale(i12(j,i)) = w2scale 7052 end do 7053 do j = 1, n13(i) 7054 wscale(i13(j,i)) = w3scale 7055 end do 7056 do j = 1, n14(i) 7057 wscale(i14(j,i)) = w4scale 7058 end do 7059 do j = 1, n15(i) 7060 wscale(i15(j,i)) = w5scale 7061 end do 7062c 7063c evaluate all sites within the cutoff distance 7064c 7065 do kk = ii+1, npole 7066 k = ipole(kk) 7067 xr = x(k) - xi 7068 yr = y(k) - yi 7069 zr = z(k) - zi 7070 call image (xr,yr,zr) 7071 r2 = xr*xr + yr* yr + zr*zr 7072 if (r2 .le. off2) then 7073 r = sqrt(r2) 7074 if (use_thole) then 7075 call dampthole2 (ii,kk,5,r,dmpik) 7076 dmpik(3) = uscale(k) * dmpik(3) 7077 dmpik(5) = uscale(k) * dmpik(5) 7078 else if (use_chgpen) then 7079 alphak = palpha(kk) 7080 call dampmut (r,alphai,alphak,dmpik) 7081 dmpik(3) = wscale(k) * dmpik(3) 7082 dmpik(5) = wscale(k) * dmpik(5) 7083 end if 7084 polik = poli * polarity(kk) 7085 rr3 = dmpik(3) * polik / (r*r2) 7086 rr5 = 3.0d0 * dmpik(5) * polik / (r*r2*r2) 7087 minv(m+1) = rr5*xr*xr - rr3 7088 minv(m+2) = rr5*xr*yr 7089 minv(m+3) = rr5*xr*zr 7090 minv(m+4) = rr5*yr*yr - rr3 7091 minv(m+5) = rr5*yr*zr 7092 minv(m+6) = rr5*zr*zr - rr3 7093 m = m + 6 7094 end if 7095 end do 7096c 7097c reset exclusion coefficients for connected atoms 7098c 7099 do j = 1, np11(i) 7100 uscale(ip11(j,i)) = 1.0d0 7101 end do 7102 do j = 1, np12(i) 7103 uscale(ip12(j,i)) = 1.0d0 7104 end do 7105 do j = 1, np13(i) 7106 uscale(ip13(j,i)) = 1.0d0 7107 end do 7108 do j = 1, np14(i) 7109 uscale(ip14(j,i)) = 1.0d0 7110 end do 7111 do j = 1, n12(i) 7112 wscale(i12(j,i)) = 1.0d0 7113 end do 7114 do j = 1, n13(i) 7115 wscale(i13(j,i)) = 1.0d0 7116 end do 7117 do j = 1, n14(i) 7118 wscale(i14(j,i)) = 1.0d0 7119 end do 7120 do j = 1, n15(i) 7121 wscale(i15(j,i)) = 1.0d0 7122 end do 7123 end do 7124c 7125c perform deallocation of some local arrays 7126c 7127 deallocate (uscale) 7128 deallocate (wscale) 7129 end if 7130 return 7131 end 7132c 7133c 7134c ############################################################### 7135c ## ## 7136c ## subroutine uscale0b -- dipole preconditioner via list ## 7137c ## ## 7138c ############################################################### 7139c 7140c 7141c "uscale0b" builds and applies a preconditioner for the conjugate 7142c gradient induced dipole solver using a neighbor pair list 7143c 7144c 7145 subroutine uscale0b (mode,rsd,rsdp,zrsd,zrsdp) 7146 use atoms 7147 use chgpen 7148 use couple 7149 use mplpot 7150 use mpole 7151 use neigh 7152 use polar 7153 use polgrp 7154 use polpcg 7155 use polpot 7156 implicit none 7157 integer i,j,k,m 7158 integer ii,kk,kkk 7159 real*8 xi,yi,zi 7160 real*8 xr,yr,zr 7161 real*8 r,r2,rr3,rr5 7162 real*8 polmin 7163 real*8 poli,polik 7164 real*8 alphai,alphak 7165 real*8 m1,m2,m3 7166 real*8 m4,m5,m6 7167 real*8 dmpik(5) 7168 real*8, allocatable :: uscale(:) 7169 real*8, allocatable :: wscale(:) 7170 real*8 rsd(3,*) 7171 real*8 rsdp(3,*) 7172 real*8 zrsd(3,*) 7173 real*8 zrsdp(3,*) 7174 real*8, allocatable :: zrsdt(:,:) 7175 real*8, allocatable :: zrsdtp(:,:) 7176 character*6 mode 7177c 7178c 7179c apply the preconditioning matrix to the current residual 7180c 7181 if (mode .eq. 'APPLY') then 7182c 7183c perform dynamic allocation of some local arrays 7184c 7185 allocate (zrsdt(3,npole)) 7186 allocate (zrsdtp(3,npole)) 7187c 7188c use diagonal preconditioner elements as first approximation 7189c 7190 polmin = 0.00000001d0 7191 do ii = 1, npole 7192 poli = udiag * max(polmin,polarity(ii)) 7193 do j = 1, 3 7194 zrsd(j,ii) = poli * rsd(j,ii) 7195 zrsdp(j,ii) = poli * rsdp(j,ii) 7196 zrsdt(j,ii) = 0.0d0 7197 zrsdtp(j,ii) = 0.0d0 7198 end do 7199 end do 7200c 7201c use the off-diagonal preconditioner elements in second phase 7202c 7203!$OMP PARALLEL default(private) shared(npole,mindex,minv,nulst,ulst, 7204!$OMP& rsd,rsdp,zrsd,zrsdp,zrsdt,zrsdtp) 7205!$OMP DO reduction(+:zrsdt,zrsdtp) schedule(guided) 7206 do ii = 1, npole 7207 m = mindex(ii) 7208 do kkk = 1, nulst(ii) 7209 kk = ulst(kkk,ii) 7210 m1 = minv(m+1) 7211 m2 = minv(m+2) 7212 m3 = minv(m+3) 7213 m4 = minv(m+4) 7214 m5 = minv(m+5) 7215 m6 = minv(m+6) 7216 m = m + 6 7217 zrsdt(1,ii) = zrsdt(1,ii) + m1*rsd(1,kk) 7218 & + m2*rsd(2,kk) + m3*rsd(3,kk) 7219 zrsdt(2,ii) = zrsdt(2,ii) + m2*rsd(1,kk) 7220 & + m4*rsd(2,kk) + m5*rsd(3,kk) 7221 zrsdt(3,ii) = zrsdt(3,ii) + m3*rsd(1,kk) 7222 & + m5*rsd(2,kk) + m6*rsd(3,kk) 7223 zrsdt(1,kk) = zrsdt(1,kk) + m1*rsd(1,ii) 7224 & + m2*rsd(2,ii) + m3*rsd(3,ii) 7225 zrsdt(2,kk) = zrsdt(2,kk) + m2*rsd(1,ii) 7226 & + m4*rsd(2,ii) + m5*rsd(3,ii) 7227 zrsdt(3,kk) = zrsdt(3,kk) + m3*rsd(1,ii) 7228 & + m5*rsd(2,ii) + m6*rsd(3,ii) 7229 zrsdtp(1,ii) = zrsdtp(1,ii) + m1*rsdp(1,kk) 7230 & + m2*rsdp(2,kk) + m3*rsdp(3,kk) 7231 zrsdtp(2,ii) = zrsdtp(2,ii) + m2*rsdp(1,kk) 7232 & + m4*rsdp(2,kk) + m5*rsdp(3,kk) 7233 zrsdtp(3,ii) = zrsdtp(3,ii) + m3*rsdp(1,kk) 7234 & + m5*rsdp(2,kk) + m6*rsdp(3,kk) 7235 zrsdtp(1,kk) = zrsdtp(1,kk) + m1*rsdp(1,ii) 7236 & + m2*rsdp(2,ii) + m3*rsdp(3,ii) 7237 zrsdtp(2,kk) = zrsdtp(2,kk) + m2*rsdp(1,ii) 7238 & + m4*rsdp(2,ii) + m5*rsdp(3,ii) 7239 zrsdtp(3,kk) = zrsdtp(3,kk) + m3*rsdp(1,ii) 7240 & + m5*rsdp(2,ii) + m6*rsdp(3,ii) 7241 end do 7242 end do 7243!$OMP END DO 7244c 7245c transfer the results from local to global arrays 7246c 7247!$OMP DO 7248 do ii = 1, npole 7249 do j = 1, 3 7250 zrsd(j,ii) = zrsd(j,ii) + zrsdt(j,ii) 7251 zrsdp(j,ii) = zrsdp(j,ii) + zrsdtp(j,ii) 7252 end do 7253 end do 7254!$OMP END DO 7255!$OMP END PARALLEL 7256c 7257c perform deallocation of some local arrays 7258c 7259 deallocate (zrsdt) 7260 deallocate (zrsdtp) 7261c 7262c build the off-diagonal elements of preconditioning matrix 7263c 7264 else if (mode .eq. 'BUILD') then 7265 m = 0 7266 do ii = 1, npole 7267 mindex(ii) = m 7268 m = m + 6*nulst(ii) 7269 end do 7270c 7271c perform dynamic allocation of some local arrays 7272c 7273 allocate (uscale(n)) 7274 allocate (wscale(n)) 7275c 7276c set array needed to scale connected atom interactions 7277c 7278 do i = 1, n 7279 uscale(i) = 1.0d0 7280 wscale(i) = 1.0d0 7281 end do 7282c 7283c OpenMP directives for the major loop structure 7284c 7285!$OMP PARALLEL default(private) shared(n,npole,ipole,x,y,z,polarity, 7286!$OMP& palpha,u1scale,u2scale,u3scale,u4scale,w2scale,w3scale,w4scale, 7287!$OMP& w5scale,n12,i12,n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12, 7288!$OMP& np13,ip13,np14,ip14,use_thole,use_chgpen,nulst,ulst,mindex,minv) 7289!$OMP& firstprivate (uscale,wscale) 7290c 7291c determine the off-diagonal elements of the preconditioner 7292c 7293!$OMP DO schedule(guided) 7294 do ii = 1, npole 7295 i = ipole(ii) 7296 xi = x(i) 7297 yi = y(i) 7298 zi = z(i) 7299 poli = polarity(ii) 7300 if (use_chgpen) alphai = palpha(ii) 7301c 7302c set exclusion coefficients for connected atoms 7303c 7304 do j = 1, np11(i) 7305 uscale(ip11(j,i)) = u1scale 7306 end do 7307 do j = 1, np12(i) 7308 uscale(ip12(j,i)) = u2scale 7309 end do 7310 do j = 1, np13(i) 7311 uscale(ip13(j,i)) = u3scale 7312 end do 7313 do j = 1, np14(i) 7314 uscale(ip14(j,i)) = u4scale 7315 end do 7316 do j = 1, n12(i) 7317 wscale(i12(j,i)) = w2scale 7318 end do 7319 do j = 1, n13(i) 7320 wscale(i13(j,i)) = w3scale 7321 end do 7322 do j = 1, n14(i) 7323 wscale(i14(j,i)) = w4scale 7324 end do 7325 do j = 1, n15(i) 7326 wscale(i15(j,i)) = w5scale 7327 end do 7328c 7329c evaluate all sites within the cutoff distance 7330c 7331 m = mindex(ii) 7332 do kkk = 1, nulst(ii) 7333 kk = ulst(kkk,ii) 7334 k = ipole(kk) 7335 xr = x(k) - xi 7336 yr = y(k) - yi 7337 zr = z(k) - zi 7338 call image (xr,yr,zr) 7339 r2 = xr*xr + yr* yr + zr*zr 7340 r = sqrt(r2) 7341 if (use_thole) then 7342 call dampthole2 (ii,kk,5,r,dmpik) 7343 dmpik(3) = uscale(k) * dmpik(3) 7344 dmpik(5) = uscale(k) * dmpik(5) 7345 else if (use_chgpen) then 7346 alphak = palpha(kk) 7347 call dampmut (r,alphai,alphak,dmpik) 7348 dmpik(3) = wscale(k) * dmpik(3) 7349 dmpik(5) = wscale(k) * dmpik(5) 7350 end if 7351 polik = poli * polarity(kk) 7352 rr3 = dmpik(3) * polik / (r*r2) 7353 rr5 = 3.0d0 * dmpik(5) * polik / (r*r2*r2) 7354 minv(m+1) = rr5*xr*xr - rr3 7355 minv(m+2) = rr5*xr*yr 7356 minv(m+3) = rr5*xr*zr 7357 minv(m+4) = rr5*yr*yr - rr3 7358 minv(m+5) = rr5*yr*zr 7359 minv(m+6) = rr5*zr*zr - rr3 7360 m = m + 6 7361 end do 7362c 7363c reset exclusion coefficients for connected atoms 7364c 7365 do j = 1, np11(i) 7366 uscale(ip11(j,i)) = 1.0d0 7367 end do 7368 do j = 1, np12(i) 7369 uscale(ip12(j,i)) = 1.0d0 7370 end do 7371 do j = 1, np13(i) 7372 uscale(ip13(j,i)) = 1.0d0 7373 end do 7374 do j = 1, np14(i) 7375 uscale(ip14(j,i)) = 1.0d0 7376 end do 7377 do j = 1, n12(i) 7378 wscale(i12(j,i)) = 1.0d0 7379 end do 7380 do j = 1, n13(i) 7381 wscale(i13(j,i)) = 1.0d0 7382 end do 7383 do j = 1, n14(i) 7384 wscale(i14(j,i)) = 1.0d0 7385 end do 7386 do j = 1, n15(i) 7387 wscale(i15(j,i)) = 1.0d0 7388 end do 7389 end do 7390!$OMP END DO 7391!$OMP END PARALLEL 7392c 7393c perform deallocation of some local arrays 7394c 7395 deallocate (uscale) 7396 deallocate (wscale) 7397 end if 7398 return 7399 end 7400