diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/0README_QMMM 6.2.06/source/0README_QMMM --- 6.2.06/source_orig/0README_QMMM 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/0README_QMMM 2013-11-30 10:24:44.206831059 +0100 @@ -0,0 +1,53 @@ +QM/MM readme +Nicolas Ferré, Aix-Marseille Université, France +Federico Melaccio, Siena Università, Italy +December 2013 + +4 types of atom: MM (qmmm = 0), HLA (qmmm = 1), QM (qmmm=2), Y (qmmm=3) +* HLA (Hydrogen Link Atom) does not have any connectivity, nor vdW parameters. +* Y (LSCF/MM mixed QM/MM Atom) carries Q_Y (QM-derived) + q_Y (MM ff) total charge. + +## Interaction rules ## +!! Not all the ff can be used together with QM/MM !! +!! Check the current status in subroutine qmmm_todo !! + +* The HLA only interacts electrostatically. Inherits 1-4 conditions from + the QM atom it is connected to +* Bond stretching: no QM-QM and QM-Y bonds. See bonds.f +* Angle bending: if at least one atom is MM or if there is a Y-Y bond. + See angles.f +* Stretch-bend coupling: exclude QM-QM-MM, QM-Y-MM, Y-QM-MM couplings +* Urey-Bradley: exclude QM-QM and QM-Y 1-3 interactions +* Angle-angle coupling: NYI +* Out of plane bending: if at least one atom is MM or if there is a Y-Y bond. + See kopbend.f +* Out of plane distance: if at least one atom is MM or if there is a Y-Y bond. + See kopdist.f +* Improper torsion: keep only if the central atom is MM or Y. See kimptor.f +* Improper dihedral: keep only if the central atom is MM or Y. See kimprop.f +* Torsion: automatically excluding torsions around QM-QM and QM-Y bonds. + See bonds.f and torsions.f + Includes a piece of code for accounting for torsions involving one MM atom, + eg. QM-QM-QM-MM. It certainly double-count some interactions, but it may + correct the force acting on the MM atom. +* Pi torsion coupling: nothing to do +* Stretch-torsion coupling: NYI +* Torsion-torsion coupling: NYI +* vdW: exclude QM-QM, but includes QM-(QM image) in case of PBC. +* Electrostatics: 2 modes, always excluding QM-QM. QM/MM electrostatics follow + (doespf .true.) or not (doespf .false.) the 1-4 conditions. DONE + !! Temporarily disabled: the potential varies too sharply !! + e4qmmm = 0: QM/MM energy/gradient => only MM/MM electrostatics in Tinker, + point charges or electrostatic potential passed to QMprog, + Y special case: includes interactions with q_MM + e4qmmm = 3: microiterations/MD => QM/MM electrostatics in Tinker, involving + at least one MM atom, nbinqm atoms frozen, + Y special case: includes interactions with Q_Y+q_Y + Warning: (MM2, MM3) bond dipoles along MM-MM, MM-Y or Y-Y bonds only. + !! Point charge/multipole interactions: + !! Now we use a substractive scheme : ec = ec(all) - ec(QM/anything) !! + !! - ec(HLA/anything) ... !! + !! where ec(all) includes all the interactions, computed by any approach, !! + !! include PME !! + + diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/active.f 6.2.06/source/active.f --- 6.2.06/source_orig/active.f 2013-07-14 04:23:53.000000000 +0200 +++ 6.2.06/source/active.f 2013-10-23 11:36:27.047130194 +0200 @@ -69,7 +69,7 @@ next = 1 record = keyline(j) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) c c get any lists of atoms whose coordinates are active diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/alchemy.f 6.2.06/source/alchemy.f --- 6.2.06/source_orig/alchemy.f 2013-07-14 04:23:53.000000000 +0200 +++ 6.2.06/source/alchemy.f 2013-10-23 11:36:27.047130194 +0200 @@ -160,7 +160,7 @@ 110 format (a120) next = 1 call gettext (record,answer,next) - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') dogeom = .false. if (dogeom) then write (iout,120) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/analyze.f 6.2.06/source/analyze.f --- 6.2.06/source_orig/analyze.f 2013-07-14 04:23:53.000000000 +0200 +++ 6.2.06/source/analyze.f 2013-10-23 11:36:27.047130194 +0200 @@ -81,7 +81,7 @@ dodetail = .false. doprops = .false. doconect = .false. - call upcase (string) + call tk_upcase (string) do i = 1, trimtext(string) letter = string(i:i) if (letter .eq. 'G') dosystem = .true. diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/angles.f 6.2.06/source/angles.f --- 6.2.06/source_orig/angles.f 2013-07-14 04:23:53.000000000 +0200 +++ 6.2.06/source/angles.f 2013-11-13 19:20:10.988019509 +0100 @@ -27,6 +27,9 @@ include 'couple.i' include 'iounit.i' integer i,j,k,m +cqmmm + include 'qmmm.i' + integer ijqmmm,ikqmmm c c c loop over all atoms, storing the atoms in each bond angle @@ -36,6 +39,11 @@ m = 0 do j = 1, n12(i)-1 do k = j+1, n12(i) +cqmmm + ijqmmm = qmmm(i) + qmmm(i12(j,i)) + ikqmmm = qmmm(i) + qmmm(i12(k,i)) + if (ijqmmm .ge. 4 .and. ijqmmm.le. 5 + & .and. ikqmmm .ge. 4 .and. ikqmmm .le. 5) goto 20 nangle = nangle + 1 if (nangle .gt. maxang) then write (iout,10) @@ -49,12 +57,15 @@ iang(2,nangle) = i iang(3,nangle) = i12(k,i) iang(4,nangle) = 0 +cqmmm + 20 continue end do end do c c set the out-of-plane atom for angles at trivalent centers c - if (n12(i) .eq. 3) then +cqmmm if (n12(i) .eq. 3) then + if (n12(i) .eq. 3 .and. mod(qmmm(i),3).eq.0) then iang(4,nangle) = i12(1,i) iang(4,nangle-1) = i12(2,i) iang(4,nangle-2) = i12(3,i) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/anneal.f 6.2.06/source/anneal.f --- 6.2.06/source_orig/anneal.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/anneal.f 2013-10-23 11:36:27.047130194 +0200 @@ -120,7 +120,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'S') cooltyp = 'SIGMOID' if (answer .eq. 'E') cooltyp = 'EXPONENT' c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/attach.f 6.2.06/source/attach.f --- 6.2.06/source_orig/attach.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/attach.f 2013-10-23 11:36:27.047130194 +0200 @@ -51,7 +51,7 @@ & ' Attached to Atom',i6) call fatal end if - call sort (n13(i),i13(1,i)) + call tk_sort (n13(i),i13(1,i)) end do c c loop over all atoms finding all the 1-4 relationships @@ -80,7 +80,7 @@ & ' Attached to Atom',i6) call fatal end if - call sort (n14(i),i14(1,i)) + call tk_sort (n14(i),i14(1,i)) end do c c loop over all atoms finding all the 1-5 relationships @@ -112,7 +112,7 @@ & ' Attached to Atom',i6) call fatal end if - call sort (n15(i),i15(1,i)) + call tk_sort (n15(i),i15(1,i)) end do return end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/bonds.f 6.2.06/source/bonds.f --- 6.2.06/source_orig/bonds.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/bonds.f 2013-10-21 18:20:56.541885301 +0200 @@ -25,6 +25,9 @@ include 'couple.i' include 'iounit.i' integer i,j,k,m +cqmmm + include 'qmmm.i' + integer jqmmm,kqmmm,mqmmm c c c loop over all atoms, storing the atoms in each bond @@ -34,6 +37,9 @@ do j = 1, n12(i) k = i12(j,i) if (i .lt. k) then +cqmmm + kqmmm = qmmm(i) + qmmm(k) + if (kqmmm .eq. 4 .or. kqmmm .eq. 5) goto 20 nbond = nbond + 1 if (nbond .gt. maxbnd) then write (iout,10) @@ -54,5 +60,35 @@ end if end do end do +c +cqmmm Control there are enough link atoms +c + do i = 1, nbond + j = ibnd(1,i) + k = ibnd(2,i) + jqmmm = qmmm(j) + kqmmm = qmmm(k) + if (jqmmm .eq.0 .and. kqmmm .eq.2) then + do m = 1, n + mqmmm = qmmm(m) + if (mqmmm .eq.1 .and. i12(1,m) .eq.j .and. i12(2,m).eq.k) + & goto 30 + end do + else if (jqmmm .eq.2 .and. kqmmm .eq.0) then + do m = 1, n + mqmmm = qmmm(m) + if (mqmmm .eq.1 .and. i12(1,m) .eq.k .and. i12(2,m).eq.j) + & goto 30 + end do + else + goto 30 + end if + write (iout,31) j,k + 31 format (/,' BONDS -- No LAH between MM atom ',i5, + & ' and QM atom ',i5) + 30 continue + end do +cqmmm + return end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/cluster.f 6.2.06/source/cluster.f --- 6.2.06/source_orig/cluster.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/cluster.f 2013-10-23 11:36:27.047130194 +0200 @@ -70,7 +70,7 @@ next = 1 record = keyline(j) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:6) .eq. 'GROUP ') then use_group = .true. gnum = 0 @@ -149,7 +149,7 @@ do i = 1, n list(i) = grplist(i) end do - call sort3 (n,list,kgrp) + call tk_sort3 (n,list,kgrp) c c find the first and last atom in each of the groups c @@ -171,7 +171,7 @@ do i = 0, ngrp size = igrp(2,i) - igrp(1,i) + 1 if (igrp(1,i) .ne. 0) - & call sort (size,kgrp(igrp(1,i))) + & call tk_sort (size,kgrp(igrp(1,i))) end do end if c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/command.f 6.2.06/source/command.f --- 6.2.06/source_orig/command.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/command.f 2013-10-23 11:36:27.047130194 +0200 @@ -51,7 +51,7 @@ letter = arg(i)(1:1) if (letter .eq. '-') then letter = arg(i)(2:2) - call upcase (letter) + call tk_upcase (letter) if (letter.ge.'A' .and. letter.le.'Z') then listarg(i) = .false. listarg(i+1) = .false. diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/connect.f 6.2.06/source/connect.f --- 6.2.06/source_orig/connect.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/connect.f 2013-10-23 11:36:27.047130194 +0200 @@ -64,7 +64,7 @@ c sort the attached atom lists into ascending order c do i = 1, n - call sort (n12(i),i12(1,i)) + call tk_sort (n12(i),i12(1,i)) end do return end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/connolly.f 6.2.06/source/connolly.f --- 6.2.06/source_orig/connolly.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/connolly.f 2013-10-23 11:36:27.047130194 +0200 @@ -134,7 +134,7 @@ call place call compress call saddles - call contact + call tk_contact call vam (volume,area) return end @@ -1646,17 +1646,17 @@ end c c -c ############################################################### -c ## ## -c ## subroutine contact -- builds exposed contact surfaces ## -c ## ## -c ############################################################### +c ################################################################## +c ## ## +c ## subroutine tk_contact -- builds exposed contact surfaces ## +c ## ## +c ################################################################## c c -c "contact" constructs the contact surface, cycles and convex faces +c "tk_contact" constructs the contact surface, cycles and convex faces c c - subroutine contact + subroutine tk_contact implicit none include 'sizes.i' include 'faces.i' diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/control.f 6.2.06/source/control.f --- 6.2.06/source_orig/control.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/control.f 2013-10-23 11:36:27.047130194 +0200 @@ -47,7 +47,7 @@ exist = .false. do i = 1, narg-1 string = arg(i) - call upcase (string) + call tk_upcase (string) if (string(1:2) .eq. '-V') then verbose = .true. else if (string(1:2) .eq. '-D') then @@ -62,7 +62,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'DIGITS ') then string = record(next:120) read (string,*,err=10) digits diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/crystal.f 6.2.06/source/crystal.f --- 6.2.06/source_orig/crystal.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/crystal.f 2013-10-23 11:36:27.051130195 +0200 @@ -265,7 +265,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') call molmerge end if c @@ -288,7 +288,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') then call field call katom @@ -311,7 +311,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') then do i = 1, n z(i) = (z(i)/gamma_term) / zbox @@ -514,7 +514,7 @@ c sort the connected atom lists into ascending order c do i = 1, n - call sort (n12(i),i12(1,i)) + call tk_sort (n12(i),i12(1,i)) end do return end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/cutoffs.f 6.2.06/source/cutoffs.f --- 6.2.06/source_orig/cutoffs.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/cutoffs.f 2013-10-23 11:36:27.051130195 +0200 @@ -83,7 +83,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) c c get values related to use of Ewald summation diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/distgeom.f 6.2.06/source/distgeom.f --- 6.2.06/source_orig/distgeom.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/distgeom.f 2013-10-23 11:36:27.051130195 +0200 @@ -176,7 +176,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .ne. 'N') then call nextarg (answer,exist) if (.not. exist) then @@ -188,7 +188,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) do i = 1, n if (n12(i) .eq. 4) then nhydro = 0 @@ -220,7 +220,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .ne. 'N') then do i = 1, n if (n12(i) .eq. 3) then @@ -245,7 +245,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .ne. 'N') then do i = 1, nbond ia = ibnd(1,i) @@ -281,7 +281,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') query = .true. c c choose the global enantiomer nearest to the original @@ -297,7 +297,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') use_invert = .true. c c set the type of refinement to be used after embedding @@ -313,7 +313,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'M') use_anneal = .false. c c initialize chirality and planarity restraint values diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/document.f 6.2.06/source/document.f --- 6.2.06/source_orig/document.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/document.f 2013-10-23 11:36:27.051130195 +0200 @@ -138,12 +138,12 @@ next = 10 call getword (record,module,next) call lowcase (module) - call upcase (module(1:1)) + call tk_upcase (module(1:1)) if (module.eq.'Subroutine' .or. module.eq.'Function' & .or. module.eq.'Program') then nunit = nunit + 1 call getword (record,routine(nunit),next) - call upcase (routine(nunit)) + call tk_upcase (routine(nunit)) leng = trimtext (routine(nunit)) routine(nunit) = routine(nunit)(1:leng)//' '//module read (isrc,80,err=100,end=100) @@ -169,7 +169,7 @@ end do 100 continue close (unit=isrc) - call sort7 (nunit,routine,link) + call tk_sort7 (nunit,routine,link) idoc = freeunit () docfile = 'routines.doc' call version (docfile,'new') @@ -228,7 +228,7 @@ do while (.true.) read (isrc,170,err=180,end=180) record 170 format (a120) - call upcase (record) + call tk_upcase (record) if (record(1:1) .ne. 'C') then next = 1 call getword (record,module,next) @@ -261,7 +261,7 @@ end do 180 continue close (unit=isrc) - call sort7 (nunit,routine,link) + call tk_sort7 (nunit,routine,link) idoc = freeunit () docfile = 'calls.doc' call version (docfile,'new') @@ -270,7 +270,7 @@ string = routine(i) leng = trimtext (string) j = link(i) - call sort10 (nline(j),info(1,j)) + call tk_sort10 (nline(j),info(1,j)) if (wiki) then field = string(1:leng) do k = 1, nline(j) @@ -309,7 +309,7 @@ if (next .ne. 0) then nunit = nunit + 1 leng = trimtext (record) - call upcase (record(11:next-1)) + call tk_upcase (record(11:next-1)) string = record(11:next-1) start = 20 if (wiki) start = trimtext(string) + 5 @@ -344,7 +344,7 @@ end do 260 continue close (unit=isrc) - call sort7 (nunit,routine,link) + call tk_sort7 (nunit,routine,link) idoc = freeunit () docfile = 'common.doc' call version (docfile,'new') @@ -400,7 +400,7 @@ if (next .ne. 0) then next = next + 1 call getword (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) nkey = nkey + 1 key(nkey) = keyword end if @@ -409,7 +409,7 @@ end do 340 continue close (unit=isrc) - call sort6 (nkey,key) + call tk_sort6 (nkey,key) keylast = ' ' idoc = freeunit () docfile = 'keyword.doc' @@ -447,7 +447,7 @@ end do 380 continue close (unit=isrc) - call sort6 (nkey,key) + call tk_sort6 (nkey,key) keylast = ' ' leng = index (srcfile,'.') field = srcfile(1:leng-1)//'.o:' diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/dynamic.f 6.2.06/source/dynamic.f --- 6.2.06/source_orig/dynamic.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/dynamic.f 2013-10-23 11:36:27.051130195 +0200 @@ -61,11 +61,11 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:11) .eq. 'INTEGRATOR ') then call getword (record,integrate,next) - call upcase (integrate) + call tk_upcase (integrate) end if end do c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/eangle2.f 6.2.06/source/eangle2.f --- 6.2.06/source_orig/eangle2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/eangle2.f 2013-10-21 18:20:56.209885316 +0200 @@ -35,6 +35,10 @@ real*8, allocatable :: d0(:,:) logical proceed logical twosided +cqmmm + include 'qmmm.i' + integer iaqmmm,ibqmmm,icqmmm + integer iabqmmm,ibcqmmm c c c compute analytical angle bending Hessian elements @@ -61,9 +65,18 @@ ib = iang(2,k) ic = iang(3,k) id = iang(4,k) +cqmmm + iaqmmm = qmmm(ia) + ibqmmm = qmmm(ib) + icqmmm = qmmm(ic) + iabqmmm = iaqmmm + ibqmmm + ibcqmmm = ibqmmm + icqmmm proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic .or. i.eq.id) if (proceed .and. use_group) & call groups (proceed,fgrp,ia,ib,ic,id,0,0) +cqmmm + if (proceed) proceed = (min(iabqmmm,ibcqmmm) .le. 3 + & .or. max(iabqmmm,ibcqmmm) .eq. 6) end if if (proceed) then term = fgrp / eps diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ebond2.f 6.2.06/source/ebond2.f --- 6.2.06/source_orig/ebond2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ebond2.f 2013-10-21 18:20:56.749885292 +0200 @@ -56,6 +56,8 @@ c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,0,0,0,0) +cqmmm + proceed = proceed .and. (ib .ne. 0) c c compute the value of the bond length deviation c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ebuck1.f 6.2.06/source/ebuck1.f --- 6.2.06/source_orig/ebuck1.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ebuck1.f 2013-10-21 18:20:56.497885303 +0200 @@ -112,6 +112,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -173,6 +176,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -198,6 +204,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -352,6 +362,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -377,6 +390,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -594,6 +610,9 @@ logical proceed,usei logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -670,6 +689,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -722,6 +744,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -948,6 +974,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -1009,6 +1038,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -1034,6 +1066,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ebuck2.f 6.2.06/source/ebuck2.f --- 6.2.06/source_orig/ebuck2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ebuck2.f 2013-10-21 18:20:56.433885306 +0200 @@ -96,6 +96,9 @@ real*8, allocatable :: vscale(:) logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c perform dynamic allocation of some local arrays @@ -163,6 +166,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -188,6 +193,11 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (k .ne. i) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1 + & .and. ikqmmm .ne. 4) c c compute the Hessian elements for this interaction c @@ -400,6 +410,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -424,6 +436,9 @@ kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1) c c compute the Hessian elements for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ebuck3.f 6.2.06/source/ebuck3.f --- 6.2.06/source_orig/ebuck3.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ebuck3.f 2013-10-21 18:20:56.425885307 +0200 @@ -118,6 +118,9 @@ logical proceed,usei logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -177,6 +180,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -202,6 +208,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -319,6 +329,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -344,6 +357,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -527,6 +543,9 @@ logical prime,repeat logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -601,6 +620,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -653,6 +675,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -851,6 +877,9 @@ logical proceed,usei logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -910,6 +939,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -935,6 +967,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ebuck.f 6.2.06/source/ebuck.f --- 6.2.06/source_orig/ebuck.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ebuck.f 2013-10-21 18:20:56.489885304 +0200 @@ -96,6 +96,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -150,6 +153,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -175,6 +181,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -261,6 +271,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -286,6 +299,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -428,6 +444,9 @@ logical proceed,usei logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -497,6 +516,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -549,6 +571,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -699,6 +725,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -753,6 +782,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -778,6 +810,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/echarge1.f 6.2.06/source/echarge1.f --- 6.2.06/source_orig/echarge1.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/echarge1.f 2013-11-26 18:25:31.894467289 +0100 @@ -21,6 +21,8 @@ include 'sizes.i' include 'cutoff.i' include 'warp.i' +cqmmm + include 'qmmm.i' c c c choose the method for summing over pairwise interactions @@ -42,6 +44,8 @@ else call echarge1a end if +cqmmm + if (nbinqm .ne. 0 .and. e4qmmm .eq. 0) call echarge1qmmm return end c @@ -97,6 +101,9 @@ real*8, allocatable :: cscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy and derivatives @@ -154,6 +161,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -274,6 +292,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -322,6 +344,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -448,6 +481,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -526,6 +563,9 @@ logical proceed,usei logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy and derivatives @@ -599,6 +639,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c loop over method of lights neighbors of current atom c @@ -770,6 +821,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -844,6 +899,9 @@ real*8, allocatable :: cscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy and derivatives @@ -901,6 +959,18 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nelst(ii) + jqmmm = mod(qmmm(iion(elst(j,ii))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) + & cscale(jion(elst(j,ii))) = 1.0d0 + if (ijqmmm .ne. 0) cscale(jion(elst(j,ii))) = + & cscale(jion(elst(j,ii))) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -1022,6 +1092,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(ii) + cscale(jion(elst(j,ii))) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1096,6 +1170,9 @@ logical proceed,usei character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the Ewald summation energy and derivatives @@ -1192,6 +1269,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -1274,6 +1362,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1318,6 +1410,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -1403,6 +1506,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1487,6 +1594,9 @@ logical prime,repeat character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the Ewald summation energy and derivatives @@ -1600,6 +1710,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c loop over method of lights neighbors of current atom c @@ -1733,6 +1854,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1818,6 +1943,9 @@ logical proceed,usei character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the Ewald summation energy and derivatives @@ -1944,6 +2072,18 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nelst(ii) + jqmmm = mod(qmmm(iion(elst(j,ii))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) + & cscale(jion(elst(j,ii))) = 1.0d0 + if (ijqmmm .ne. 0) cscale(jion(elst(j,ii))) = + & cscale(jion(elst(j,ii))) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -2027,6 +2167,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(ii) + cscale(jion(elst(j,ii))) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -2059,7 +2203,7 @@ vir(1,i) = virt(1,i) vir(2,i) = virt(2,i) vir(3,i) = virt(3,i) - end do + end do c c intermolecular energy is total minus intramolecular part c @@ -2117,6 +2261,9 @@ real*8, allocatable :: cscale(:) logical proceed,usei external erf +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy and derivatives @@ -2180,6 +2327,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -2279,6 +2437,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -2497,3 +2659,460 @@ end do return end +c +c +c ###################################################### +c ## ## +c ## subroutine echarge1qmmm -- QM/MM corrections ## +c ## ## +c ###################################################### +c +c +c "echarge1qmmm" corrects the charge-charge interaction energy +c using a pairwise double loop +c only MM-MM, MM-Y and Y-Y interactions must be excluded +c +c + subroutine echarge1qmmm + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'cell.i' + include 'charge.i' + include 'chgpot.i' + include 'couple.i' + include 'deriv.i' + include 'energi.i' + include 'group.i' + include 'inter.i' + include 'molcul.i' + include 'shunt.i' + include 'usage.i' + include 'virial.i' + integer i,j,k + integer ii,kk + integer in,kn + integer ic,kc + real*8 e,fgrp,de,dc + real*8 f,fi,fik + real*8 r,r2,rb,rb2 + real*8 xi,yi,zi + real*8 xr,yr,zr + real*8 xc,yc,zc + real*8 xic,yic,zic + real*8 dedx,dedy,dedz + real*8 dedxc,dedyc,dedzc + real*8 shift,taper,trans + real*8 dtaper,dtrans + real*8 rc,rc2,rc3,rc4 + real*8 rc5,rc6,rc7 + real*8 vxx,vyy,vzz + real*8 vyx,vzx,vzy + real*8, allocatable :: cscale(:) + logical proceed,usei + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm,kqmmm,ikqmmm +c +c +c + if (nion .eq. 0) return +c +c perform dynamic allocation of some local arrays +c + allocate (cscale(n)) +c +c set array needed to scale connected atom interactions +c + do i = 1, n + cscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = electric / dielec + mode = 'CHARGE' + call switch (mode) +c +c compute the charge interaction energy and first derivatives +c + do ii = 1, nion-1 + i = iion(ii) + in = jion(ii) + ic = kion(ii) + xic = x(ic) + yic = y(ic) + zic = z(ic) + xi = x(i) - xic + yi = y(i) - yic + zi = z(i) - zic + fi = f * pchg(ii) + usei = (use(i) .or. use(ic)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(in) + cscale(i12(j,in)) = c2scale + end do + do j = 1, n13(in) + cscale(i13(j,in)) = c3scale + end do + do j = 1, n14(in) + cscale(i14(j,in)) = c4scale + end do + do j = 1, n15(in) + cscale(i15(j,in)) = c5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do +c +c decide whether to compute the current interaction +c + do kk = ii+1, nion + k = iion(kk) + kn = jion(kk) + kc = kion(kk) +cqmmm + kqmmm = mod(qmmm(k),3) + ikqmmm = iqmmm + kqmmm + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + if (proceed) proceed = (usei .or. use(k) .or. use(kc)) + if (proceed) proceed = (ikqmmm .ne. 0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + xc = xic - x(kc) + yc = yic - y(kc) + zc = zic - z(kc) + if (use_bounds) call image (xc,yc,zc) + rc2 = xc*xc + yc*yc + zc*zc + if (rc2 .le. off2) then + xr = xc + xi - x(k) + x(kc) + yr = yc + yi - y(k) + y(kc) + zr = zc + zi - z(k) + z(kc) + r2 = xr*xr + yr*yr + zr*zr + r = sqrt(r2) + rb = r + ebuffer + rb2 = rb * rb + fik = fi * pchg(kk) * cscale(kn) + e = fik / rb + de = -fik / rb2 + dc = 0.0d0 +c +c use shifted energy switching if near the cutoff distance +c + shift = fik / (0.5d0*(off+cut)) + e = e - shift + if (rc2 .gt. cut2) then + rc = sqrt(rc2) + rc3 = rc2 * rc + rc4 = rc2 * rc2 + rc5 = rc2 * rc3 + rc6 = rc3 * rc3 + rc7 = rc3 * rc4 + taper = c5*rc5 + c4*rc4 + c3*rc3 + & + c2*rc2 + c1*rc + c0 + dtaper = 5.0d0*c5*rc4 + 4.0d0*c4*rc3 + & + 3.0d0*c3*rc2 + 2.0d0*c2*rc + c1 + trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4 + & + f3*rc3 + f2*rc2 + f1*rc + f0) + dtrans = fik * (7.0d0*f7*rc6 + 6.0d0*f6*rc5 + & + 5.0d0*f5*rc4 + 4.0d0*f4*rc3 + & + 3.0d0*f3*rc2 + 2.0d0*f2*rc + f1) + dc = (e*dtaper + dtrans) / rc + de = de * taper + e = e*taper + trans + end if +c +c scale the interaction based on its group membership +c + if (use_group) then + e = e * fgrp + de = de * fgrp + dc = dc * fgrp + end if +c +c form the chain rule terms for derivative expressions +c + de = de / r + dedx = de * xr + dedy = de * yr + dedz = de * zr + dedxc = dc * xc + dedyc = dc * yc + dedzc = dc * zc +c +c increment the overall energy and derivative expressions +c + ec = ec - e + dec(1,i) = dec(1,i) - dedx + dec(2,i) = dec(2,i) - dedy + dec(3,i) = dec(3,i) - dedz + dec(1,ic) = dec(1,ic) - dedxc + dec(2,ic) = dec(2,ic) - dedyc + dec(3,ic) = dec(3,ic) - dedzc + dec(1,k) = dec(1,k) + dedx + dec(2,k) = dec(2,k) + dedy + dec(3,k) = dec(3,k) + dedz + dec(1,kc) = dec(1,kc) + dedxc + dec(2,kc) = dec(2,kc) + dedyc + dec(3,kc) = dec(3,kc) + dedzc +c +c increment the internal virial tensor components +c + vxx = xr*dedx + xc*dedxc + vyx = yr*dedx + yc*dedxc + vzx = zr*dedx + zc*dedxc + vyy = yr*dedy + yc*dedyc + vzy = zr*dedy + zc*dedyc + vzz = zr*dedz + zc*dedzc + vir(1,1) = vir(1,1) - vxx + vir(2,1) = vir(2,1) - vyx + vir(3,1) = vir(3,1) - vzx + vir(1,2) = vir(1,2) - vyx + vir(2,2) = vir(2,2) - vyy + vir(3,2) = vir(3,2) - vzy + vir(1,3) = vir(1,3) - vzx + vir(2,3) = vir(2,3) - vzy + vir(3,3) = vir(3,3) - vzz +c +c increment the total intermolecular energy +c + if (molcule(i) .ne. molcule(k)) then + einter = einter - e + end if + end if + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do + do j = 1, n12(in) + cscale(i12(j,in)) = 1.0d0 + end do + do j = 1, n13(in) + cscale(i13(j,in)) = 1.0d0 + end do + do j = 1, n14(in) + cscale(i14(j,in)) = 1.0d0 + end do + do j = 1, n15(in) + cscale(i15(j,in)) = 1.0d0 + end do + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (.not. use_replica) return +c +c calculate interaction energy with other unit cells +c + do ii = 1, nion + i = iion(ii) + in = jion(ii) + ic = kion(ii) + usei = (use(i) .or. use(ic)) + xic = x(ic) + yic = y(ic) + zic = z(ic) + xi = x(i) - xic + yi = y(i) - yic + zi = z(i) - zic + fi = f * pchg(ii) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(in) + cscale(i12(j,in)) = c2scale + end do + do j = 1, n13(in) + cscale(i13(j,in)) = c3scale + end do + do j = 1, n14(in) + cscale(i14(j,in)) = c4scale + end do + do j = 1, n15(in) + cscale(i15(j,in)) = c5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + if (iqmmm .eq. 0) goto 99 + do j = ii, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do +c +c decide whether to compute the current interaction +c + do kk = ii, nion + k = iion(kk) + kn = jion(kk) + kc = kion(kk) + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + if (proceed) proceed = (usei .or. use(k) .or. use(kc)) +c +c compute the energy contribution for this interaction +c + if (proceed) then + do j = 1, ncell + xc = xic - x(kc) + yc = yic - y(kc) + zc = zic - z(kc) + call imager (xc,yc,zc,j) + rc2 = xc*xc + yc*yc + zc*zc + if (rc2 .le. off2) then + xr = xc + xi - x(k) + x(kc) + yr = yc + yi - y(k) + y(kc) + zr = zc + zi - z(k) + z(kc) + r2 = xr*xr + yr*yr + zr*zr + r = sqrt(r2) + rb = r + ebuffer + rb2 = rb * rb + fik = fi * pchg(kk) + if (use_polymer) then + if (r2 .le. polycut2) fik = fik * cscale(kn) + end if + e = fik / rb + de = -fik / rb2 + dc = 0.0d0 +c +c use shifted energy switching if near the cutoff distance +c + shift = fik / (0.5d0*(off+cut)) + e = e - shift + if (rc2 .gt. cut2) then + rc = sqrt(rc2) + rc3 = rc2 * rc + rc4 = rc2 * rc2 + rc5 = rc2 * rc3 + rc6 = rc3 * rc3 + rc7 = rc3 * rc4 + taper = c5*rc5 + c4*rc4 + c3*rc3 + & + c2*rc2 + c1*rc + c0 + dtaper = 5.0d0*c5*rc4 + 4.0d0*c4*rc3 + & + 3.0d0*c3*rc2 + 2.0d0*c2*rc + c1 + trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4 + & + f3*rc3 + f2*rc2 + f1*rc + f0) + dtrans = fik * (7.0d0*f7*rc6 + 6.0d0*f6*rc5 + & + 5.0d0*f5*rc4 + 4.0d0*f4*rc3 + & + 3.0d0*f3*rc2 + 2.0d0*f2*rc + f1) + dc = (e*dtaper + dtrans) / rc + de = de * taper + e = e*taper + trans + end if +c +c scale the interaction based on its group membership +c + if (use_group) then + e = e * fgrp + de = de * fgrp + dc = dc * fgrp + end if +c +c form the chain rule terms for derivative expressions +c + de = de / r + dedx = de * xr + dedy = de * yr + dedz = de * zr + dedxc = dc * xc + dedyc = dc * yc + dedzc = dc * zc +c +c increment the energy and gradient values +c + if (i .eq. k) e = 0.5d0 * e + ec = ec - e + dec(1,i) = dec(1,i) - dedx + dec(2,i) = dec(2,i) - dedy + dec(3,i) = dec(3,i) - dedz + dec(1,ic) = dec(1,ic) - dedxc + dec(2,ic) = dec(2,ic) - dedyc + dec(3,ic) = dec(3,ic) - dedzc + if (i .ne. k) then + dec(1,k) = dec(1,k) + dedx + dec(2,k) = dec(2,k) + dedy + dec(3,k) = dec(3,k) + dedz + dec(1,kc) = dec(1,kc) + dedxc + dec(2,kc) = dec(2,kc) + dedyc + dec(3,kc) = dec(3,kc) + dedzc + end if +c +c increment the internal virial tensor components +c + vxx = xr*dedx + xc*dedxc + vyx = yr*dedx + yc*dedxc + vzx = zr*dedx + zc*dedxc + vyy = yr*dedy + yc*dedyc + vzy = zr*dedy + zc*dedyc + vzz = zr*dedz + zc*dedzc + vir(1,1) = vir(1,1) - vxx + vir(2,1) = vir(2,1) - vyx + vir(3,1) = vir(3,1) - vzx + vir(1,2) = vir(1,2) - vyx + vir(2,2) = vir(2,2) - vyy + vir(3,2) = vir(3,2) - vzy + vir(1,3) = vir(1,3) - vzx + vir(2,3) = vir(2,3) - vzy + vir(3,3) = vir(3,3) - vzz +c +c increment the total intermolecular energy +c + einter = einter - e + end if + end do + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = ii, nion + cscale(jion(j)) = 1.0d0 + end do + do j = 1, n12(in) + cscale(i12(j,in)) = 1.0d0 + end do + do j = 1, n13(in) + cscale(i13(j,in)) = 1.0d0 + end do + do j = 1, n14(in) + cscale(i14(j,in)) = 1.0d0 + end do + do j = 1, n15(in) + cscale(i15(j,in)) = 1.0d0 + end do +cqmmm + 99 continue + end do +c +c perform deallocation of some local arrays +c + deallocate (cscale) + return + end + diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/echarge2.f 6.2.06/source/echarge2.f --- 6.2.06/source_orig/echarge2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/echarge2.f 2013-11-26 18:25:31.894467289 +0100 @@ -22,6 +22,8 @@ include 'cutoff.i' include 'warp.i' integer i +cqmmm + include 'qmmm.i' c c c choose the method for summing over pairwise interactions @@ -33,6 +35,8 @@ else call echarge2a (i) end if +cqmmm + if (nbinqm .ne. 0 .and. e4qmmm .eq. 0) call echarge2qmmm (i) return end c @@ -77,6 +81,9 @@ real*8, allocatable :: cscale(:) logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c first see if the atom of interest carries a charge @@ -118,6 +125,16 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(iion(j)) = 1.0d0 + if (ijqmmm .ne. 0) cscale(iion(j)) = cscale(iion(j))*qmmmscale + end do c c set cutoff distances and switching function coefficients c @@ -374,6 +391,9 @@ real*8, allocatable :: cscale(:) logical proceed external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c first see if the atom of interest carries a charge @@ -416,6 +436,16 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(iion(j)) = 1.0d0 + if (ijqmmm .ne. 0) cscale(iion(j)) = cscale(iion(j))*qmmmscale + end do c c calculate the real space Ewald interaction Hessian elements c @@ -610,6 +640,9 @@ real*8, allocatable :: cscale(:) logical proceed external erf +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c first see if the atom of interest carries a charge @@ -651,6 +684,16 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j)) = 1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = cscale(jion(j))*qmmmscale + end do c c set the smallest exponential terms to be calculated c @@ -777,3 +820,318 @@ deallocate (cscale) return end +c +c +c ###################################################### +c ## ## +c ## subroutine echarge2qmmm -- QM/MM corrections ## +c ## ## +c ###################################################### +c +c +c "echarge2qmmm" corrects the charge-charge interaction energy +c using a pairwise double loop +c only MM-MM, MM-Y and Y-Y interactions must be excluded +c +c + subroutine echarge2qmmm (i) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'cell.i' + include 'charge.i' + include 'chgpot.i' + include 'couple.i' + include 'group.i' + include 'hessn.i' + include 'shunt.i' + integer i,j,k,kk + integer in,kn,jcell + real*8 e,de,d2e + real*8 fi,fik,fgrp + real*8 d2edx,d2edy,d2edz + real*8 xi,yi,zi + real*8 xr,yr,zr + real*8 shift,taper,trans + real*8 dtaper,dtrans + real*8 d2taper,d2trans + real*8 r,rb,rb2 + real*8 r2,r3,r4 + real*8 r5,r6,r7 + real*8 term(3,3) + real*8, allocatable :: cscale(:) + logical proceed + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm,kqmmm,ikqmmm +c +c +c first see if the atom of interest carries a charge +c + do k = 1, nion + if (iion(k) .eq. i) then + fi = electric * pchg(k) / dielec + in = jion(k) + goto 10 + end if + end do + return + 10 continue +c +c store the coordinates of the atom of interest +c + xi = x(i) + yi = y(i) + zi = z(i) +c +c perform dynamic allocation of some local arrays +c + allocate (cscale(n)) +c +c set array needed to scale connected atom interactions +c + do j = 1, nion + cscale(iion(j)) = 1.0d0 + end do + do j = 1, n12(in) + cscale(i12(j,in)) = c2scale + end do + do j = 1, n13(in) + cscale(i13(j,in)) = c3scale + end do + do j = 1, n14(in) + cscale(i14(j,in)) = c4scale + end do + do j = 1, n15(in) + cscale(i15(j,in)) = c5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j)) = 1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = cscale(jion(j))*qmmmscale + end do +c +c set cutoff distances and switching function coefficients +c + mode = 'CHARGE' + call switch (mode) +c +c calculate the charge interaction energy Hessian elements +c + do kk = 1, nion + k = iion(kk) + kn = jion(kk) +cqmmm + kqmmm = mod(qmmm(k),3) + ikqmmm = iqmmm + kqmmm + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + if (proceed) proceed = (kn .ne. i) + if (proceed) proceed = (ikqmmm .ne. 0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + xr = xi - x(k) + yr = yi - y(k) + zr = zi - z(k) + if (use_bounds) call image (xr,yr,zr) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + rb = r + ebuffer + rb2 = rb * rb + fik = fi * pchg(kk) * cscale(kn) +c +c compute chain rule terms for Hessian matrix elements +c + de = -fik / rb2 + d2e = -2.0d0 * de/rb +c +c use shifted energy switching if near the cutoff distance +c + if (r2 .gt. cut2) then + e = fik / r + shift = fik / (0.5d0*(off+cut)) + e = e - shift + r3 = r2 * r + r4 = r2 * r2 + r5 = r2 * r3 + r6 = r3 * r3 + r7 = r3 * r4 + taper = c5*r5 + c4*r4 + c3*r3 + c2*r2 + c1*r + c0 + dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3 + & + 3.0d0*c3*r2 + 2.0d0*c2*r + c1 + d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2 + & + 6.0d0*c3*r + 2.0d0*c2 + trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4 + & + f3*r3 + f2*r2 + f1*r + f0) + dtrans = fik * (7.0d0*f7*r6 + 6.0d0*f6*r5 + & + 5.0d0*f5*r4 + 4.0d0*f4*r3 + & + 3.0d0*f3*r2 + 2.0d0*f2*r + f1) + d2trans = fik * (42.0d0*f7*r5 + 30.0d0*f6*r4 + & + 20.0d0*f5*r3 + 12.0d0*f4*r2 + & + 6.0d0*f3*r + 2.0d0*f2) + d2e = e*d2taper + 2.0d0*de*dtaper + & + d2e*taper + d2trans + de = e*dtaper + de*taper + dtrans + end if +c +c scale the interaction based on its group membership +c + if (use_group) then + de = de * fgrp + d2e = d2e * fgrp + end if +c +c form the individual Hessian element components +c + de = de / r + d2e = (d2e-de) / r2 + d2edx = d2e * xr + d2edy = d2e * yr + d2edz = d2e * zr + term(1,1) = d2edx*xr + de + term(1,2) = d2edx*yr + term(1,3) = d2edx*zr + term(2,1) = term(1,2) + term(2,2) = d2edy*yr + de + term(2,3) = d2edy*zr + term(3,1) = term(1,3) + term(3,2) = term(2,3) + term(3,3) = d2edz*zr + de +c +c increment diagonal and non-diagonal Hessian elements +c + do j = 1, 3 + hessx(j,i) = hessx(j,i) - term(1,j) + hessy(j,i) = hessy(j,i) - term(2,j) + hessz(j,i) = hessz(j,i) - term(3,j) + hessx(j,k) = hessx(j,k) + term(1,j) + hessy(j,k) = hessy(j,k) + term(2,j) + hessz(j,k) = hessz(j,k) + term(3,j) + end do + end if + end if + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (.not. use_replica) return +cqmmm + if (iqmmm .eq. 0) return + +c +c calculate interaction energy with other unit cells +c + do kk = 1, nion + k = iion(kk) + kn = jion(kk) + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + do jcell = 1, ncell + xr = xi - x(k) + yr = yi - y(k) + zr = zi - z(k) + call imager (xr,yr,zr,jcell) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + rb = r + ebuffer + rb2 = rb * rb + fik = fi * pchg(kk) + if (use_polymer) then + if (r2 .le. polycut2) fik = fik * cscale(kn) + end if +c +c compute chain rule terms for Hessian matrix elements +c + de = -fik / rb2 + d2e = -2.0d0 * de/rb +c +c use shifted energy switching if near the cutoff distance +c + if (r2 .gt. cut2) then + e = fik / r + shift = fik / (0.5d0*(off+cut)) + e = e - shift + r3 = r2 * r + r4 = r2 * r2 + r5 = r2 * r3 + r6 = r3 * r3 + r7 = r3 * r4 + taper = c5*r5 + c4*r4 + c3*r3 + c2*r2 + c1*r + c0 + dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3 + & + 3.0d0*c3*r2 + 2.0d0*c2*r + c1 + d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2 + & + 6.0d0*c3*r + 2.0d0*c2 + trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4 + & + f3*r3 + f2*r2 + f1*r + f0) + dtrans = fik * (7.0d0*f7*r6 + 6.0d0*f6*r5 + & + 5.0d0*f5*r4 + 4.0d0*f4*r3 + & + 3.0d0*f3*r2 + 2.0d0*f2*r + f1) + d2trans = fik * (42.0d0*f7*r5 + 30.0d0*f6*r4 + & + 20.0d0*f5*r3 + 12.0d0*f4*r2 + & + 6.0d0*f3*r + 2.0d0*f2) + d2e = e*d2taper + 2.0d0*de*dtaper + & + d2e*taper + d2trans + de = e*dtaper + de*taper + dtrans + end if +c +c scale the interaction based on its group membership +c + if (use_group) then + de = de * fgrp + d2e = d2e * fgrp + end if +c +c form the individual Hessian element components +c + de = de / r + d2e = (d2e-de) / r2 + d2edx = d2e * xr + d2edy = d2e * yr + d2edz = d2e * zr + term(1,1) = d2edx*xr + de + term(1,2) = d2edx*yr + term(1,3) = d2edx*zr + term(2,1) = term(1,2) + term(2,2) = d2edy*yr + de + term(2,3) = d2edy*zr + term(3,1) = term(1,3) + term(3,2) = term(2,3) + term(3,3) = d2edz*zr + de +c +c increment diagonal and non-diagonal Hessian elements +c + do j = 1, 3 + hessx(j,i) = hessx(j,i) - term(1,j) + hessy(j,i) = hessy(j,i) - term(2,j) + hessz(j,i) = hessz(j,i) - term(3,j) + hessx(j,k) = hessx(j,k) + term(1,j) + hessy(j,k) = hessy(j,k) + term(2,j) + hessz(j,k) = hessz(j,k) + term(3,j) + end do + end if + end do + end if + end do +c +c perform deallocation of some local arrays +c + deallocate (cscale) + return + end + diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/echarge3.f 6.2.06/source/echarge3.f --- 6.2.06/source_orig/echarge3.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/echarge3.f 2013-11-26 18:25:31.894467289 +0100 @@ -21,6 +21,8 @@ include 'sizes.i' include 'cutoff.i' include 'warp.i' +cqmmm + include 'qmmm.i' c c c choose the method for summing over pairwise interactions @@ -42,6 +44,8 @@ else call echarge3a end if +cqmmm + if (nbinqm .ne. 0 .and. e4qmmm .eq. 0) call echarge3qmmm return end c @@ -96,6 +100,9 @@ logical proceed,usei logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy and partitioning @@ -153,6 +160,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -242,6 +260,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -290,6 +312,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -383,6 +416,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -461,6 +498,9 @@ logical prime,repeat logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy and partitioning @@ -534,6 +574,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c loop over method of lights neighbors of current atom c @@ -685,6 +736,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -759,6 +814,9 @@ logical proceed,usei logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy and partitioning @@ -816,6 +874,18 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nelst(ii) + jqmmm = mod(qmmm(iion(elst(j,ii))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) + & cscale(jion(elst(j,ii))) = 1.0d0 + if (ijqmmm .ne. 0) cscale(jion(elst(j,ii))) = + & cscale(jion(elst(j,ii))) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -906,6 +976,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(ii) + cscale(jion(elst(j,ii))) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -980,6 +1054,9 @@ logical header,huge character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the Ewald summation energy and partitioning @@ -1065,6 +1142,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -1135,6 +1223,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1183,6 +1275,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -1253,6 +1356,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1333,6 +1440,9 @@ logical header,huge character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the Ewald summation energy and partitioning @@ -1435,6 +1545,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c loop over method of lights neighbors of current atom c @@ -1563,6 +1684,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1647,6 +1772,9 @@ logical header,huge character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the Ewald summation energy and partitioning @@ -1752,6 +1880,18 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nelst(ii) + jqmmm = mod(qmmm(iion(elst(j,ii))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) + & cscale(jion(elst(j,ii))) = 1.0d0 + if (ijqmmm .ne. 0) cscale(jion(elst(j,ii))) = + & cscale(jion(elst(j,ii))) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -1823,6 +1963,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(ii) + cscale(jion(elst(j,ii))) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1907,6 +2051,9 @@ logical proceed,usei logical header,huge external erf +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy and partitioning @@ -1969,6 +2116,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -2053,6 +2211,400 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do + do j = 1, n12(in) + cscale(i12(j,in)) = 1.0d0 + end do + do j = 1, n13(in) + cscale(i13(j,in)) = 1.0d0 + end do + do j = 1, n14(in) + cscale(i14(j,in)) = 1.0d0 + end do + do j = 1, n15(in) + cscale(i15(j,in)) = 1.0d0 + end do + end do +c +c perform deallocation of some local arrays +c + deallocate (cscale) + return + end +c +c +c ###################################################### +c ## ## +c ## subroutine echarge3qmmm -- QM/MM corrections ## +c ## ## +c ###################################################### +c +c +c "echarge3qmmm" corrects the charge-charge interaction energy +c using a pairwise double loop +c only MM-MM, MM-Y and Y-Y interactions must be excluded +c +c + subroutine echarge3qmmm + implicit none + include 'sizes.i' + include 'action.i' + include 'analyz.i' + include 'atmtyp.i' + include 'atoms.i' + include 'bound.i' + include 'cell.i' + include 'charge.i' + include 'chgpot.i' + include 'couple.i' + include 'energi.i' + include 'group.i' + include 'inform.i' + include 'inter.i' + include 'iounit.i' + include 'molcul.i' + include 'shunt.i' + include 'usage.i' + integer i,j,k + integer ii,kk + integer in,kn + integer ic,kc + real*8 e,fgrp + real*8 r,r2,rb + real*8 f,fi,fik + real*8 xi,yi,zi + real*8 xr,yr,zr + real*8 xc,yc,zc + real*8 xic,yic,zic + real*8 shift,taper,trans + real*8 rc,rc2,rc3,rc4 + real*8 rc5,rc6,rc7 + real*8, allocatable :: cscale(:) + logical proceed,usei + logical header,huge + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm,kqmmm,ikqmmm +c +c +c + if (nion .eq. 0) return + header = .true. +c +c perform dynamic allocation of some local arrays +c + allocate (cscale(n)) +c +c set array needed to scale connected atom interactions +c + do i = 1, n + cscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = electric / dielec + mode = 'CHARGE' + call switch (mode) +c +c compute and partition the charge interaction energy +c + do ii = 1, nion-1 + i = iion(ii) + in = jion(ii) + ic = kion(ii) + xic = x(ic) + yic = y(ic) + zic = z(ic) + xi = x(i) - xic + yi = y(i) - yic + zi = z(i) - zic + fi = f * pchg(ii) + usei = (use(i) .or. use(ic)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(in) + cscale(i12(j,in)) = c2scale + end do + do j = 1, n13(in) + cscale(i13(j,in)) = c3scale + end do + do j = 1, n14(in) + cscale(i14(j,in)) = c4scale + end do + do j = 1, n15(in) + cscale(i15(j,in)) = c5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do +c +c decide whether to compute the current interaction +c + do kk = ii+1, nion + k = iion(kk) + kn = jion(kk) + kc = kion(kk) +cqmmm + kqmmm = mod(qmmm(k),3) + ikqmmm = iqmmm + kqmmm + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + if (proceed) proceed = (usei .or. use(k) .or. use(kc)) + if (proceed) proceed = (cscale(kn) .ne. 0.0d0) + if (proceed) proceed = (ikqmmm .ne. 0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + xc = xic - x(kc) + yc = yic - y(kc) + zc = zic - z(kc) + if (use_bounds) call image (xc,yc,zc) + rc2 = xc*xc + yc*yc + zc*zc + if (rc2 .le. off2) then + xr = xc + xi - x(k) + x(kc) + yr = yc + yi - y(k) + y(kc) + zr = zc + zi - z(k) + z(kc) + r2 = xr*xr + yr*yr + zr*zr + r = sqrt(r2) + rb = r + ebuffer + fik = fi * pchg(kk) * cscale(kn) + e = fik / rb +c +c use shifted energy switching if near the cutoff distance +c + shift = fik / (0.5d0*(off+cut)) + e = e - shift + if (rc2 .gt. cut2) then + rc = sqrt(rc2) + rc3 = rc2 * rc + rc4 = rc2 * rc2 + rc5 = rc2 * rc3 + rc6 = rc3 * rc3 + rc7 = rc3 * rc4 + taper = c5*rc5 + c4*rc4 + c3*rc3 + & + c2*rc2 + c1*rc + c0 + trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4 + & + f3*rc3 + f2*rc2 + f1*rc + f0) + e = e*taper + trans + end if +c +c scale the interaction based on its group membership +c + if (use_group) e = e * fgrp +c +c increment the overall charge-charge energy component +c + nec = nec - 1 + ec = ec - e + aec(i) = aec(i) - 0.5d0*e + aec(k) = aec(k) - 0.5d0*e +c +c increment the total intermolecular energy +c + if (molcule(i) .ne. molcule(k)) then + einter = einter - e + end if +c +c print a message if the energy of this interaction is large +c + huge = (abs(e) .gt. 100.0d0) + if (debug .or. (verbose.and.huge)) then + if (header) then + header = .false. + write (iout,10) + 10 format (/,' Removing Individual Charge-Charge', + & ' Interactions :', + & //,' Type',14x,'Atom Names', + & 17x,'Charges',5x,'Distance', + & 6x,'Energy',/) + end if + write (iout,20) i,name(i),k,name(k), + & pchg(ii),pchg(kk),r,e + 20 format (' Charge',4x,2(i7,'-',a3),8x, + & 2f7.2,f11.4,f12.4) + end if + end if + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do + do j = 1, n12(in) + cscale(i12(j,in)) = 1.0d0 + end do + do j = 1, n13(in) + cscale(i13(j,in)) = 1.0d0 + end do + do j = 1, n14(in) + cscale(i14(j,in)) = 1.0d0 + end do + do j = 1, n15(in) + cscale(i15(j,in)) = 1.0d0 + end do + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (.not. use_replica) return +c +c calculate interaction energy with other unit cells +c + do ii = 1, nion + i = iion(ii) + in = jion(ii) + ic = kion(ii) + usei = (use(i) .or. use(ic)) + xic = x(ic) + yic = y(ic) + zic = z(ic) + xi = x(i) - xic + yi = y(i) - yic + zi = z(i) - zic + fi = f * pchg(ii) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(in) + cscale(i12(j,in)) = c2scale + end do + do j = 1, n13(in) + cscale(i13(j,in)) = c3scale + end do + do j = 1, n14(in) + cscale(i14(j,in)) = c4scale + end do + do j = 1, n15(in) + cscale(i15(j,in)) = c5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + if (iqmmm .eq. 0) goto 99 + do j = ii, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do +c +c decide whether to compute the current interaction +c + do kk = ii, nion + k = iion(kk) + kn = jion(kk) + kc = kion(kk) + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + if (proceed) proceed = (usei .or. use(k) .or. use(kc)) +c +c compute the energy contribution for this interaction +c + if (proceed) then + do j = 1, ncell + xc = xic - x(kc) + yc = yic - y(kc) + zc = zic - z(kc) + call imager (xc,yc,zc,j) + rc2 = xc*xc + yc*yc + zc*zc + if (rc2 .le. off2) then + xr = xc + xi - x(k) + x(kc) + yr = yc + yi - y(k) + y(kc) + zr = zc + zi - z(k) + z(kc) + r2 = xr*xr + yr*yr + zr*zr + r = sqrt(r2) + rb = r + ebuffer + fik = fi * pchg(kk) + if (use_polymer) then + if (r2 .le. polycut2) fik = fik * cscale(kn) + end if + e = fik / rb +c +c use shifted energy switching if near the cutoff distance +c + shift = fik / (0.5d0*(off+cut)) + e = e - shift + if (rc2 .gt. cut2) then + rc = sqrt(rc2) + rc3 = rc2 * rc + rc4 = rc2 * rc2 + rc5 = rc2 * rc3 + rc6 = rc3 * rc3 + rc7 = rc3 * rc4 + taper = c5*rc5 + c4*rc4 + c3*rc3 + & + c2*rc2 + c1*rc + c0 + trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4 + & + f3*rc3 + f2*rc2 + f1*rc + f0) + e = e*taper + trans + end if +c +c scale the interaction based on its group membership +c + if (use_group) e = e * fgrp +c +c increment the overall charge-charge energy component +c + if (i .eq. k) e = 0.5d0 * e + if (e .ne. 0.0d0) nec = nec - 1 + ec = ec - e + aec(i) = aec(i) - 0.5d0*e + aec(k) = aec(k) - 0.5d0*e +c +c increment the total intermolecular energy +c + einter = einter - e +c +c print a message if the energy of this interaction is large +c + huge = (abs(e) .gt. 100.0d0) + if ((debug.and.e.ne.0.0d0) + & .or. (verbose.and.huge)) then + if (header) then + header = .false. + write (iout,30) + 30 format (/,' Removing Individual', + & ' Charge-Charge Interactions :', + & //,' Type',14x,'Atom Names', + & 17x,'Charges',5x,'Distance', + & 6x,'Energy',/) + end if + write (iout,40) i,name(i),k,name(k), + & pchg(ii),pchg(kk),r,e + 40 format (' Charge',4x,2(i7,'-',a3),1x, + & '(XTAL)',1x,2f7.2,f11.4,f12.4) + end if + end if + end do + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = ii, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -2065,6 +2617,8 @@ do j = 1, n15(in) cscale(i15(j,in)) = 1.0d0 end do +cqmmm + 99 continue end do c c perform deallocation of some local arrays @@ -2072,3 +2626,4 @@ deallocate (cscale) return end + diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/echarge.f 6.2.06/source/echarge.f --- 6.2.06/source_orig/echarge.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/echarge.f 2013-11-26 18:25:31.894467289 +0100 @@ -20,6 +20,8 @@ include 'sizes.i' include 'cutoff.i' include 'warp.i' +cqmmm + include 'qmmm.i' c c c choose the method for summing over pairwise interactions @@ -41,6 +43,8 @@ else call echarge0a end if +cqmmm + if (nbinqm .ne. 0 .and. e4qmmm .eq. 0) call echarge0qmmm return end c @@ -86,6 +90,9 @@ real*8, allocatable :: cscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy @@ -138,6 +145,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -198,6 +216,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -246,6 +268,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -312,6 +345,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -381,6 +418,9 @@ logical proceed,usei logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy @@ -449,6 +489,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c loop over method of lights neighbors of current atom c @@ -560,6 +611,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -624,6 +679,9 @@ real*8, allocatable :: cscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy @@ -676,6 +734,18 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nelst(ii) + jqmmm = mod(qmmm(iion(elst(j,ii))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) + & cscale(jion(elst(j,ii))) = 1.0d0 + if (ijqmmm .ne. 0) cscale(iion(elst(j,ii))) = + & cscale(jion(elst(j,ii))) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -737,6 +807,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(ii) + cscale(jion(elst(j,ii))) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -800,6 +874,9 @@ logical proceed,usei character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the Ewald charge interaction energy @@ -876,6 +953,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -914,6 +1002,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -958,6 +1050,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -1005,6 +1108,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1074,6 +1181,9 @@ logical prime,repeat character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the Ewald charge interaction energy @@ -1167,6 +1277,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) + & = cscale(jion(j)) * qmmmscale + end do c c loop over method of lights neighbors of current atom c @@ -1256,6 +1377,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1323,6 +1448,9 @@ logical proceed,usei character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the Ewald charge interaction energy @@ -1412,6 +1540,18 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = 1, nelst(ii) + jqmmm = mod(qmmm(iion(elst(j,ii))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) + & cscale(jion(elst(j,ii))) = 1.0d0 + if (ijqmmm .ne. 0) cscale(jion(elst(j,ii))) = + & cscale(jion(elst(j,ii))) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -1451,6 +1591,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(ii) + cscale(jion(elst(j,ii))) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1516,6 +1660,9 @@ real*8, allocatable :: cscale(:) logical proceed,usei external erf +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the charge interaction energy @@ -1573,6 +1720,17 @@ do j = 1, n15(in) cscale(i15(j,in)) = c5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do c c decide whether to compute the current interaction c @@ -1628,6 +1786,10 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do do j = 1, n12(in) cscale(i12(j,in)) = 1.0d0 end do @@ -1767,3 +1929,331 @@ end if return end +cqmmm +c +c ##################################################### +c ## ## +c ## subroutine echarge0qmmm -- QM/MM corrections ## +c ## ## +c ##################################################### +c +c +c "echarge0qmmm" corrects the charge-charge interaction energy +c using a pairwise double loop +c only MM-MM, MM-Y and Y-Y interactions must be retained +c +c + subroutine echarge0qmmm + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'cell.i' + include 'charge.i' + include 'chgpot.i' + include 'couple.i' + include 'energi.i' + include 'group.i' + include 'shunt.i' + include 'usage.i' + integer i,j,k + integer ii,kk + integer in,kn + integer ic,kc + real*8 e,fgrp + real*8 r,r2,rb + real*8 f,fi,fik + real*8 xi,yi,zi + real*8 xr,yr,zr + real*8 xc,yc,zc + real*8 xic,yic,zic + real*8 shift,taper,trans + real*8 rc,rc2,rc3,rc4 + real*8 rc5,rc6,rc7 + real*8, allocatable :: cscale(:) + logical proceed,usei + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm,kqmmm,ikqmmm +c +c +c + if (nion .eq. 0) return +c +c perform dynamic allocation of some local arrays +c + allocate (cscale(n)) +c +c set array needed to scale connected atom interactions +c + do i = 1, n + cscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = electric / dielec + mode = 'CHARGE' + call switch (mode) +c +c calculate the charge interaction energy term +c + do ii = 1, nion-1 + i = iion(ii) + in = jion(ii) + ic = kion(ii) + xic = x(ic) + yic = y(ic) + zic = z(ic) + xi = x(i) - xic + yi = y(i) - yic + zi = z(i) - zic + fi = f * pchg(ii) + usei = (use(i) .or. use(ic)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(in) + cscale(i12(j,in)) = c2scale + end do + do j = 1, n13(in) + cscale(i13(j,in)) = c3scale + end do + do j = 1, n14(in) + cscale(i14(j,in)) = c4scale + end do + do j = 1, n15(in) + cscale(i15(j,in)) = c5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + do j = ii+1, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do +c +c decide whether to compute the current interaction +c + do kk = ii+1, nion + k = iion(kk) + kn = jion(kk) + kc = kion(kk) +cqmmm + kqmmm = mod(qmmm(k),3) + ikqmmm = iqmmm + kqmmm + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + if (proceed) proceed = (usei .or. use(k) .or. use(kc)) + if (proceed) proceed = (ikqmmm .ne. 0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + xc = xic - x(kc) + yc = yic - y(kc) + zc = zic - z(kc) + if (use_bounds) call image (xc,yc,zc) + rc2 = xc*xc + yc*yc + zc*zc + if (rc2 .le. off2) then + xr = xc + xi - x(k) + x(kc) + yr = yc + yi - y(k) + y(kc) + zr = zc + zi - z(k) + z(kc) + r2 = xr*xr + yr*yr + zr*zr + r = sqrt(r2) + rb = r + ebuffer + fik = fi * pchg(kk) * cscale(kn) + e = fik / rb +c +c use shifted energy switching if near the cutoff distance +c + shift = fik / (0.5d0*(off+cut)) + e = e - shift + if (rc2 .gt. cut2) then + rc = sqrt(rc2) + rc3 = rc2 * rc + rc4 = rc2 * rc2 + rc5 = rc2 * rc3 + rc6 = rc3 * rc3 + rc7 = rc3 * rc4 + taper = c5*rc5 + c4*rc4 + c3*rc3 + & + c2*rc2 + c1*rc + c0 + trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4 + & + f3*rc3 + f2*rc2 + f1*rc + f0) + e = e*taper + trans + end if +c +c scale the interaction based on its group membership +c + if (use_group) e = e * fgrp +c +c decrement the overall charge-charge energy component +c + ec = ec - e + end if + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = ii+1, nion + cscale(jion(j)) = 1.0d0 + end do + do j = 1, n12(in) + cscale(i12(j,in)) = 1.0d0 + end do + do j = 1, n13(in) + cscale(i13(j,in)) = 1.0d0 + end do + do j = 1, n14(in) + cscale(i14(j,in)) = 1.0d0 + end do + do j = 1, n15(in) + cscale(i15(j,in)) = 1.0d0 + end do + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (.not. use_replica) return +c +c calculate interaction energy with other unit cells +c + do ii = 1, nion + i = iion(ii) + in = jion(ii) + ic = kion(ii) + usei = (use(i) .or. use(ic)) + xic = x(ic) + yic = y(ic) + zic = z(ic) + xi = x(i) - xic + yi = y(i) - yic + zi = z(i) - zic + fi = f * pchg(ii) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(in) + cscale(i12(j,in)) = c2scale + end do + do j = 1, n13(in) + cscale(i13(j,in)) = c3scale + end do + do j = 1, n14(in) + cscale(i14(j,in)) = c4scale + end do + do j = 1, n15(in) + cscale(i15(j,in)) = c5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(i),3) + if (iqmmm .eq. 0) goto 99 + do j = ii, nion + jqmmm = mod(qmmm(iion(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) cscale(jion(j))=1.0d0 + if (ijqmmm .ne. 0) cscale(jion(j)) = + & cscale(jion(j)) * qmmmscale + end do +c +c decide whether to compute the current interaction +c + do kk = ii, nion + k = iion(kk) + kn = jion(kk) + kc = kion(kk) + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + if (proceed) proceed = (usei .or. use(k) .or. use(kc)) +c +c compute the energy contribution for this interaction +c + if (proceed) then + do j = 1, ncell + xc = xic - x(kc) + yc = yic - y(kc) + zc = zic - z(kc) + call imager (xc,yc,zc,j) + rc2 = xc*xc + yc*yc + zc*zc + if (rc2 .le. off2) then + xr = xc + xi - x(k) + x(kc) + yr = yc + yi - y(k) + y(kc) + zr = zc + zi - z(k) + z(kc) + r2 = xr*xr + yr*yr + zr*zr + r = sqrt(r2) + rb = r + ebuffer + fik = fi * pchg(kk) + if (use_polymer) then + if (r2 .le. polycut2) fik = fik * cscale(kn) + end if + e = fik / rb +c +c use shifted energy switching if near the cutoff distance +c + shift = fik / (0.5d0*(off+cut)) + e = e - shift + if (rc2 .gt. cut2) then + rc = sqrt(rc2) + rc3 = rc2 * rc + rc4 = rc2 * rc2 + rc5 = rc2 * rc3 + rc6 = rc3 * rc3 + rc7 = rc3 * rc4 + taper = c5*rc5 + c4*rc4 + c3*rc3 + & + c2*rc2 + c1*rc + c0 + trans = fik * (f7*rc7 + f6*rc6 + f5*rc5 + f4*rc4 + & + f3*rc3 + f2*rc2 + f1*rc + f0) + e = e*taper + trans + end if +c +c scale the interaction based on its group membership +c + if (use_group) e = e * fgrp +c +c increment the overall charge-charge energy component +c + if (i .eq. k) e = 0.5d0 * e + ec = ec - e + end if + end do + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = ii, nion + cscale(jion(j)) = 1.0d0 + end do + do j = 1, n12(in) + cscale(i12(j,in)) = 1.0d0 + end do + do j = 1, n13(in) + cscale(i13(j,in)) = 1.0d0 + end do + do j = 1, n14(in) + cscale(i14(j,in)) = 1.0d0 + end do + do j = 1, n15(in) + cscale(i15(j,in)) = 1.0d0 + end do +cqmmm + 99 continue + end do +c +c perform deallocation of some local arrays +c + deallocate (cscale) + return + end + diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/echgdpl1.f 6.2.06/source/echgdpl1.f --- 6.2.06/source_orig/echgdpl1.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/echgdpl1.f 2013-10-21 18:20:56.517885303 +0200 @@ -58,6 +58,9 @@ real*8 vyx,vzx,vzy logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm c c c zero out the overall charge-dipole interaction energy @@ -99,6 +102,8 @@ yi = y(i1) zi = z(i1) fi = f * pchg(i) +cqmmm + iqmmm = mod(qmmm(i),3) c c decide whether to compute the current interaction c @@ -110,6 +115,8 @@ if (proceed) proceed = (use(i1) .or. use(k1) .or. use(k2)) if (proceed) proceed = (skip(k1).ne.i1 .and. & skip(k2).ne.i1) +cqmmm + if (proceed) proceed = (iqmmm .le. e4qmmm) c c compute the energy contribution for this interaction c @@ -253,6 +260,8 @@ yi = y(i1) zi = z(i1) fi = f * pchg(i) +cqmmm + iqmmm = mod(qmmm(i),3) c c decide whether to compute the current interaction c @@ -262,6 +271,8 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i1,k1,k2,0,0,0) if (proceed) proceed = (use(i1) .or. use(k1) .or. use(k2)) +cqmmm + if (proceed) proceed = (iqmmm .le. e4qmmm) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/echgdpl2.f 6.2.06/source/echgdpl2.f --- 6.2.06/source_orig/echgdpl2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/echgdpl2.f 2013-10-21 18:20:56.677885295 +0200 @@ -78,6 +78,9 @@ real*8 d2taperxz,d2taperyz logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm c c c check for the presence of both charges and dipoles @@ -115,6 +118,8 @@ yi = y(i1) zi = z(i1) fi = f * pchg(ii) +cqmmm + iqmmm = mod(qmmm(i),3) c c decide whether to compute the current interaction c @@ -125,6 +130,8 @@ if (use_group) call groups (proceed,fgrp,i1,k1,k2,0,0,0) if (proceed) proceed = (skip(k1).ne.i1 .and. & skip(k2).ne.i1) +cqmmm + if (proceed) proceed = (iqmmm .le. e4qmmm) c c compute the energy contribution for this interaction c @@ -384,6 +391,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i1,k1,k2,0,0,0) if (proceed) proceed = (omit(i1) .ne. k) +cqmmm + iqmmm = mod(qmmm(i1),3) + if (proceed) proceed = (iqmmm .le. e4qmmm) c c compute the energy contribution for this interaction c @@ -774,6 +784,8 @@ yi = y(i1) zi = z(i1) fi = f * pchg(ii) +cqmmm + iqmmm = mod(qmmm(i),3) c c decide whether to compute the current interaction c @@ -782,6 +794,8 @@ k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,k1,k2,0,0,0) +cqmmm + if (proceed) proceed = (iqmmm .le. e4qmmm) c c compute the energy contribution for this interaction c @@ -1048,6 +1062,9 @@ i1 = iion(ii) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,k1,k2,0,0,0) +cqmmm + iqmmm = mod(qmmm(i1),3) + if (proceed) proceed = (iqmmm .le. e4qmmm) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/echgdpl3.f 6.2.06/source/echgdpl3.f --- 6.2.06/source_orig/echgdpl3.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/echgdpl3.f 2013-10-21 18:20:56.437885306 +0200 @@ -51,6 +51,9 @@ logical proceed logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm c c c zero out the overall charge-dipole interaction energy @@ -92,6 +95,8 @@ yi = y(i1) zi = z(i1) fi = f * pchg(i) +cqmmm + iqmmm = mod(qmmm(i),3) c c decide whether to compute the current interaction c @@ -103,6 +108,8 @@ if (proceed) proceed = (use(i1) .or. use(k1) .or. use(k2)) if (proceed) proceed = (skip(k1).ne.i1 .and. & skip(k2).ne.i1) +cqmmm + if (proceed) proceed = (iqmmm .le. e4qmmm) c c compute the energy contribution for this interaction c @@ -191,6 +198,8 @@ yi = y(i1) zi = z(i1) fi = f * pchg(i) +cqmmm + iqmmm = mod(qmmm(i),3) c c decide whether to compute the current interaction c @@ -200,6 +209,8 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i1,k1,k2,0,0,0) if (proceed) proceed = (use(i1) .or. use(k1) .or. use(k2)) +cqmmm + if (proceed) proceed = (iqmmm .le. e4qmmm) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/echgdpl.f 6.2.06/source/echgdpl.f --- 6.2.06/source_orig/echgdpl.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/echgdpl.f 2013-10-21 18:20:56.273885313 +0200 @@ -42,6 +42,9 @@ real*8 r,r2,r3,r4,r5 logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm c c c zero out the overall charge-dipole interaction energy @@ -77,6 +80,8 @@ yi = y(i1) zi = z(i1) fi = f * pchg(i) +cqmmm + iqmmm = mod(qmmm(i),3) c c decide whether to compute the current interaction c @@ -88,6 +93,8 @@ if (proceed) proceed = (use(i1) .or. use(k1) .or. use(k2)) if (proceed) proceed = (skip(k1).ne.i1 .and. & skip(k2).ne.i1) +cqmmm + if (proceed) proceed = (iqmmm .le. e4qmmm) c c compute the energy contribution for this interaction c @@ -148,6 +155,8 @@ yi = y(i1) zi = z(i1) fi = f * pchg(i) +cqmmm + iqmmm = mod(qmmm(i),3) c c decide whether to compute the current interaction c @@ -157,6 +166,8 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i1,k1,k2,0,0,0) if (proceed) proceed = (use(i1) .or. use(k1) .or. use(k2)) +cqmmm + if (proceed) proceed = (iqmmm .le. e4qmmm) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/egauss1.f 6.2.06/source/egauss1.f --- 6.2.06/source_orig/egauss1.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/egauss1.f 2013-10-21 18:20:56.453885305 +0200 @@ -94,6 +94,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -149,6 +152,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -174,6 +180,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -329,6 +339,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -354,6 +367,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -574,6 +590,9 @@ logical proceed,usei logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -644,6 +663,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -696,6 +718,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -924,6 +950,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -979,6 +1008,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -1004,6 +1036,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -1208,6 +1244,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei external erf +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -1269,6 +1308,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -1294,6 +1336,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/egauss2.f 6.2.06/source/egauss2.f --- 6.2.06/source_orig/egauss2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/egauss2.f 2013-10-21 18:20:56.561885301 +0200 @@ -88,6 +88,9 @@ real*8 term(3,3) logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c perform dynamic allocation of some local arrays @@ -149,6 +152,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -174,6 +179,11 @@ proceed = (k .ne. i) if (proceed .and. use_group) & call groups (proceed,fgrp,i,k,0,0,0,0) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1 + & .and. ikqmmm .ne. 4) c c compute the Hessian elements for this interaction c @@ -368,6 +378,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -392,6 +404,9 @@ kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1) c c compute the Hessian elements for this interaction c @@ -652,6 +667,9 @@ real*8, allocatable :: vscale(:) real*8 term(3,3) logical proceed +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c perform dynamic allocation of some local arrays @@ -719,6 +737,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -744,6 +764,11 @@ proceed = (k .ne. i) if (proceed .and. use_group) & call groups (proceed,fgrp,i,k,0,0,0,0) +cqmmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1 + & .and. ikqmmm .ne. 4) c c compute the Hessian elements for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/egauss3.f 6.2.06/source/egauss3.f --- 6.2.06/source_orig/egauss3.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/egauss3.f 2013-10-21 18:20:56.349885310 +0200 @@ -90,6 +90,9 @@ logical proceed,usei logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -143,6 +146,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -168,6 +174,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -283,6 +293,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -308,6 +321,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -492,6 +508,9 @@ logical prime,repeat logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -560,6 +579,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -612,6 +634,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -811,6 +837,9 @@ logical proceed,usei logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -864,6 +893,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -889,6 +921,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -1052,6 +1088,9 @@ logical proceed,usei logical header,huge external erf +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -1111,6 +1150,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) do j = ii+1, nvdw vscale(ivdw(j)) = 1.0d0 end do @@ -1137,6 +1179,10 @@ if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) if (proceed) proceed = (vscale(k) .ne. 0.0d0) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/egauss.f 6.2.06/source/egauss.f --- 6.2.06/source_orig/egauss.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/egauss.f 2013-10-23 11:36:27.051130195 +0200 @@ -81,6 +81,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -129,6 +132,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -154,6 +160,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -240,6 +250,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -265,6 +278,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -407,6 +423,9 @@ logical proceed,usei logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -470,6 +489,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -522,6 +544,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -672,6 +698,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -720,6 +749,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -745,6 +777,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -870,6 +906,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei external erf +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -924,6 +963,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -949,6 +991,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ehal1.f 6.2.06/source/ehal1.f --- 6.2.06/source_orig/ehal1.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ehal1.f 2013-10-21 18:20:56.721885293 +0200 @@ -108,6 +108,9 @@ logical proceed,usei logical muti,mutk character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -163,6 +166,9 @@ zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -189,6 +195,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -361,6 +371,9 @@ zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -387,6 +400,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -628,6 +644,9 @@ logical muti,mutk logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -698,6 +717,9 @@ zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -751,6 +773,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -1003,6 +1029,9 @@ logical proceed,usei logical muti,mutk character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -1084,6 +1113,9 @@ zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -1110,6 +1142,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ehal2.f 6.2.06/source/ehal2.f --- 6.2.06/source_orig/ehal2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ehal2.f 2013-10-21 18:20:56.725885293 +0200 @@ -58,6 +58,9 @@ real*8, allocatable :: vscale(:) logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c perform dynamic allocation of some local arrays @@ -118,6 +121,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -143,6 +148,11 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (k .ne. i) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1 + & .and. ikqmmm .ne. 4) c c compute the Hessian elements for this interaction c @@ -351,6 +361,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -375,6 +387,9 @@ kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1) c c compute the Hessian elements for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ehal3.f 6.2.06/source/ehal3.f --- 6.2.06/source_orig/ehal3.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ehal3.f 2013-10-21 18:20:56.745885292 +0200 @@ -111,6 +111,9 @@ logical muti,mutk logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -164,6 +167,9 @@ zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -190,6 +196,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -318,6 +328,9 @@ zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -344,6 +357,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -538,6 +554,9 @@ logical prime,repeat logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -606,6 +625,9 @@ zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -659,6 +681,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -870,6 +896,9 @@ logical muti,mutk logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -945,6 +974,9 @@ zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -971,6 +1003,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ehal.f 6.2.06/source/ehal.f --- 6.2.06/source_orig/ehal.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ehal.f 2013-10-21 18:20:56.597885299 +0200 @@ -88,6 +88,9 @@ logical proceed,usei logical muti,mutk character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -136,6 +139,9 @@ zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -162,6 +168,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -257,6 +267,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -283,6 +296,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -435,6 +451,9 @@ logical muti,mutk logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -498,6 +517,9 @@ zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -551,6 +573,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -711,6 +737,9 @@ logical proceed,usei logical muti,mutk character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -773,6 +802,9 @@ zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -799,6 +831,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/elecpol0.f 6.2.06/source/elecpol0.f --- 6.2.06/source_orig/elecpol0.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/elecpol0.f 2013-10-21 18:20:56.521885302 +0200 @@ -0,0 +1,8189 @@ +cqmmm +c "elecpol0" calculates the electrostatic potential (in e/A) +c and field (in e/A^2) on site i (either HLA, QM or Y) +c due to all MM permanent and induced multipoles +c ** in the case of ESPF at order 0 ** +c +c + subroutine elecpol0(i,QMMM_EP) + implicit none + include 'sizes.i' + include 'cutoff.i' + include 'deriv.i' + include 'energi.i' + include 'mpole.i' + include 'potent.i' + integer i + real*8 QMMM_EP(6) +c +c +c choose the method for summing over multipole interactions +c + if (use_ewald) then + if (use_mlist) then + call elecpol0d + else + call elecpol0c + end if + else + if (use_mlist) then + call elecpol0b + else + call elecpol0a + end if + end if + return + end +c +c +c "elecpola" calculates elecpot using a pairwise double loop +c +c + subroutine elecpol0a (i,QMMM_EP) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'boxes.i' + include 'cell.i' + include 'chgpot.i' + include 'couple.i' + include 'cutoff.i' + include 'deriv.i' + include 'energi.i' + include 'group.i' + include 'inter.i' + include 'molcul.i' + include 'mplpot.i' + include 'mpole.i' + include 'polar.i' + include 'polgrp.i' + include 'polpot.i' + include 'shunt.i' + include 'usage.i' + include 'virial.i' + integer i,j,k + integer ii,kk,jcell + integer ix,iy,iz + integer kx,ky,kz + integer iax,iay,iaz + integer kax,kay,kaz + real*8 e,ei,f,fgrp,gfd + real*8 damp,expdamp + real*8 pdi,pti,pgamma + real*8 scale3,scale3i + real*8 scale5,scale5i + real*8 scale7,scale7i + real*8 temp3,temp5,temp7 + real*8 psc3,psc5,psc7 + real*8 dsc3,dsc5,dsc7 + real*8 xr,yr,zr + real*8 xix,yix,zix + real*8 xiy,yiy,ziy + real*8 xiz,yiz,ziz + real*8 xkx,ykx,zkx + real*8 xky,yky,zky + real*8 xkz,ykz,zkz + real*8 r,r2,rr1,rr3 + real*8 rr5,rr7,rr9,rr11 + real*8 vxx,vyy,vzz + real*8 vyx,vzx,vzy + real*8 ci,di(3),qi(9) + real*8 ck,dk(3),qk(9) + real*8 frcxi(3),frcxk(3) + real*8 frcyi(3),frcyk(3) + real*8 frczi(3),frczk(3) + real*8 fridmp(3),findmp(3) + real*8 ftm2(3),ftm2i(3) + real*8 ttm2(3),ttm3(3) + real*8 ttm2i(3),ttm3i(3) + real*8 dixdk(3),fdir(3) + real*8 dixuk(3),dkxui(3) + real*8 dixukp(3),dkxuip(3) + real*8 uixqkr(3),ukxqir(3) + real*8 uixqkrp(3),ukxqirp(3) + real*8 qiuk(3),qkui(3) + real*8 qiukp(3),qkuip(3) + real*8 rxqiuk(3),rxqkui(3) + real*8 rxqiukp(3),rxqkuip(3) + real*8 qidk(3),qkdi(3) + real*8 qir(3),qkr(3) + real*8 qiqkr(3),qkqir(3) + real*8 qixqk(3),rxqir(3) + real*8 dixr(3),dkxr(3) + real*8 dixqkr(3),dkxqir(3) + real*8 rxqkr(3),qkrxqir(3) + real*8 rxqikr(3),rxqkir(3) + real*8 rxqidk(3),rxqkdi(3) + real*8 ddsc3(3),ddsc5(3) + real*8 ddsc7(3) + real*8 gl(0:8),gli(7),glip(7) + real*8 sc(10),sci(8),scip(8) + real*8 gf(7),gfi(6),gti(6) + real*8, allocatable :: mscale(:) + real*8, allocatable :: pscale(:) + real*8, allocatable :: dscale(:) + real*8, allocatable :: uscale(:) + logical proceed,usei,usek + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm +c +c +c initialization +c + do k = 1, 6 + QMMM_EP(k) = 0.0d0 + end do +c +c the 3 following calls are avoided, already done +c during energy and gradient calculations +c +c check the sign of multipole components at chiral sites +c +c call chkpole +c +c rotate the multipole components into the global frame +c +c call rotpole +c +c compute the induced dipoles at each polarizable atom +c +c call induce +c +c perform dynamic allocation of some local arrays +c + allocate (mscale(n)) + allocate (pscale(n)) + allocate (dscale(n)) + allocate (uscale(n)) +c +c set arrays needed to scale connected atom interactions +c + if (npole .eq. 0) return + do i = 1, n + mscale(i) = 1.0d0 + pscale(i) = 1.0d0 + dscale(i) = 1.0d0 + uscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = 1.0d0 / dielec + mode = 'MPOLE' + call switch (mode) +c +c set scale factors for permanent multipole and induced terms +c + do i = 1, npole-1 + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + do k = 1, np11(ii) + if (i14(j,ii) .eq. ip11(k,ii)) + & pscale(i14(j,ii)) = p4scale * p41scale + end do + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do + do k = i+1, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) + proceed = .true. + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + if (.not. use_intra) proceed = .true. + if (proceed) proceed = (usei .or. usek) + if (.not. proceed) goto 10 + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + if (use_bounds) call image (xr,yr,zr) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + scale3i = scale3 * uscale(kk) + scale5i = scale5 * uscale(kk) + scale7i = scale7 * uscale(kk) + dsc3 = scale3 * dscale(kk) + dsc5 = scale5 * dscale(kk) + dsc7 = scale7 * dscale(kk) + psc3 = scale3 * pscale(kk) + psc5 = scale5 * pscale(kk) + psc7 = scale7 * pscale(kk) +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c compute the energy contributions for this interaction +c + e = rr1*gl(0) + rr3*(gl(1)+gl(6)) + & + rr5*(gl(2)+gl(7)+gl(8)) + & + rr7*(gl(3)+gl(5)) + rr9*gl(4) + ei = 0.5d0*(rr3*(gli(1)+gli(6))*psc3 + & + rr5*(gli(2)+gli(7))*psc5 + & + rr7*gli(3)*psc7) + e = f * mscale(kk) * e + ei = f * ei + em = em + e + ep = ep + ei +c +c increment the total intermolecular energy +c + if (molcule(ii) .ne. molcule(kk)) then + einter = einter + e + ei + end if +c +c intermediate variables for the permanent components +c + gf(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gf(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gf(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gf(4) = 2.0d0 * rr5 + gf(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gf(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gf(7) = 4.0d0 * rr7 +c +c intermediate variables for the induced components +c + gfi(1) = 0.5d0 * rr5 * ((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*scale3i) + & + 0.5d0 * rr7 * ((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*scale5i) + & + 0.5d0 * rr9 * (gli(3)*psc7+glip(3)*dsc7) + gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfi(4) = 2.0d0 * rr5 + gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) +c +c get the permanent force components +c + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the induced force components +c + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify induced force for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (rr5*scip(2)*scale3i + & - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i) + temp5 = 0.5d0 * rr5 * scale5i + fdir(1) = gfd*xr + temp5 + & * (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfd*yr + temp5 + & * (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfd*zr + temp5 + & * (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3) + end if +c +c intermediate terms for induced torque on multipoles +c + gti(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gti(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) +c +c get the permanent torque components +c + ttm2(1) = -rr3*dixdk(1) + gf(2)*dixr(1) - gf(5)*rxqir(1) + & + gf(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -rr3*dixdk(2) + gf(2)*dixr(2) - gf(5)*rxqir(2) + & + gf(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -rr3*dixdk(3) + gf(2)*dixr(3) - gf(5)*rxqir(3) + & + gf(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = rr3*dixdk(1) + gf(3)*dkxr(1) - gf(6)*rxqkr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = rr3*dixdk(2) + gf(3)*dkxr(2) - gf(6)*rxqkr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = rr3*dixdk(3) + gf(3)*dkxr(3) - gf(6)*rxqkr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the induced torque components +c + ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1) + ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2) + ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3) + ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1) + ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2) + ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3) +c +c handle the case where scaling is used +c + do j = 1, 3 + ftm2(j) = f * ftm2(j) * mscale(kk) + ftm2i(j) = f * ftm2i(j) + ttm2(j) = f * ttm2(j) * mscale(kk) + ttm2i(j) = f * ttm2i(j) + ttm3(j) = f * ttm3(j) * mscale(kk) + ttm3i(j) = f * ttm3i(j) + end do +c +c increment gradient due to force and torque on first site +c + dem(1,ii) = dem(1,ii) + ftm2(1) + dem(2,ii) = dem(2,ii) + ftm2(2) + dem(3,ii) = dem(3,ii) + ftm2(3) + dep(1,ii) = dep(1,ii) + ftm2i(1) + dep(2,ii) = dep(2,ii) + ftm2i(2) + dep(3,ii) = dep(3,ii) + ftm2i(3) + call torque (i,ttm2,ttm2i,frcxi,frcyi,frczi) +c +c increment gradient due to force and torque on second site +c + dem(1,kk) = dem(1,kk) - ftm2(1) + dem(2,kk) = dem(2,kk) - ftm2(2) + dem(3,kk) = dem(3,kk) - ftm2(3) + dep(1,kk) = dep(1,kk) - ftm2i(1) + dep(2,kk) = dep(2,kk) - ftm2i(2) + dep(3,kk) = dep(3,kk) - ftm2i(3) + call torque (k,ttm3,ttm3i,frcxk,frcyk,frczk) +c +c increment the internal virial tensor components +c + iaz = iz + iax = ix + iay = iy + kaz = kz + kax = kx + kay = ky + if (iaz .eq. 0) iaz = ii + if (iax .eq. 0) iax = ii + if (iay .eq. 0) iay = ii + if (kaz .eq. 0) kaz = kk + if (kax .eq. 0) kax = kk + if (kay .eq. 0) kay = kk + xiz = x(iaz) - x(ii) + yiz = y(iaz) - y(ii) + ziz = z(iaz) - z(ii) + xix = x(iax) - x(ii) + yix = y(iax) - y(ii) + zix = z(iax) - z(ii) + xiy = x(iay) - x(ii) + yiy = y(iay) - y(ii) + ziy = z(iay) - z(ii) + xkz = x(kaz) - x(kk) + ykz = y(kaz) - y(kk) + zkz = z(kaz) - z(kk) + xkx = x(kax) - x(kk) + ykx = y(kax) - y(kk) + zkx = z(kax) - z(kk) + xky = x(kay) - x(kk) + yky = y(kay) - y(kk) + zky = z(kay) - z(kk) + vxx = -xr*(ftm2(1)+ftm2i(1)) + xix*frcxi(1) + & + xiy*frcyi(1) + xiz*frczi(1) + xkx*frcxk(1) + & + xky*frcyk(1) + xkz*frczk(1) + vyx = -yr*(ftm2(1)+ftm2i(1)) + yix*frcxi(1) + & + yiy*frcyi(1) + yiz*frczi(1) + ykx*frcxk(1) + & + yky*frcyk(1) + ykz*frczk(1) + vzx = -zr*(ftm2(1)+ftm2i(1)) + zix*frcxi(1) + & + ziy*frcyi(1) + ziz*frczi(1) + zkx*frcxk(1) + & + zky*frcyk(1) + zkz*frczk(1) + vyy = -yr*(ftm2(2)+ftm2i(2)) + yix*frcxi(2) + & + yiy*frcyi(2) + yiz*frczi(2) + ykx*frcxk(2) + & + yky*frcyk(2) + ykz*frczk(2) + vzy = -zr*(ftm2(2)+ftm2i(2)) + zix*frcxi(2) + & + ziy*frcyi(2) + ziz*frczi(2) + zkx*frcxk(2) + & + zky*frcyk(2) + zkz*frczk(2) + vzz = -zr*(ftm2(3)+ftm2i(3)) + zix*frcxi(3) + & + ziy*frcyi(3) + ziz*frczi(3) + zkx*frcxk(3) + & + zky*frcyk(3) + zkz*frczk(3) + vir(1,1) = vir(1,1) + vxx + vir(2,1) = vir(2,1) + vyx + vir(3,1) = vir(3,1) + vzx + vir(1,2) = vir(1,2) + vyx + vir(2,2) = vir(2,2) + vyy + vir(3,2) = vir(3,2) + vzy + vir(1,3) = vir(1,3) + vzx + vir(2,3) = vir(2,3) + vzy + vir(3,3) = vir(3,3) + vzz + end if + 10 continue + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (use_replica) then +c +c calculate interaction with other unit cells +c + do i = 1, npole + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do + do k = i, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + proceed = .true. + if (proceed) proceed = (usei .or. usek) + if (.not. proceed) goto 20 + do jcell = 1, ncell + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + call imager (xr,yr,zr,jcell) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + scale3i = scale3 + scale5i = scale5 + scale7i = scale7 + dsc3 = scale3 + dsc5 = scale5 + dsc7 = scale7 + psc3 = scale3 + psc5 = scale5 + psc7 = scale7 + if (use_polymer) then + if (r2 .le. polycut2) then + scale3i = scale3i * uscale(kk) + scale5i = scale5i * uscale(kk) + scale7i = scale7i * uscale(kk) + dsc3 = dsc3 * dscale(kk) + dsc5 = dsc5 * dscale(kk) + dsc7 = dsc7 * dscale(kk) + psc3 = psc3 * pscale(kk) + psc5 = psc5 * pscale(kk) + psc7 = psc7 * pscale(kk) + end if + end if +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c compute the energy contributions for this interaction +c + e = rr1*gl(0) + rr3*(gl(1)+gl(6)) + & + rr5*(gl(2)+gl(7)+gl(8)) + & + rr7*(gl(3)+gl(5)) + rr9*gl(4) + ei = 0.5d0*(rr3*(gli(1)+gli(6))*psc3 + & + rr5*(gli(2)+gli(7))*psc5 + & + rr7*gli(3)*psc7) + e = f * e + ei = f * ei + if (use_polymer) then + if (r2 .le. polycut2) then + e = e * mscale(kk) + end if + end if + if (use_group) then + e = e * fgrp +c ei = ei * fgrp + end if + if (ii .eq. kk) then + e = 0.5d0 * e + ei = 0.5d0 * ei + end if + em = em + e + ep = ep + ei +c +c increment the total intermolecular energy +c + if (molcule(ii) .ne. molcule(kk)) then + einter = einter + e + ei + end if +c +c intermediate variables for the permanent components +c + gf(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gf(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gf(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gf(4) = 2.0d0 * rr5 + gf(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gf(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gf(7) = 4.0d0 * rr7 +c +c intermediate variables for the induced components +c + gfi(1) = 0.5d0 * rr5 * ((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*scale3i) + & + 0.5d0 * rr7 * ((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*scale5i) + & + 0.5d0 * rr9 * (gli(3)*psc7+glip(3)*dsc7) + gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfi(4) = 2.0d0 * rr5 + gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) +c +c get the permanent force components +c + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the induced force components +c + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify induced force for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (rr5*scip(2)*scale3i + & - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i) + temp5 = 0.5d0 * rr5 * scale5i + fdir(1) = gfd*xr + temp5 + & * (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfd*yr + temp5 + & * (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfd*zr + temp5 + & * (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3) + end if +c +c intermediate terms for induced torque on multipoles +c + gti(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gti(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) +c +c get the permanent torque components +c + ttm2(1) = -rr3*dixdk(1) + gf(2)*dixr(1) - gf(5)*rxqir(1) + & + gf(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -rr3*dixdk(2) + gf(2)*dixr(2) - gf(5)*rxqir(2) + & + gf(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -rr3*dixdk(3) + gf(2)*dixr(3) - gf(5)*rxqir(3) + & + gf(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = rr3*dixdk(1) + gf(3)*dkxr(1) - gf(6)*rxqkr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = rr3*dixdk(2) + gf(3)*dkxr(2) - gf(6)*rxqkr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = rr3*dixdk(3) + gf(3)*dkxr(3) - gf(6)*rxqkr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the induced torque components +c + ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1) + ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2) + ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3) + ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1) + ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2) + ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3) +c +c handle the case where scaling is used +c + do j = 1, 3 + ftm2(j) = f * ftm2(j) + ftm2i(j) = f * ftm2i(j) + ttm2(j) = f * ttm2(j) + ttm2i(j) = f * ttm2i(j) + ttm3(j) = f * ttm3(j) + ttm3i(j) = f * ttm3i(j) + end do + if (use_polymer) then + if (r2 .le. polycut2) then + do j = 1, 3 + ftm2(j) = ftm2(j) * mscale(kk) + ttm2(j) = ttm2(j) * mscale(kk) + ttm3(j) = ttm3(j) * mscale(kk) + end do + end if + end if + if (use_group) then + do j = 1, 3 + ftm2(j) = ftm2(j) * fgrp + ttm2(j) = ttm2(j) * fgrp + ttm3(j) = ttm3(j) * fgrp +c ftm2i(j) = ftm2i(j) * fgrp +c ttm2i(j) = ttm2i(j) * fgrp +c ttm3i(j) = ttm3i(j) * fgrp + end do + end if + if (ii .eq. kk) then + do j = 1, 3 + ftm2(j) = 0.5d0 * ftm2(j) + ftm2i(j) = 0.5d0 * ftm2i(j) + ttm2(j) = 0.5d0 * ttm2(j) + ttm2i(j) = 0.5d0 * ttm2i(j) + ttm3(j) = 0.5d0 * ttm3(j) + ttm3i(j) = 0.5d0 * ttm3i(j) + end do + end if +c +c increment gradient due to force and torque on first site +c + dem(1,ii) = dem(1,ii) + ftm2(1) + dem(2,ii) = dem(2,ii) + ftm2(2) + dem(3,ii) = dem(3,ii) + ftm2(3) + dep(1,ii) = dep(1,ii) + ftm2i(1) + dep(2,ii) = dep(2,ii) + ftm2i(2) + dep(3,ii) = dep(3,ii) + ftm2i(3) + call torque (i,ttm2,ttm2i,frcxi,frcyi,frczi) +c +c increment gradient due to force and torque on second site +c + dem(1,kk) = dem(1,kk) - ftm2(1) + dem(2,kk) = dem(2,kk) - ftm2(2) + dem(3,kk) = dem(3,kk) - ftm2(3) + dep(1,kk) = dep(1,kk) - ftm2i(1) + dep(2,kk) = dep(2,kk) - ftm2i(2) + dep(3,kk) = dep(3,kk) - ftm2i(3) + call torque (k,ttm3,ttm3i,frcxk,frcyk,frczk) +c +c increment the internal virial tensor components +c + iaz = iz + iax = ix + iay = iy + kaz = kz + kax = kx + kay = ky + if (iaz .eq. 0) iaz = ii + if (iax .eq. 0) iax = ii + if (iay .eq. 0) iay = ii + if (kaz .eq. 0) kaz = kk + if (kax .eq. 0) kax = kk + if (kay .eq. 0) kay = kk + xiz = x(iaz) - x(ii) + yiz = y(iaz) - y(ii) + ziz = z(iaz) - z(ii) + xix = x(iax) - x(ii) + yix = y(iax) - y(ii) + zix = z(iax) - z(ii) + xiy = x(iay) - x(ii) + yiy = y(iay) - y(ii) + ziy = z(iay) - z(ii) + xkz = x(kaz) - x(kk) + ykz = y(kaz) - y(kk) + zkz = z(kaz) - z(kk) + xkx = x(kax) - x(kk) + ykx = y(kax) - y(kk) + zkx = z(kax) - z(kk) + xky = x(kay) - x(kk) + yky = y(kay) - y(kk) + zky = z(kay) - z(kk) + vxx = -xr*(ftm2(1)+ftm2i(1)) + xix*frcxi(1) + & + xiy*frcyi(1) + xiz*frczi(1) + xkx*frcxk(1) + & + xky*frcyk(1) + xkz*frczk(1) + vyx = -yr*(ftm2(1)+ftm2i(1)) + yix*frcxi(1) + & + yiy*frcyi(1) + yiz*frczi(1) + ykx*frcxk(1) + & + yky*frcyk(1) + ykz*frczk(1) + vzx = -zr*(ftm2(1)+ftm2i(1)) + zix*frcxi(1) + & + ziy*frcyi(1) + ziz*frczi(1) + zkx*frcxk(1) + & + zky*frcyk(1) + zkz*frczk(1) + vyy = -yr*(ftm2(2)+ftm2i(2)) + yix*frcxi(2) + & + yiy*frcyi(2) + yiz*frczi(2) + ykx*frcxk(2) + & + yky*frcyk(2) + ykz*frczk(2) + vzy = -zr*(ftm2(2)+ftm2i(2)) + zix*frcxi(2) + & + ziy*frcyi(2) + ziz*frczi(2) + zkx*frcxk(2) + & + zky*frcyk(2) + zkz*frczk(2) + vzz = -zr*(ftm2(3)+ftm2i(3)) + zix*frcxi(3) + & + ziy*frcyi(3) + ziz*frczi(3) + zkx*frcxk(3) + & + zky*frcyk(3) + zkz*frczk(3) + vir(1,1) = vir(1,1) + vxx + vir(2,1) = vir(2,1) + vyx + vir(3,1) = vir(3,1) + vzx + vir(1,2) = vir(1,2) + vyx + vir(2,2) = vir(2,2) + vyy + vir(3,2) = vir(3,2) + vzy + vir(1,3) = vir(1,3) + vzx + vir(2,3) = vir(2,3) + vzy + vir(3,3) = vir(3,3) + vzz + end if + end do + 20 continue + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do + end do + end if +c +c perform deallocation of some local arrays +c + deallocate (mscale) + deallocate (pscale) + deallocate (dscale) + deallocate (uscale) + return + end +c +c +c ############################################################### +c ## ## +c ## subroutine empole1b -- neighbor list multipole derivs ## +c ## ## +c ############################################################### +c +c +c "empole1b" calculates the multipole and dipole polarization +c energy and derivatives with respect to Cartesian coordinates +c using a neighbor list +c +c + subroutine empole1b + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'boxes.i' + include 'chgpot.i' + include 'couple.i' + include 'cutoff.i' + include 'deriv.i' + include 'energi.i' + include 'group.i' + include 'inter.i' + include 'molcul.i' + include 'mplpot.i' + include 'mpole.i' + include 'neigh.i' + include 'polar.i' + include 'polgrp.i' + include 'polpot.i' + include 'shunt.i' + include 'usage.i' + include 'virial.i' + integer i,j,k + integer ii,kk,kkk + integer ix,iy,iz + integer kx,ky,kz + integer iax,iay,iaz + integer kax,kay,kaz + real*8 e,ei,f,fgrp,gfd + real*8 damp,expdamp + real*8 pdi,pti,pgamma + real*8 scale3,scale3i + real*8 scale5,scale5i + real*8 scale7,scale7i + real*8 temp3,temp5,temp7 + real*8 psc3,psc5,psc7 + real*8 dsc3,dsc5,dsc7 + real*8 xr,yr,zr + real*8 xix,yix,zix + real*8 xiy,yiy,ziy + real*8 xiz,yiz,ziz + real*8 xkx,ykx,zkx + real*8 xky,yky,zky + real*8 xkz,ykz,zkz + real*8 r,r2,rr1,rr3 + real*8 rr5,rr7,rr9,rr11 + real*8 vxx,vyy,vzz + real*8 vyx,vzx,vzy + real*8 ci,di(3),qi(9) + real*8 ck,dk(3),qk(9) + real*8 frcxi(3),frcxk(3) + real*8 frcyi(3),frcyk(3) + real*8 frczi(3),frczk(3) + real*8 fridmp(3),findmp(3) + real*8 ftm2(3),ftm2i(3) + real*8 ttm2(3),ttm3(3) + real*8 ttm2i(3),ttm3i(3) + real*8 dixdk(3),fdir(3) + real*8 dixuk(3),dkxui(3) + real*8 dixukp(3),dkxuip(3) + real*8 uixqkr(3),ukxqir(3) + real*8 uixqkrp(3),ukxqirp(3) + real*8 qiuk(3),qkui(3) + real*8 qiukp(3),qkuip(3) + real*8 rxqiuk(3),rxqkui(3) + real*8 rxqiukp(3),rxqkuip(3) + real*8 qidk(3),qkdi(3) + real*8 qir(3),qkr(3) + real*8 qiqkr(3),qkqir(3) + real*8 qixqk(3),rxqir(3) + real*8 dixr(3),dkxr(3) + real*8 dixqkr(3),dkxqir(3) + real*8 rxqkr(3),qkrxqir(3) + real*8 rxqikr(3),rxqkir(3) + real*8 rxqidk(3),rxqkdi(3) + real*8 ddsc3(3),ddsc5(3) + real*8 ddsc7(3) + real*8 gl(0:8),gli(7),glip(7) + real*8 sc(10),sci(8),scip(8) + real*8 gf(7),gfi(6),gti(6) + real*8, allocatable :: mscale(:) + real*8, allocatable :: pscale(:) + real*8, allocatable :: dscale(:) + real*8, allocatable :: uscale(:) + logical proceed,usei,usek + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm +c +c +c zero out multipole and polarization energy and derivatives +c + em = 0.0d0 + ep = 0.0d0 + do i = 1, n + do j = 1, 3 + dem(j,i) = 0.0d0 + dep(j,i) = 0.0d0 + end do + end do +c +c check the sign of multipole components at chiral sites +c + call chkpole +c +c rotate the multipole components into the global frame +c + call rotpole +c +c compute the induced dipoles at each polarizable atom +c + call induce +c +c perform dynamic allocation of some local arrays +c + allocate (mscale(n)) + allocate (pscale(n)) + allocate (dscale(n)) + allocate (uscale(n)) +c +c set arrays needed to scale connected atom interactions +c + if (npole .eq. 0) return + do i = 1, n + mscale(i) = 1.0d0 + pscale(i) = 1.0d0 + dscale(i) = 1.0d0 + uscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and scaling coefficients +c + f = electric / dielec + mode = 'MPOLE' + call switch (mode) +c +c set scale factors for permanent multipole and induced terms +c + do i = 1, npole-1 + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + do k = 1, np11(ii) + if (i14(j,ii) .eq. ip11(k,ii)) + & pscale(i14(j,ii)) = p4scale * p41scale + end do + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, nelst(i) + jqmmm = mod(qmmm(ipole(elst(j,i))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + dscale(ipole(elst(j,i))) = 1.0d0 + uscale(ipole(elst(j,i))) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = mscale(ipole(elst(j,i))) + & * qmmmscale + pscale(ipole(elst(j,i))) = pscale(ipole(elst(j,i))) + & * qmmmscale + dscale(ipole(elst(j,i))) = dscale(ipole(elst(j,i))) + & * qmmmscale + uscale(ipole(elst(j,i))) = uscale(ipole(elst(j,i))) + & * qmmmscale + end if + end do + do kkk = 1, nelst(i) + k = elst(kkk,i) + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) + proceed = .true. + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + if (.not. use_intra) proceed = .true. + if (proceed) proceed = (usei .or. usek) + if (.not. proceed) goto 10 + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + if (use_bounds) call image (xr,yr,zr) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + scale3i = scale3 * uscale(kk) + scale5i = scale5 * uscale(kk) + scale7i = scale7 * uscale(kk) + dsc3 = scale3 * dscale(kk) + dsc5 = scale5 * dscale(kk) + dsc7 = scale7 * dscale(kk) + psc3 = scale3 * pscale(kk) + psc5 = scale5 * pscale(kk) + psc7 = scale7 * pscale(kk) +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c compute the energy contributions for this interaction +c + e = rr1*gl(0) + rr3*(gl(1)+gl(6)) + & + rr5*(gl(2)+gl(7)+gl(8)) + & + rr7*(gl(3)+gl(5)) + rr9*gl(4) + ei = 0.5d0*(rr3*(gli(1)+gli(6))*psc3 + & + rr5*(gli(2)+gli(7))*psc5 + & + rr7*gli(3)*psc7) + e = f * mscale(kk) * e + ei = f * ei + em = em + e + ep = ep + ei +c +c increment the total intermolecular energy +c + if (molcule(ii) .ne. molcule(kk)) then + einter = einter + e + ei + end if +c +c intermediate variables for the permanent components +c + gf(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gf(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gf(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gf(4) = 2.0d0 * rr5 + gf(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gf(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gf(7) = 4.0d0 * rr7 +c +c intermediate variables for the induced components +c + gfi(1) = 0.5d0 * rr5 * ((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*scale3i) + & + 0.5d0 * rr7 * ((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*scale5i) + & + 0.5d0 * rr9 * (gli(3)*psc7+glip(3)*dsc7) + gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfi(4) = 2.0d0 * rr5 + gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) +c +c get the permanent force components +c + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the induced force components +c + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify induced force for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (rr5*scip(2)*scale3i + & - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i) + temp5 = 0.5d0 * rr5 * scale5i + fdir(1) = gfd*xr + temp5 + & * (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfd*yr + temp5 + & * (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfd*zr + temp5 + & * (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3) + end if +c +c intermediate variables for induced torque components +c + gti(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gti(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) +c +c get the permanent torque components +c + ttm2(1) = -rr3*dixdk(1) + gf(2)*dixr(1) - gf(5)*rxqir(1) + & + gf(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -rr3*dixdk(2) + gf(2)*dixr(2) - gf(5)*rxqir(2) + & + gf(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -rr3*dixdk(3) + gf(2)*dixr(3) - gf(5)*rxqir(3) + & + gf(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = rr3*dixdk(1) + gf(3)*dkxr(1) - gf(6)*rxqkr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = rr3*dixdk(2) + gf(3)*dkxr(2) - gf(6)*rxqkr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = rr3*dixdk(3) + gf(3)*dkxr(3) - gf(6)*rxqkr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the induced torque components +c + ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1) + ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2) + ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3) + ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1) + ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2) + ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3) +c +c handle the case where scaling is used +c + do j = 1, 3 + ftm2(j) = f * ftm2(j) * mscale(kk) + ftm2i(j) = f * ftm2i(j) + ttm2(j) = f * ttm2(j) * mscale(kk) + ttm2i(j) = f * ttm2i(j) + ttm3(j) = f * ttm3(j) * mscale(kk) + ttm3i(j) = f * ttm3i(j) + end do +c +c increment gradient due to force and torque on first site +c + dem(1,ii) = dem(1,ii) + ftm2(1) + dem(2,ii) = dem(2,ii) + ftm2(2) + dem(3,ii) = dem(3,ii) + ftm2(3) + dep(1,ii) = dep(1,ii) + ftm2i(1) + dep(2,ii) = dep(2,ii) + ftm2i(2) + dep(3,ii) = dep(3,ii) + ftm2i(3) + call torque (i,ttm2,ttm2i,frcxi,frcyi,frczi) +c +c increment gradient due to force and torque on second site +c + dem(1,kk) = dem(1,kk) - ftm2(1) + dem(2,kk) = dem(2,kk) - ftm2(2) + dem(3,kk) = dem(3,kk) - ftm2(3) + dep(1,kk) = dep(1,kk) - ftm2i(1) + dep(2,kk) = dep(2,kk) - ftm2i(2) + dep(3,kk) = dep(3,kk) - ftm2i(3) + call torque (k,ttm3,ttm3i,frcxk,frcyk,frczk) +c +c increment the internal virial tensor components +c + iaz = iz + iax = ix + iay = iy + kaz = kz + kax = kx + kay = ky + if (iaz .eq. 0) iaz = ii + if (iax .eq. 0) iax = ii + if (iay .eq. 0) iay = ii + if (kaz .eq. 0) kaz = kk + if (kax .eq. 0) kax = kk + if (kay .eq. 0) kay = kk + xiz = x(iaz) - x(ii) + yiz = y(iaz) - y(ii) + ziz = z(iaz) - z(ii) + xix = x(iax) - x(ii) + yix = y(iax) - y(ii) + zix = z(iax) - z(ii) + xiy = x(iay) - x(ii) + yiy = y(iay) - y(ii) + ziy = z(iay) - z(ii) + xkz = x(kaz) - x(kk) + ykz = y(kaz) - y(kk) + zkz = z(kaz) - z(kk) + xkx = x(kax) - x(kk) + ykx = y(kax) - y(kk) + zkx = z(kax) - z(kk) + xky = x(kay) - x(kk) + yky = y(kay) - y(kk) + zky = z(kay) - z(kk) + vxx = -xr*(ftm2(1)+ftm2i(1)) + xix*frcxi(1) + & + xiy*frcyi(1) + xiz*frczi(1) + xkx*frcxk(1) + & + xky*frcyk(1) + xkz*frczk(1) + vyx = -yr*(ftm2(1)+ftm2i(1)) + yix*frcxi(1) + & + yiy*frcyi(1) + yiz*frczi(1) + ykx*frcxk(1) + & + yky*frcyk(1) + ykz*frczk(1) + vzx = -zr*(ftm2(1)+ftm2i(1)) + zix*frcxi(1) + & + ziy*frcyi(1) + ziz*frczi(1) + zkx*frcxk(1) + & + zky*frcyk(1) + zkz*frczk(1) + vyy = -yr*(ftm2(2)+ftm2i(2)) + yix*frcxi(2) + & + yiy*frcyi(2) + yiz*frczi(2) + ykx*frcxk(2) + & + yky*frcyk(2) + ykz*frczk(2) + vzy = -zr*(ftm2(2)+ftm2i(2)) + zix*frcxi(2) + & + ziy*frcyi(2) + ziz*frczi(2) + zkx*frcxk(2) + & + zky*frcyk(2) + zkz*frczk(2) + vzz = -zr*(ftm2(3)+ftm2i(3)) + zix*frcxi(3) + & + ziy*frcyi(3) + ziz*frczi(3) + zkx*frcxk(3) + & + zky*frcyk(3) + zkz*frczk(3) + vir(1,1) = vir(1,1) + vxx + vir(2,1) = vir(2,1) + vyx + vir(3,1) = vir(3,1) + vzx + vir(1,2) = vir(1,2) + vyx + vir(2,2) = vir(2,2) + vyy + vir(3,2) = vir(3,2) + vzy + vir(1,3) = vir(1,3) + vzx + vir(2,3) = vir(2,3) + vzy + vir(3,3) = vir(3,3) + vzz + end if + 10 continue + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = 1, nelst(i) + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + dscale(ipole(elst(j,i))) = 1.0d0 + uscale(ipole(elst(j,i))) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do + end do +c +c perform deallocation of some local arrays +c + deallocate (mscale) + deallocate (pscale) + deallocate (dscale) + deallocate (uscale) + return + end +c +c +c ################################################################ +c ## ## +c ## subroutine empole1c -- Ewald multipole derivs via loop ## +c ## ## +c ################################################################ +c +c +c "empole1c" calculates the multipole and dipole polarization +c energy and derivatives with respect to Cartesian coordinates +c using particle mesh Ewald summation and a double loop +c +c + subroutine empole1c + implicit none + include 'sizes.i' + include 'atoms.i' + include 'boxes.i' + include 'chgpot.i' + include 'deriv.i' + include 'energi.i' + include 'ewald.i' + include 'inter.i' + include 'math.i' + include 'mpole.i' + include 'polar.i' + include 'polpot.i' + include 'virial.i' + integer i,j,ii + real*8 e,ei,eintra + real*8 f,term,fterm + real*8 cii,dii,qii,uii + real*8 xd,yd,zd + real*8 xu,yu,zu + real*8 xup,yup,zup + real*8 xq,yq,zq + real*8 xv,yv,zv,vterm + real*8 ci,dix,diy,diz + real*8 uix,uiy,uiz + real*8 qixx,qixy,qixz + real*8 qiyy,qiyz,qizz + real*8 xdfield,xufield + real*8 ydfield,yufield + real*8 zdfield,zufield + real*8 trq(3),trqi(3) + real*8 frcx(3),frcy(3),frcz(3) +c +c +c zero out multipole and polarization energy and derivatives +c + em = 0.0d0 + ep = 0.0d0 + do i = 1, n + do j = 1, 3 + dem(j,i) = 0.0d0 + dep(j,i) = 0.0d0 + end do + end do +c +c set the energy unit conversion factor +c + f = electric / dielec +c +c check the sign of multipole components at chiral sites +c + call chkpole +c +c rotate the multipole components into the global frame +c + call rotpole +c +c compute the induced dipole moment at each atom +c + call induce +c +c compute the reciprocal space part of the Ewald summation +c + call emrecip1 +c +c compute the real space part of the Ewald summation +c + call ereal1c (eintra) +c +c compute the Ewald self-energy term over all the atoms +c + term = 2.0d0 * aewald * aewald + fterm = -f * aewald / sqrtpi + do i = 1, npole + ci = rpole(1,i) + dix = rpole(2,i) + diy = rpole(3,i) + diz = rpole(4,i) + qixx = rpole(5,i) + qixy = rpole(6,i) + qixz = rpole(7,i) + qiyy = rpole(9,i) + qiyz = rpole(10,i) + qizz = rpole(13,i) + uix = uind(1,i) + uiy = uind(2,i) + uiz = uind(3,i) + cii = ci*ci + dii = dix*dix + diy*diy + diz*diz + qii = qixx*qixx + qiyy*qiyy + qizz*qizz + & + 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz) + uii = dix*uix + diy*uiy + diz*uiz + e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0)) + ei = fterm * term * uii / 3.0d0 + em = em + e + ep = ep + ei + end do +c +c compute the self-energy torque term due to induced dipole +c + trq(1) = 0.0d0 + trq(2) = 0.0d0 + trq(3) = 0.0d0 + term = (4.0d0/3.0d0) * f * aewald**3 / sqrtpi + do i = 1, npole + dix = rpole(2,i) + diy = rpole(3,i) + diz = rpole(4,i) + uix = 0.5d0 * (uind(1,i)+uinp(1,i)) + uiy = 0.5d0 * (uind(2,i)+uinp(2,i)) + uiz = 0.5d0 * (uind(3,i)+uinp(3,i)) + trqi(1) = term * (diy*uiz-diz*uiy) + trqi(2) = term * (diz*uix-dix*uiz) + trqi(3) = term * (dix*uiy-diy*uix) + call torque (i,trq,trqi,frcx,frcy,frcz) + end do +c +c compute the cell dipole boundary correction term +c + if (boundary .eq. 'VACUUM') then + xd = 0.0d0 + yd = 0.0d0 + zd = 0.0d0 + xu = 0.0d0 + yu = 0.0d0 + zu = 0.0d0 + xup = 0.0d0 + yup = 0.0d0 + zup = 0.0d0 + do i = 1, npole + ii = ipole(i) + xd = xd + rpole(2,i) + rpole(1,i)*x(ii) + yd = yd + rpole(3,i) + rpole(1,i)*y(ii) + zd = zd + rpole(4,i) + rpole(1,i)*z(ii) + xu = xu + uind(1,i) + yu = yu + uind(2,i) + zu = zu + uind(3,i) + xup = xup + uinp(1,i) + yup = yup + uinp(2,i) + zup = zup + uinp(3,i) + end do + term = (2.0d0/3.0d0) * f * (pi/volbox) + em = em + term*(xd*xd+yd*yd+zd*zd) + ep = ep + term*(xd*xu+yd*yu+zd*zu) + do i = 1, npole + ii = ipole(i) + dem(1,ii) = dem(1,ii) + 2.0d0*term*rpole(1,i)*xd + dem(2,ii) = dem(2,ii) + 2.0d0*term*rpole(1,i)*yd + dem(3,ii) = dem(3,ii) + 2.0d0*term*rpole(1,i)*zd + dep(1,ii) = dep(1,ii) + term*rpole(1,i)*(xu+xup) + dep(2,ii) = dep(2,ii) + term*rpole(1,i)*(yu+yup) + dep(3,ii) = dep(3,ii) + term*rpole(1,i)*(zu+zup) + end do + xdfield = -2.0d0 * term * xd + ydfield = -2.0d0 * term * yd + zdfield = -2.0d0 * term * zd + xufield = -term * (xu+xup) + yufield = -term * (yu+yup) + zufield = -term * (zu+zup) + do i = 1, npole + trq(1) = rpole(3,i)*zdfield - rpole(4,i)*ydfield + trq(2) = rpole(4,i)*xdfield - rpole(2,i)*zdfield + trq(3) = rpole(2,i)*ydfield - rpole(3,i)*xdfield + trqi(1) = rpole(3,i)*zufield - rpole(4,i)*yufield + trqi(2) = rpole(4,i)*xufield - rpole(2,i)*zufield + trqi(3) = rpole(2,i)*yufield - rpole(3,i)*xufield + call torque (i,trq,trqi,frcx,frcy,frcz) + end do +c +c boundary correction to virial due to overall cell dipole +c + xd = 0.0d0 + yd = 0.0d0 + zd = 0.0d0 + xq = 0.0d0 + yq = 0.0d0 + zq = 0.0d0 + do i = 1, npole + ii = ipole(i) + xd = xd + rpole(2,i) + yd = yd + rpole(3,i) + zd = zd + rpole(4,i) + xq = xq + rpole(1,i)*x(ii) + yq = yq + rpole(1,i)*y(ii) + zq = zq + rpole(1,i)*z(ii) + end do + xv = xq * (xd+0.5d0*(xu+xup)) + yv = yq * (yd+0.5d0*(yu+yup)) + zv = zq * (zd+0.5d0*(zu+zup)) + vterm = term * (xq*xq + yq*yq + zq*zq + 2.0d0*(xv+yv+zv) + & + xu*xup + yu*yup + zu*zup + & + xd*(xd+xu+xup) + yd*(yd+yu+yup) + & + zd*(zd+zu+zup)) + vir(1,1) = vir(1,1) + 2.0d0*term*(xq*xq+xv) + vterm + vir(2,1) = vir(2,1) + 2.0d0*term*(xq*yq+xv) + vir(3,1) = vir(3,1) + 2.0d0*term*(xq*zq+xv) + vir(1,2) = vir(1,2) + 2.0d0*term*(yq*xq+yv) + vir(2,2) = vir(2,2) + 2.0d0*term*(yq*yq+yv) + vterm + vir(3,2) = vir(3,2) + 2.0d0*term*(yq*zq+yv) + vir(1,3) = vir(1,3) + 2.0d0*term*(zq*xq+zv) + vir(2,3) = vir(2,3) + 2.0d0*term*(zq*yq+zv) + vir(3,3) = vir(3,3) + 2.0d0*term*(zq*zq+zv) + vterm + if (poltyp .eq. 'DIRECT') then + vterm = term * (xu*xup+yu*yup+zu*zup) + vir(1,1) = vir(1,1) + vterm + vir(2,2) = vir(2,2) + vterm + vir(3,3) = vir(3,3) + vterm + end if + end if +c +c intermolecular energy is total minus intramolecular part +c + einter = einter + em + ep - eintra + return + end +c +c +c ################################################################ +c ## ## +c ## subroutine ereal1c -- Ewald real space derivs via loop ## +c ## ## +c ################################################################ +c +c +c "ereal1c" evaluates the real space portion of the regular Ewald +c summation energy and gradient due to atomic multipole interactions +c and dipole polarizability +c +c + subroutine ereal1c (eintra) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'boxes.i' + include 'cell.i' + include 'chgpot.i' + include 'couple.i' + include 'cutoff.i' + include 'deriv.i' + include 'energi.i' + include 'ewald.i' + include 'math.i' + include 'molcul.i' + include 'mplpot.i' + include 'mpole.i' + include 'polar.i' + include 'polgrp.i' + include 'polpot.i' + include 'shunt.i' + include 'virial.i' + integer i,j,k + integer ii,kk,jcell + integer iax,iay,iaz + integer kax,kay,kaz + real*8 e,ei,f,bfac + real*8 eintra,erfc + real*8 damp,expdamp + real*8 pdi,pti,pgamma + real*8 scale3,scale5 + real*8 scale7 + real*8 temp3,temp5,temp7 + real*8 dsc3,dsc5,dsc7 + real*8 psc3,psc5,psc7 + real*8 usc3,usc5 + real*8 alsq2,alsq2n + real*8 exp2a,ralpha + real*8 gfd,gfdr + real*8 xr,yr,zr + real*8 xix,yix,zix + real*8 xiy,yiy,ziy + real*8 xiz,yiz,ziz + real*8 xkx,ykx,zkx + real*8 xky,yky,zky + real*8 xkz,ykz,zkz + real*8 r,r2,rr1,rr3 + real*8 rr5,rr7,rr9,rr11 + real*8 erl,erli + real*8 vxx,vyy,vzz + real*8 vyx,vzx,vzy + real*8 frcxi(3),frcxk(3) + real*8 frcyi(3),frcyk(3) + real*8 frczi(3),frczk(3) + real*8 ci,di(3),qi(9) + real*8 ck,dk(3),qk(9) + real*8 fridmp(3),findmp(3) + real*8 ftm2(3),ftm2i(3) + real*8 ftm2r(3),ftm2ri(3) + real*8 ttm2(3),ttm3(3) + real*8 ttm2i(3),ttm3i(3) + real*8 ttm2r(3),ttm3r(3) + real*8 ttm2ri(3),ttm3ri(3) + real*8 fdir(3),dixdk(3) + real*8 dkxui(3),dixuk(3) + real*8 dixukp(3),dkxuip(3) + real*8 uixqkr(3),ukxqir(3) + real*8 uixqkrp(3),ukxqirp(3) + real*8 qiuk(3),qkui(3) + real*8 qiukp(3),qkuip(3) + real*8 rxqiuk(3),rxqkui(3) + real*8 rxqiukp(3),rxqkuip(3) + real*8 qidk(3),qkdi(3) + real*8 qir(3),qkr(3) + real*8 qiqkr(3),qkqir(3) + real*8 qixqk(3),rxqir(3) + real*8 dixr(3),dkxr(3) + real*8 dixqkr(3),dkxqir(3) + real*8 rxqkr(3),qkrxqir(3) + real*8 rxqikr(3),rxqkir(3) + real*8 rxqidk(3),rxqkdi(3) + real*8 ddsc3(3),ddsc5(3) + real*8 ddsc7(3) + real*8 bn(0:5) + real*8 sc(10),gl(0:8) + real*8 sci(8),scip(8) + real*8 gli(7),glip(7) + real*8 gf(7),gfi(6) + real*8 gfr(7),gfri(6) + real*8 gti(6),gtri(6) + real*8, allocatable :: mscale(:) + real*8, allocatable :: pscale(:) + real*8, allocatable :: dscale(:) + real*8, allocatable :: uscale(:) + character*6 mode + external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm +c +c +c zero out the intramolecular portion of the Ewald energy +c + eintra = 0.0d0 + if (npole .eq. 0) return +c +c perform dynamic allocation of some local arrays +c + allocate (mscale(n)) + allocate (pscale(n)) + allocate (dscale(n)) + allocate (uscale(n)) +c +c set arrays needed to scale connected atom interactions +c + do i = 1, n + mscale(i) = 1.0d0 + pscale(i) = 1.0d0 + dscale(i) = 1.0d0 + uscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = electric / dielec + mode = 'EWALD' + call switch (mode) +c +c set the permanent multipole and induced dipole values +c + do i = 1, npole-1 + ii = ipole(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + do k = 1, np11(ii) + if (i14(j,ii) .eq. ip11(k,ii)) + & pscale(i14(j,ii)) = p4scale * p41scale + end do + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do + do k = i+1, npole + kk = ipole(k) + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + call image (xr,yr,zr) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c calculate the real space error function terms +c + ralpha = aewald * r + bn(0) = erfc(ralpha) / r + alsq2 = 2.0d0 * aewald**2 + alsq2n = 0.0d0 + if (aewald .gt. 0.0d0) alsq2n = 1.0d0 / (sqrtpi*aewald) + exp2a = exp(-ralpha**2) + do j = 1, 5 + bfac = dble(2*j-1) + alsq2n = alsq2 * alsq2n + bn(j) = (bfac*bn(j-1)+alsq2n*exp2a) / r2 + end do +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + dsc3 = 1.0d0 - scale3*dscale(kk) + dsc5 = 1.0d0 - scale5*dscale(kk) + dsc7 = 1.0d0 - scale7*dscale(kk) + psc3 = 1.0d0 - scale3*pscale(kk) + psc5 = 1.0d0 - scale5*pscale(kk) + psc7 = 1.0d0 - scale7*pscale(kk) + usc3 = 1.0d0 - scale3*uscale(kk) + usc5 = 1.0d0 - scale5*uscale(kk) +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate the scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate the scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c compute the energy contributions for this interaction +c + e = bn(0)*gl(0) + bn(1)*(gl(1)+gl(6)) + & + bn(2)*(gl(2)+gl(7)+gl(8)) + & + bn(3)*(gl(3)+gl(5)) + bn(4)*gl(4) + ei = 0.5d0 * (bn(1)*(gli(1)+gli(6)) + & + bn(2)*(gli(2)+gli(7)) + bn(3)*gli(3)) +c +c get the real energy without any screening function +c + erl = rr1*gl(0) + rr3*(gl(1)+gl(6)) + & + rr5*(gl(2)+gl(7)+gl(8)) + & + rr7*(gl(3)+gl(5)) + rr9*gl(4) + erli = 0.5d0*(rr3*(gli(1)+gli(6))*psc3 + & + rr5*(gli(2)+gli(7))*psc5 + & + rr7*gli(3)*psc7) + e = e - (1.0d0-mscale(kk))*erl + ei = ei - erli + e = f * e + ei = f * ei + em = em + e + ep = ep + ei +c +c increment the total intramolecular energy; assumes +c intramolecular distances are less than half of cell +c length and less than the ewald cutoff +c + if (molcule(ii) .eq. molcule(kk)) then + eintra = eintra + mscale(kk)*erl*f + eintra = eintra + 0.5d0*pscale(kk) + & * (rr3*(gli(1)+gli(6))*scale3 + & + rr5*(gli(2)+gli(7))*scale5 + & + rr7*gli(3)*scale7) + end if +c +c intermediate variables for permanent force terms +c + gf(1) = bn(1)*gl(0) + bn(2)*(gl(1)+gl(6)) + & + bn(3)*(gl(2)+gl(7)+gl(8)) + & + bn(4)*(gl(3)+gl(5)) + bn(5)*gl(4) + gf(2) = -ck*bn(1) + sc(4)*bn(2) - sc(6)*bn(3) + gf(3) = ci*bn(1) + sc(3)*bn(2) + sc(5)*bn(3) + gf(4) = 2.0d0 * bn(2) + gf(5) = 2.0d0 * (-ck*bn(2)+sc(4)*bn(3)-sc(6)*bn(4)) + gf(6) = 2.0d0 * (-ci*bn(2)-sc(3)*bn(3)-sc(5)*bn(4)) + gf(7) = 4.0d0 * bn(3) + gfr(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gfr(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gfr(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gfr(4) = 2.0d0 * rr5 + gfr(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gfr(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gfr(7) = 4.0d0 * rr7 +c +c intermediate variables for induced force terms +c + gfi(1) = 0.5d0*bn(2)*(gli(1)+glip(1)+gli(6)+glip(6)) + & + 0.5d0*bn(2)*scip(2) + & + 0.5d0*bn(3)*(gli(2)+glip(2)+gli(7)+glip(7)) + & - 0.5d0*bn(3)*(sci(3)*scip(4)+scip(3)*sci(4)) + & + 0.5d0*bn(4)*(gli(3)+glip(3)) + gfi(2) = -ck*bn(1) + sc(4)*bn(2) - sc(6)*bn(3) + gfi(3) = ci*bn(1) + sc(3)*bn(2) + sc(5)*bn(3) + gfi(4) = 2.0d0 * bn(2) + gfi(5) = bn(3) * (sci(4)+scip(4)) + gfi(6) = -bn(3) * (sci(3)+scip(3)) + gfri(1) = 0.5d0*rr5*((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*usc3) + & + 0.5d0*rr7*((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*usc5) + & + 0.5d0*rr9*(gli(3)*psc7+glip(3)*dsc7) + gfri(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfri(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfri(4) = 2.0d0 * rr5 + gfri(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfri(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) +c +c get the permanent force with screening +c + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the permanent force without screening +c + ftm2r(1) = gfr(1)*xr + gfr(2)*di(1) + gfr(3)*dk(1) + & + gfr(4)*(qkdi(1)-qidk(1)) + gfr(5)*qir(1) + & + gfr(6)*qkr(1) + gfr(7)*(qiqkr(1)+qkqir(1)) + ftm2r(2) = gfr(1)*yr + gfr(2)*di(2) + gfr(3)*dk(2) + & + gfr(4)*(qkdi(2)-qidk(2)) + gfr(5)*qir(2) + & + gfr(6)*qkr(2) + gfr(7)*(qiqkr(2)+qkqir(2)) + ftm2r(3) = gfr(1)*zr + gfr(2)*di(3) + gfr(3)*dk(3) + & + gfr(4)*(qkdi(3)-qidk(3)) + gfr(5)*qir(3) + & + gfr(6)*qkr(3) + gfr(7)*(qiqkr(3)+qkqir(3)) +c +c get the induced force with screening +c + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (gfi(2)*(uind(1,i)+uinp(1,i)) + & + bn(2)*(sci(4)*uinp(1,i)+scip(4)*uind(1,i)) + & + gfi(3)*(uind(1,k)+uinp(1,k)) + & + bn(2)*(sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + & + (sci(4)+scip(4))*bn(2)*di(1) + & + (sci(3)+scip(3))*bn(2)*dk(1) + & + gfi(4)*(qkui(1)+qkuip(1)-qiuk(1)-qiukp(1))) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (gfi(2)*(uind(2,i)+uinp(2,i)) + & + bn(2)*(sci(4)*uinp(2,i)+scip(4)*uind(2,i)) + & + gfi(3)*(uind(2,k)+uinp(2,k)) + & + bn(2)*(sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + & + (sci(4)+scip(4))*bn(2)*di(2) + & + (sci(3)+scip(3))*bn(2)*dk(2) + & + gfi(4)*(qkui(2)+qkuip(2)-qiuk(2)-qiukp(2))) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (gfi(2)*(uind(3,i)+uinp(3,i)) + & + bn(2)*(sci(4)*uinp(3,i)+scip(4)*uind(3,i)) + & + gfi(3)*(uind(3,k)+uinp(3,k)) + & + bn(2)*(sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + & + (sci(4)+scip(4))*bn(2)*di(3) + & + (sci(3)+scip(3))*bn(2)*dk(3) + & + gfi(4)*(qkui(3)+qkuip(3)-qiuk(3)-qiukp(3))) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c get the induced force without screening +c + ftm2ri(1) = gfri(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*usc5*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfri(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfri(5)*qir(1) + gfri(6)*qkr(1) + ftm2ri(2) = gfri(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*usc5*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfri(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfri(5)*qir(2) + gfri(6)*qkr(2) + ftm2ri(3) = gfri(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*usc5*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfri(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfri(5)*qir(3) + gfri(6)*qkr(3) +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify the forces for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (bn(2)*scip(2) + & - bn(3)*(scip(3)*sci(4)+sci(3)*scip(4))) + gfdr = 0.5d0 * (rr5*scip(2)*usc3 + & - rr7*(scip(3)*sci(4) + & +sci(3)*scip(4))*usc5) + ftm2i(1) = ftm2i(1) - gfd*xr - 0.5d0*bn(2)* + & (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + ftm2i(2) = ftm2i(2) - gfd*yr - 0.5d0*bn(2)* + & (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + ftm2i(3) = ftm2i(3) - gfd*zr - 0.5d0*bn(2)* + & (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + fdir(1) = gfdr*xr + 0.5d0*usc5*rr5* + & (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfdr*yr + 0.5d0*usc5*rr5* + & (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfdr*zr + 0.5d0*usc5*rr5* + & (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) + fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) + fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) + fdir(3) + findmp(3) + end if +c +c intermediate variables for induced torque terms +c + gti(2) = 0.5d0 * bn(2) * (sci(4)+scip(4)) + gti(3) = 0.5d0 * bn(2) * (sci(3)+scip(3)) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) + gtri(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gtri(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gtri(4) = gfri(4) + gtri(5) = gfri(5) + gtri(6) = gfri(6) +c +c get the permanent torque with screening +c + ttm2(1) = -bn(1)*dixdk(1) + gf(2)*dixr(1) + & + gf(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gf(5)*rxqir(1) - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -bn(1)*dixdk(2) + gf(2)*dixr(2) + & + gf(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gf(5)*rxqir(2) - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -bn(1)*dixdk(3) + gf(2)*dixr(3) + & + gf(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gf(5)*rxqir(3) - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = bn(1)*dixdk(1) + gf(3)*dkxr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(6)*rxqkr(1) - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = bn(1)*dixdk(2) + gf(3)*dkxr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(6)*rxqkr(2) - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = bn(1)*dixdk(3) + gf(3)*dkxr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(6)*rxqkr(3) - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the permanent torque without screening +c + ttm2r(1) = -rr3*dixdk(1) + gfr(2)*dixr(1)-gfr(5)*rxqir(1) + & + gfr(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gfr(7)*(rxqikr(1)+qkrxqir(1)) + ttm2r(2) = -rr3*dixdk(2) + gfr(2)*dixr(2)-gfr(5)*rxqir(2) + & + gfr(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gfr(7)*(rxqikr(2)+qkrxqir(2)) + ttm2r(3) = -rr3*dixdk(3) + gfr(2)*dixr(3)-gfr(5)*rxqir(3) + & + gfr(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gfr(7)*(rxqikr(3)+qkrxqir(3)) + ttm3r(1) = rr3*dixdk(1) + gfr(3)*dkxr(1) -gfr(6)*rxqkr(1) + & - gfr(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gfr(7)*(rxqkir(1)-qkrxqir(1)) + ttm3r(2) = rr3*dixdk(2) + gfr(3)*dkxr(2) -gfr(6)*rxqkr(2) + & - gfr(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gfr(7)*(rxqkir(2)-qkrxqir(2)) + ttm3r(3) = rr3*dixdk(3) + gfr(3)*dkxr(3) -gfr(6)*rxqkr(3) + & - gfr(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gfr(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the induced torque with screening +c + ttm2i(1) = -bn(1)*(dixuk(1)+dixukp(1))*0.5d0 + & + gti(2)*dixr(1) + gti(4)*(ukxqir(1)+rxqiuk(1) + & + ukxqirp(1)+rxqiukp(1))*0.5d0 - gti(5)*rxqir(1) + ttm2i(2) = -bn(1)*(dixuk(2)+dixukp(2))*0.5d0 + & + gti(2)*dixr(2) + gti(4)*(ukxqir(2)+rxqiuk(2) + & + ukxqirp(2)+rxqiukp(2))*0.5d0 - gti(5)*rxqir(2) + ttm2i(3) = -bn(1)*(dixuk(3)+dixukp(3))*0.5d0 + & + gti(2)*dixr(3) + gti(4)*(ukxqir(3)+rxqiuk(3) + & + ukxqirp(3)+rxqiukp(3))*0.5d0 - gti(5)*rxqir(3) + ttm3i(1) = -bn(1)*(dkxui(1)+dkxuip(1))*0.5d0 + & + gti(3)*dkxr(1) - gti(4)*(uixqkr(1)+rxqkui(1) + & + uixqkrp(1)+rxqkuip(1))*0.5d0 - gti(6)*rxqkr(1) + ttm3i(2) = -bn(1)*(dkxui(2)+dkxuip(2))*0.5d0 + & + gti(3)*dkxr(2) - gti(4)*(uixqkr(2)+rxqkui(2) + & + uixqkrp(2)+rxqkuip(2))*0.5d0 - gti(6)*rxqkr(2) + ttm3i(3) = -bn(1)*(dkxui(3)+dkxuip(3))*0.5d0 + & + gti(3)*dkxr(3) - gti(4)*(uixqkr(3)+rxqkui(3) + & + uixqkrp(3)+rxqkuip(3))*0.5d0 - gti(6)*rxqkr(3) +c +c get the induced torque without screening +c + ttm2ri(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gtri(2)*dixr(1) + gtri(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gtri(5)*rxqir(1) + ttm2ri(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gtri(2)*dixr(2) + gtri(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gtri(5)*rxqir(2) + ttm2ri(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gtri(2)*dixr(3) + gtri(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gtri(5)*rxqir(3) + ttm3ri(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gtri(3)*dkxr(1) - gtri(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gtri(6)*rxqkr(1) + ttm3ri(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gtri(3)*dkxr(2) - gtri(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gtri(6)*rxqkr(2) + ttm3ri(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gtri(3)*dkxr(3) - gtri(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gtri(6)*rxqkr(3) +c +c handle the case where scaling is used +c + do j = 1, 3 + ftm2(j) = f * (ftm2(j)-(1.0d0-mscale(kk))*ftm2r(j)) + ftm2i(j) = f * (ftm2i(j)-ftm2ri(j)) + ttm2(j) = f * (ttm2(j)-(1.0d0-mscale(kk))*ttm2r(j)) + ttm2i(j) = f * (ttm2i(j)-ttm2ri(j)) + ttm3(j) = f * (ttm3(j)-(1.0d0-mscale(kk))*ttm3r(j)) + ttm3i(j) = f * (ttm3i(j)-ttm3ri(j)) + end do +c +c increment gradient due to force and torque on first site +c + dem(1,ii) = dem(1,ii) + ftm2(1) + dem(2,ii) = dem(2,ii) + ftm2(2) + dem(3,ii) = dem(3,ii) + ftm2(3) + dep(1,ii) = dep(1,ii) + ftm2i(1) + dep(2,ii) = dep(2,ii) + ftm2i(2) + dep(3,ii) = dep(3,ii) + ftm2i(3) + call torque (i,ttm2,ttm2i,frcxi,frcyi,frczi) +c +c increment gradient due to force and torque on second site +c + dem(1,kk) = dem(1,kk) - ftm2(1) + dem(2,kk) = dem(2,kk) - ftm2(2) + dem(3,kk) = dem(3,kk) - ftm2(3) + dep(1,kk) = dep(1,kk) - ftm2i(1) + dep(2,kk) = dep(2,kk) - ftm2i(2) + dep(3,kk) = dep(3,kk) - ftm2i(3) + call torque (k,ttm3,ttm3i,frcxk,frcyk,frczk) +c +c increment the internal virial tensor components +c + iaz = zaxis(i) + iax = xaxis(i) + iay = yaxis(i) + kaz = zaxis(k) + kax = xaxis(k) + kay = yaxis(k) + if (iaz .eq. 0) iaz = ii + if (iax .eq. 0) iax = ii + if (iay .eq. 0) iay = ii + if (kaz .eq. 0) kaz = kk + if (kax .eq. 0) kax = kk + if (kay .eq. 0) kay = kk + xiz = x(iaz) - x(ii) + yiz = y(iaz) - y(ii) + ziz = z(iaz) - z(ii) + xix = x(iax) - x(ii) + yix = y(iax) - y(ii) + zix = z(iax) - z(ii) + xiy = x(iay) - x(ii) + yiy = y(iay) - y(ii) + ziy = z(iay) - z(ii) + xkz = x(kaz) - x(kk) + ykz = y(kaz) - y(kk) + zkz = z(kaz) - z(kk) + xkx = x(kax) - x(kk) + ykx = y(kax) - y(kk) + zkx = z(kax) - z(kk) + xky = x(kay) - x(kk) + yky = y(kay) - y(kk) + zky = z(kay) - z(kk) + vxx = -xr*(ftm2(1)+ftm2i(1)) + xix*frcxi(1) + & + xiy*frcyi(1) + xiz*frczi(1) + xkx*frcxk(1) + & + xky*frcyk(1) + xkz*frczk(1) + vyx = -yr*(ftm2(1)+ftm2i(1)) + yix*frcxi(1) + & + yiy*frcyi(1) + yiz*frczi(1) + ykx*frcxk(1) + & + yky*frcyk(1) + ykz*frczk(1) + vzx = -zr*(ftm2(1)+ftm2i(1)) + zix*frcxi(1) + & + ziy*frcyi(1) + ziz*frczi(1) + zkx*frcxk(1) + & + zky*frcyk(1) + zkz*frczk(1) + vyy = -yr*(ftm2(2)+ftm2i(2)) + yix*frcxi(2) + & + yiy*frcyi(2) + yiz*frczi(2) + ykx*frcxk(2) + & + yky*frcyk(2) + ykz*frczk(2) + vzy = -zr*(ftm2(2)+ftm2i(2)) + zix*frcxi(2) + & + ziy*frcyi(2) + ziz*frczi(2) + zkx*frcxk(2) + & + zky*frcyk(2) + zkz*frczk(2) + vzz = -zr*(ftm2(3)+ftm2i(3)) + zix*frcxi(3) + & + ziy*frcyi(3) + ziz*frczi(3) + zkx*frcxk(3) + & + zky*frcyk(3) + zkz*frczk(3) + vir(1,1) = vir(1,1) + vxx + vir(2,1) = vir(2,1) + vyx + vir(3,1) = vir(3,1) + vzx + vir(1,2) = vir(1,2) + vyx + vir(2,2) = vir(2,2) + vyy + vir(3,2) = vir(3,2) + vzy + vir(1,3) = vir(1,3) + vzx + vir(2,3) = vir(2,3) + vzy + vir(3,3) = vir(3,3) + vzz + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (use_replica) then +c +c calculate interaction with other unit cells +c + do i = 1, npole + ii = ipole(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do + do k = i, npole + kk = ipole(k) + do jcell = 1, ncell + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + call imager (xr,yr,zr,jcell) + r2 = xr*xr + yr*yr + zr*zr + if (.not. (use_polymer .and. r2.le.polycut2)) then + mscale(kk) = 1.0d0 + pscale(kk) = 1.0d0 + dscale(kk) = 1.0d0 + uscale(kk) = 1.0d0 + end if + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c calculate the real space error function terms +c + ralpha = aewald * r + bn(0) = erfc(ralpha) / r + alsq2 = 2.0d0 * aewald**2 + alsq2n = 0.0d0 + if (aewald .gt. 0.0d0) alsq2n = 1.0d0 / (sqrtpi*aewald) + exp2a = exp(-ralpha**2) + do j = 1, 5 + bfac = dble(2*j-1) + alsq2n = alsq2 * alsq2n + bn(j) = (bfac*bn(j-1)+alsq2n*exp2a) / r2 + end do +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + dsc3 = 1.0d0 - scale3*dscale(kk) + dsc5 = 1.0d0 - scale5*dscale(kk) + dsc7 = 1.0d0 - scale7*dscale(kk) + psc3 = 1.0d0 - scale3*pscale(kk) + psc5 = 1.0d0 - scale5*pscale(kk) + psc7 = 1.0d0 - scale7*pscale(kk) + usc3 = 1.0d0 - scale3*uscale(kk) + usc5 = 1.0d0 - scale5*uscale(kk) +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate the scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate the scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c compute the energy contributions for this interaction +c + e = bn(0)*gl(0) + bn(1)*(gl(1)+gl(6)) + & + bn(2)*(gl(2)+gl(7)+gl(8)) + & + bn(3)*(gl(3)+gl(5)) + bn(4)*gl(4) + ei = 0.5d0 * (bn(1)*(gli(1)+gli(6)) + & + bn(2)*(gli(2)+gli(7)) + bn(3)*gli(3)) +c +c get the real energy without any screening function +c + erl = rr1*gl(0) + rr3*(gl(1)+gl(6)) + & + rr5*(gl(2)+gl(7)+gl(8)) + & + rr7*(gl(3)+gl(5)) + rr9*gl(4) + erli = 0.5d0*(rr3*(gli(1)+gli(6))*psc3 + & + rr5*(gli(2)+gli(7))*psc5 + & + rr7*gli(3)*psc7) + if (use_polymer .and. r2.le.polycut2) + & e = e - (1.0d0-mscale(kk))*erl + ei = ei - erli + e = f * e + ei = f * ei + if (ii .eq. kk) then + e = 0.5d0 * e + ei = 0.5d0 * ei + end if + em = em + e + ep = ep + ei +c +c increment the total intramolecular energy; assumes +c intramolecular distances are less than half of cell +c length and less than the ewald cutoff +c + if (molcule(ii) .eq. molcule(kk)) then + eintra = eintra + mscale(kk)*erl*f + eintra = eintra + 0.5d0*pscale(kk) + & * (rr3*(gli(1)+gli(6))*scale3 + & + rr5*(gli(2)+gli(7))*scale5 + & + rr7*gli(3)*scale7) + end if +c +c intermediate variables for permanent force terms +c + gf(1) = bn(1)*gl(0) + bn(2)*(gl(1)+gl(6)) + & + bn(3)*(gl(2)+gl(7)+gl(8)) + & + bn(4)*(gl(3)+gl(5)) + bn(5)*gl(4) + gf(2) = -ck*bn(1) + sc(4)*bn(2) - sc(6)*bn(3) + gf(3) = ci*bn(1) + sc(3)*bn(2) + sc(5)*bn(3) + gf(4) = 2.0d0 * bn(2) + gf(5) = 2.0d0 * (-ck*bn(2)+sc(4)*bn(3)-sc(6)*bn(4)) + gf(6) = 2.0d0 * (-ci*bn(2)-sc(3)*bn(3)-sc(5)*bn(4)) + gf(7) = 4.0d0 * bn(3) + gfr(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gfr(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gfr(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gfr(4) = 2.0d0 * rr5 + gfr(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gfr(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gfr(7) = 4.0d0 * rr7 +c +c intermediate variables for induced force terms +c + gfi(1) = 0.5d0*bn(2)*(gli(1)+glip(1)+gli(6)+glip(6)) + & + 0.5d0*bn(2)*scip(2) + & + 0.5d0*bn(3)*(gli(2)+glip(2)+gli(7)+glip(7)) + & - 0.5d0*bn(3)*(sci(3)*scip(4)+scip(3)*sci(4)) + & + 0.5d0*bn(4)*(gli(3)+glip(3)) + gfi(2) = -ck*bn(1) + sc(4)*bn(2) - sc(6)*bn(3) + gfi(3) = ci*bn(1) + sc(3)*bn(2) + sc(5)*bn(3) + gfi(4) = 2.0d0 * bn(2) + gfi(5) = bn(3) * (sci(4)+scip(4)) + gfi(6) = -bn(3) * (sci(3)+scip(3)) + gfri(1) = 0.5d0*rr5*((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*usc3) + & + 0.5d0*rr7*((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*usc5) + & + 0.5d0*rr9*(gli(3)*psc7+glip(3)*dsc7) + gfri(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfri(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfri(4) = 2.0d0 * rr5 + gfri(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfri(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) +c +c get the permanent force with screening +c + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the permanent force without screening +c + ftm2r(1) = gfr(1)*xr + gfr(2)*di(1) + gfr(3)*dk(1) + & + gfr(4)*(qkdi(1)-qidk(1)) + gfr(5)*qir(1) + & + gfr(6)*qkr(1) + gfr(7)*(qiqkr(1)+qkqir(1)) + ftm2r(2) = gfr(1)*yr + gfr(2)*di(2) + gfr(3)*dk(2) + & + gfr(4)*(qkdi(2)-qidk(2)) + gfr(5)*qir(2) + & + gfr(6)*qkr(2) + gfr(7)*(qiqkr(2)+qkqir(2)) + ftm2r(3) = gfr(1)*zr + gfr(2)*di(3) + gfr(3)*dk(3) + & + gfr(4)*(qkdi(3)-qidk(3)) + gfr(5)*qir(3) + & + gfr(6)*qkr(3) + gfr(7)*(qiqkr(3)+qkqir(3)) +c +c get the induced force with screening +c + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (gfi(2)*(uind(1,i)+uinp(1,i)) + & + bn(2)*(sci(4)*uinp(1,i)+scip(4)*uind(1,i)) + & + gfi(3)*(uind(1,k)+uinp(1,k)) + & + bn(2)*(sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + & + (sci(4)+scip(4))*bn(2)*di(1) + & + (sci(3)+scip(3))*bn(2)*dk(1) + & + gfi(4)*(qkui(1)+qkuip(1)-qiuk(1)-qiukp(1))) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (gfi(2)*(uind(2,i)+uinp(2,i)) + & + bn(2)*(sci(4)*uinp(2,i)+scip(4)*uind(2,i)) + & + gfi(3)*(uind(2,k)+uinp(2,k)) + & + bn(2)*(sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + & + (sci(4)+scip(4))*bn(2)*di(2) + & + (sci(3)+scip(3))*bn(2)*dk(2) + & + gfi(4)*(qkui(2)+qkuip(2)-qiuk(2)-qiukp(2))) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (gfi(2)*(uind(3,i)+uinp(3,i)) + & + bn(2)*(sci(4)*uinp(3,i)+scip(4)*uind(3,i)) + & + gfi(3)*(uind(3,k)+uinp(3,k)) + & + bn(2)*(sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + & + (sci(4)+scip(4))*bn(2)*di(3) + & + (sci(3)+scip(3))*bn(2)*dk(3) + & + gfi(4)*(qkui(3)+qkuip(3)-qiuk(3)-qiukp(3))) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c get the induced force without screening +c + ftm2ri(1) = gfri(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*usc5*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfri(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfri(5)*qir(1) + gfri(6)*qkr(1) + ftm2ri(2) = gfri(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*usc5*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfri(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfri(5)*qir(2) + gfri(6)*qkr(2) + ftm2ri(3) = gfri(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*usc5*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfri(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfri(5)*qir(3) + gfri(6)*qkr(3) +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify the forces for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (bn(2)*scip(2) + & - bn(3)*(scip(3)*sci(4)+sci(3)*scip(4))) + gfdr = 0.5d0 * (rr5*scip(2)*usc3 + & - rr7*(scip(3)*sci(4) + & +sci(3)*scip(4))*usc5) + ftm2i(1) = ftm2i(1) - gfd*xr - 0.5d0*bn(2)* + & (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + ftm2i(2) = ftm2i(2) - gfd*yr - 0.5d0*bn(2)* + & (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + ftm2i(3) = ftm2i(3) - gfd*zr - 0.5d0*bn(2)* + & (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + fdir(1) = gfdr*xr + 0.5d0*usc5*rr5* + & (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfdr*yr + 0.5d0*usc5*rr5* + & (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfdr*zr + 0.5d0*usc5*rr5* + & (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) + fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) + fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) + fdir(3) + findmp(3) + end if +c +c intermediate variables for induced torque terms +c + gti(2) = 0.5d0 * bn(2) * (sci(4)+scip(4)) + gti(3) = 0.5d0 * bn(2) * (sci(3)+scip(3)) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) + gtri(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gtri(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gtri(4) = gfri(4) + gtri(5) = gfri(5) + gtri(6) = gfri(6) +c +c get the permanent torque with screening +c + ttm2(1) = -bn(1)*dixdk(1) + gf(2)*dixr(1) + & + gf(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gf(5)*rxqir(1) - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -bn(1)*dixdk(2) + gf(2)*dixr(2) + & + gf(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gf(5)*rxqir(2) - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -bn(1)*dixdk(3) + gf(2)*dixr(3) + & + gf(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gf(5)*rxqir(3) - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = bn(1)*dixdk(1) + gf(3)*dkxr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(6)*rxqkr(1) - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = bn(1)*dixdk(2) + gf(3)*dkxr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(6)*rxqkr(2) - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = bn(1)*dixdk(3) + gf(3)*dkxr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(6)*rxqkr(3) - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the permanent torque without screening +c + ttm2r(1) = -rr3*dixdk(1) + gfr(2)*dixr(1)-gfr(5)*rxqir(1) + & + gfr(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gfr(7)*(rxqikr(1)+qkrxqir(1)) + ttm2r(2) = -rr3*dixdk(2) + gfr(2)*dixr(2)-gfr(5)*rxqir(2) + & + gfr(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gfr(7)*(rxqikr(2)+qkrxqir(2)) + ttm2r(3) = -rr3*dixdk(3) + gfr(2)*dixr(3)-gfr(5)*rxqir(3) + & + gfr(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gfr(7)*(rxqikr(3)+qkrxqir(3)) + ttm3r(1) = rr3*dixdk(1) + gfr(3)*dkxr(1) -gfr(6)*rxqkr(1) + & - gfr(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gfr(7)*(rxqkir(1)-qkrxqir(1)) + ttm3r(2) = rr3*dixdk(2) + gfr(3)*dkxr(2) -gfr(6)*rxqkr(2) + & - gfr(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gfr(7)*(rxqkir(2)-qkrxqir(2)) + ttm3r(3) = rr3*dixdk(3) + gfr(3)*dkxr(3) -gfr(6)*rxqkr(3) + & - gfr(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gfr(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the induced torque with screening +c + ttm2i(1) = -bn(1)*(dixuk(1)+dixukp(1))*0.5d0 + & + gti(2)*dixr(1) + gti(4)*(ukxqir(1)+rxqiuk(1) + & + ukxqirp(1)+rxqiukp(1))*0.5d0 - gti(5)*rxqir(1) + ttm2i(2) = -bn(1)*(dixuk(2)+dixukp(2))*0.5d0 + & + gti(2)*dixr(2) + gti(4)*(ukxqir(2)+rxqiuk(2) + & + ukxqirp(2)+rxqiukp(2))*0.5d0 - gti(5)*rxqir(2) + ttm2i(3) = -bn(1)*(dixuk(3)+dixukp(3))*0.5d0 + & + gti(2)*dixr(3) + gti(4)*(ukxqir(3)+rxqiuk(3) + & + ukxqirp(3)+rxqiukp(3))*0.5d0 - gti(5)*rxqir(3) + ttm3i(1) = -bn(1)*(dkxui(1)+dkxuip(1))*0.5d0 + & + gti(3)*dkxr(1) - gti(4)*(uixqkr(1)+rxqkui(1) + & + uixqkrp(1)+rxqkuip(1))*0.5d0 - gti(6)*rxqkr(1) + ttm3i(2) = -bn(1)*(dkxui(2)+dkxuip(2))*0.5d0 + & + gti(3)*dkxr(2) - gti(4)*(uixqkr(2)+rxqkui(2) + & + uixqkrp(2)+rxqkuip(2))*0.5d0 - gti(6)*rxqkr(2) + ttm3i(3) = -bn(1)*(dkxui(3)+dkxuip(3))*0.5d0 + & + gti(3)*dkxr(3) - gti(4)*(uixqkr(3)+rxqkui(3) + & + uixqkrp(3)+rxqkuip(3))*0.5d0 - gti(6)*rxqkr(3) +c +c get the induced torque without screening +c + ttm2ri(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gtri(2)*dixr(1) + gtri(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gtri(5)*rxqir(1) + ttm2ri(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gtri(2)*dixr(2) + gtri(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gtri(5)*rxqir(2) + ttm2ri(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gtri(2)*dixr(3) + gtri(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gtri(5)*rxqir(3) + ttm3ri(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gtri(3)*dkxr(1) - gtri(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gtri(6)*rxqkr(1) + ttm3ri(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gtri(3)*dkxr(2) - gtri(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gtri(6)*rxqkr(2) + ttm3ri(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gtri(3)*dkxr(3) - gtri(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gtri(6)*rxqkr(3) +c +c handle the case where scaling is used +c + if (use_polymer .and. r2.le.polycut2) then + do j = 1, 3 + ftm2(j) = f * (ftm2(j)-(1.0d0-mscale(kk))*ftm2r(j)) + ftm2i(j) = f * (ftm2i(j)-ftm2ri(j)) + ttm2(j) = f * (ttm2(j)-(1.0d0-mscale(kk))*ttm2r(j)) + ttm2i(j) = f * (ttm2i(j)-ttm2ri(j)) + ttm3(j) = f * (ttm3(j)-(1.0d0-mscale(kk))*ttm3r(j)) + ttm3i(j) = f * (ttm3i(j)-ttm3ri(j)) + end do + else + do j = 1, 3 + ftm2(j) = f * ftm2(j) + ftm2i(j) = f * (ftm2i(j)-ftm2ri(j)) + ttm2(j) = f * ttm2(j) + ttm2i(j) = f * (ttm2i(j)-ttm2ri(j)) + ttm3(j) = f * ttm3(j) + ttm3i(j) = f * (ttm3i(j)-ttm3ri(j)) + end do + end if + if (ii .eq. kk) then + do j = 1, 3 + ftm2(j) = 0.5d0 * ftm2(j) + ftm2i(j) = 0.5d0 * ftm2i(j) + ttm2(j) = 0.5d0 * ttm2(j) + ttm2i(j) = 0.5d0 * ttm2i(j) + ttm3(j) = 0.5d0 * ttm3(j) + ttm3i(j) = 0.5d0 * ttm3i(j) + end do + end if +c +c increment gradient due to force and torque on first site +c + dem(1,ii) = dem(1,ii) + ftm2(1) + dem(2,ii) = dem(2,ii) + ftm2(2) + dem(3,ii) = dem(3,ii) + ftm2(3) + dep(1,ii) = dep(1,ii) + ftm2i(1) + dep(2,ii) = dep(2,ii) + ftm2i(2) + dep(3,ii) = dep(3,ii) + ftm2i(3) + call torque (i,ttm2,ttm2i,frcxi,frcyi,frczi) +c +c increment gradient due to force and torque on second site +c + dem(1,kk) = dem(1,kk) - ftm2(1) + dem(2,kk) = dem(2,kk) - ftm2(2) + dem(3,kk) = dem(3,kk) - ftm2(3) + dep(1,kk) = dep(1,kk) - ftm2i(1) + dep(2,kk) = dep(2,kk) - ftm2i(2) + dep(3,kk) = dep(3,kk) - ftm2i(3) + call torque (k,ttm3,ttm3i,frcxk,frcyk,frczk) +c +c increment the internal virial tensor components +c + iaz = zaxis(i) + iax = xaxis(i) + iay = yaxis(i) + kaz = zaxis(k) + kax = xaxis(k) + kay = yaxis(k) + if (iaz .eq. 0) iaz = ii + if (iax .eq. 0) iax = ii + if (iay .eq. 0) iay = ii + if (kaz .eq. 0) kaz = kk + if (kax .eq. 0) kax = kk + if (kay .eq. 0) kay = kk + xiz = x(iaz) - x(ii) + yiz = y(iaz) - y(ii) + ziz = z(iaz) - z(ii) + xix = x(iax) - x(ii) + yix = y(iax) - y(ii) + zix = z(iax) - z(ii) + xiy = x(iay) - x(ii) + yiy = y(iay) - y(ii) + ziy = z(iay) - z(ii) + xkz = x(kaz) - x(kk) + ykz = y(kaz) - y(kk) + zkz = z(kaz) - z(kk) + xkx = x(kax) - x(kk) + ykx = y(kax) - y(kk) + zkx = z(kax) - z(kk) + xky = x(kay) - x(kk) + yky = y(kay) - y(kk) + zky = z(kay) - z(kk) + vxx = -xr*(ftm2(1)+ftm2i(1)) + xix*frcxi(1) + & + xiy*frcyi(1) + xiz*frczi(1) + xkx*frcxk(1) + & + xky*frcyk(1) + xkz*frczk(1) + vyx = -yr*(ftm2(1)+ftm2i(1)) + yix*frcxi(1) + & + yiy*frcyi(1) + yiz*frczi(1) + ykx*frcxk(1) + & + yky*frcyk(1) + ykz*frczk(1) + vzx = -zr*(ftm2(1)+ftm2i(1)) + zix*frcxi(1) + & + ziy*frcyi(1) + ziz*frczi(1) + zkx*frcxk(1) + & + zky*frcyk(1) + zkz*frczk(1) + vyy = -yr*(ftm2(2)+ftm2i(2)) + yix*frcxi(2) + & + yiy*frcyi(2) + yiz*frczi(2) + ykx*frcxk(2) + & + yky*frcyk(2) + ykz*frczk(2) + vzy = -zr*(ftm2(2)+ftm2i(2)) + zix*frcxi(2) + & + ziy*frcyi(2) + ziz*frczi(2) + zkx*frcxk(2) + & + zky*frcyk(2) + zkz*frczk(2) + vzz = -zr*(ftm2(3)+ftm2i(3)) + zix*frcxi(3) + & + ziy*frcyi(3) + ziz*frczi(3) + zkx*frcxk(3) + & + zky*frcyk(3) + zkz*frczk(3) + vir(1,1) = vir(1,1) + vxx + vir(2,1) = vir(2,1) + vyx + vir(3,1) = vir(3,1) + vzx + vir(1,2) = vir(1,2) + vyx + vir(2,2) = vir(2,2) + vyy + vir(3,2) = vir(3,2) + vzy + vir(1,3) = vir(1,3) + vzx + vir(2,3) = vir(2,3) + vzy + vir(3,3) = vir(3,3) + vzz + end if + end do + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do + end do + end if +c +c perform deallocation of some local arrays +c + deallocate (mscale) + deallocate (pscale) + deallocate (dscale) + deallocate (uscale) + return + end +c +c +c ################################################################ +c ## ## +c ## subroutine empole1d -- Ewald multipole derivs via list ## +c ## ## +c ################################################################ +c +c +c "empole1d" calculates the multipole and dipole polarization +c energy and derivatives with respect to Cartesian coordinates +c using particle mesh Ewald summation and a neighbor list +c +c + subroutine empole1d + implicit none + include 'sizes.i' + include 'atoms.i' + include 'boxes.i' + include 'chgpot.i' + include 'deriv.i' + include 'energi.i' + include 'ewald.i' + include 'inter.i' + include 'math.i' + include 'mpole.i' + include 'polar.i' + include 'polpot.i' + include 'virial.i' + integer i,j,ii + real*8 e,ei,eintra + real*8 f,term,fterm + real*8 cii,dii,qii,uii + real*8 xd,yd,zd + real*8 xu,yu,zu + real*8 xup,yup,zup + real*8 xq,yq,zq + real*8 xv,yv,zv,vterm + real*8 ci,dix,diy,diz + real*8 uix,uiy,uiz + real*8 qixx,qixy,qixz + real*8 qiyy,qiyz,qizz + real*8 xdfield,xufield + real*8 ydfield,yufield + real*8 zdfield,zufield + real*8 trq(3),trqi(3) + real*8 frcx(3),frcy(3),frcz(3) +c +c +c zero out multipole and polarization energy and derivatives +c + em = 0.0d0 + ep = 0.0d0 + do i = 1, n + do j = 1, 3 + dem(j,i) = 0.0d0 + dep(j,i) = 0.0d0 + end do + end do +c +c set the energy unit conversion factor +c + f = electric / dielec +c +c check the sign of multipole components at chiral sites +c + call chkpole +c +c rotate the multipole components into the global frame +c + call rotpole +c +c compute the induced dipole moment at each atom +c + call induce +c +c compute the reciprocal space part of the Ewald summation +c + call emrecip1 +c +c compute the real space part of the Ewald summation +c + call ereal1d (eintra) +c +c compute the Ewald self-energy term over all the atoms +c + term = 2.0d0 * aewald * aewald + fterm = -f * aewald / sqrtpi + do i = 1, npole + ci = rpole(1,i) + dix = rpole(2,i) + diy = rpole(3,i) + diz = rpole(4,i) + qixx = rpole(5,i) + qixy = rpole(6,i) + qixz = rpole(7,i) + qiyy = rpole(9,i) + qiyz = rpole(10,i) + qizz = rpole(13,i) + uix = uind(1,i) + uiy = uind(2,i) + uiz = uind(3,i) + cii = ci*ci + dii = dix*dix + diy*diy + diz*diz + qii = qixx*qixx + qiyy*qiyy + qizz*qizz + & + 2.0d0*(qixy*qixy+qixz*qixz+qiyz*qiyz) + uii = dix*uix + diy*uiy + diz*uiz + e = fterm * (cii + term*(dii/3.0d0+2.0d0*term*qii/5.0d0)) + ei = fterm * term * uii / 3.0d0 + em = em + e + ep = ep + ei + end do +c +c compute the self-energy torque term due to induced dipole +c + trq(1) = 0.0d0 + trq(2) = 0.0d0 + trq(3) = 0.0d0 + term = (4.0d0/3.0d0) * f * aewald**3 / sqrtpi + do i = 1, npole + dix = rpole(2,i) + diy = rpole(3,i) + diz = rpole(4,i) + uix = 0.5d0 * (uind(1,i)+uinp(1,i)) + uiy = 0.5d0 * (uind(2,i)+uinp(2,i)) + uiz = 0.5d0 * (uind(3,i)+uinp(3,i)) + trqi(1) = term * (diy*uiz-diz*uiy) + trqi(2) = term * (diz*uix-dix*uiz) + trqi(3) = term * (dix*uiy-diy*uix) + call torque (i,trq,trqi,frcx,frcy,frcz) + end do +c +c compute the cell dipole boundary correction term +c + if (boundary .eq. 'VACUUM') then + xd = 0.0d0 + yd = 0.0d0 + zd = 0.0d0 + xu = 0.0d0 + yu = 0.0d0 + zu = 0.0d0 + xup = 0.0d0 + yup = 0.0d0 + zup = 0.0d0 + do i = 1, npole + ii = ipole(i) + xd = xd + rpole(2,i) + rpole(1,i)*x(ii) + yd = yd + rpole(3,i) + rpole(1,i)*y(ii) + zd = zd + rpole(4,i) + rpole(1,i)*z(ii) + xu = xu + uind(1,i) + yu = yu + uind(2,i) + zu = zu + uind(3,i) + xup = xup + uinp(1,i) + yup = yup + uinp(2,i) + zup = zup + uinp(3,i) + end do + term = (2.0d0/3.0d0) * f * (pi/volbox) + em = em + term*(xd*xd+yd*yd+zd*zd) + ep = ep + term*(xd*xu+yd*yu+zd*zu) + do i = 1, npole + ii = ipole(i) + dem(1,ii) = dem(1,ii) + 2.0d0*term*rpole(1,i)*xd + dem(2,ii) = dem(2,ii) + 2.0d0*term*rpole(1,i)*yd + dem(3,ii) = dem(3,ii) + 2.0d0*term*rpole(1,i)*zd + dep(1,ii) = dep(1,ii) + term*rpole(1,i)*(xu+xup) + dep(2,ii) = dep(2,ii) + term*rpole(1,i)*(yu+yup) + dep(3,ii) = dep(3,ii) + term*rpole(1,i)*(zu+zup) + end do + xdfield = -2.0d0 * term * xd + ydfield = -2.0d0 * term * yd + zdfield = -2.0d0 * term * zd + xufield = -term * (xu+xup) + yufield = -term * (yu+yup) + zufield = -term * (zu+zup) + do i = 1, npole + trq(1) = rpole(3,i)*zdfield - rpole(4,i)*ydfield + trq(2) = rpole(4,i)*xdfield - rpole(2,i)*zdfield + trq(3) = rpole(2,i)*ydfield - rpole(3,i)*xdfield + trqi(1) = rpole(3,i)*zufield - rpole(4,i)*yufield + trqi(2) = rpole(4,i)*xufield - rpole(2,i)*zufield + trqi(3) = rpole(2,i)*yufield - rpole(3,i)*xufield + call torque (i,trq,trqi,frcx,frcy,frcz) + end do +c +c boundary correction to virial due to overall cell dipole +c + xd = 0.0d0 + yd = 0.0d0 + zd = 0.0d0 + xq = 0.0d0 + yq = 0.0d0 + zq = 0.0d0 + do i = 1, npole + ii = ipole(i) + xd = xd + rpole(2,i) + yd = yd + rpole(3,i) + zd = zd + rpole(4,i) + xq = xq + rpole(1,i)*x(ii) + yq = yq + rpole(1,i)*y(ii) + zq = zq + rpole(1,i)*z(ii) + end do + xv = xq * (xd+0.5d0*(xu+xup)) + yv = yq * (yd+0.5d0*(yu+yup)) + zv = zq * (zd+0.5d0*(zu+zup)) + vterm = term * (xq*xq + yq*yq + zq*zq + 2.0d0*(xv+yv+zv) + & + xu*xup + yu*yup + zu*zup + & + xd*(xd+xu+xup) + yd*(yd+yu+yup) + & + zd*(zd+zu+zup)) + vir(1,1) = vir(1,1) + 2.0d0*term*(xq*xq+xv) + vterm + vir(2,1) = vir(2,1) + 2.0d0*term*(xq*yq+xv) + vir(3,1) = vir(3,1) + 2.0d0*term*(xq*zq+xv) + vir(1,2) = vir(1,2) + 2.0d0*term*(yq*xq+yv) + vir(2,2) = vir(2,2) + 2.0d0*term*(yq*yq+yv) + vterm + vir(3,2) = vir(3,2) + 2.0d0*term*(yq*zq+yv) + vir(1,3) = vir(1,3) + 2.0d0*term*(zq*xq+zv) + vir(2,3) = vir(2,3) + 2.0d0*term*(zq*yq+zv) + vir(3,3) = vir(3,3) + 2.0d0*term*(zq*zq+zv) + vterm + if (poltyp .eq. 'DIRECT') then + vterm = term * (xu*xup+yu*yup+zu*zup) + vir(1,1) = vir(1,1) + vterm + vir(2,2) = vir(2,2) + vterm + vir(3,3) = vir(3,3) + vterm + end if + end if +c +c intermolecular energy is total minus intramolecular part +c + einter = einter + em + ep - eintra + return + end +c +c +c ################################################################ +c ## ## +c ## subroutine ereal1d -- ewald real space derivs via list ## +c ## ## +c ################################################################ +c +c +c "ereal1d" evaluates the real space portion of the regular Ewald +c summation energy and gradient due to atomic multipole interactions +c and dipole polarizability +c +c + subroutine ereal1d (eintra) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'boxes.i' + include 'cell.i' + include 'chgpot.i' + include 'couple.i' + include 'cutoff.i' + include 'deriv.i' + include 'energi.i' + include 'ewald.i' + include 'math.i' + include 'molcul.i' + include 'mplpot.i' + include 'mpole.i' + include 'neigh.i' + include 'polar.i' + include 'polgrp.i' + include 'polpot.i' + include 'shunt.i' + include 'virial.i' + integer i,j,k + integer ii,kk,kkk + integer iax,iay,iaz + integer kax,kay,kaz + real*8 e,ei,f,bfac + real*8 eintra,erfc + real*8 damp,expdamp + real*8 pdi,pti,pgamma + real*8 scale3,scale5 + real*8 scale7 + real*8 temp3,temp5,temp7 + real*8 dsc3,dsc5,dsc7 + real*8 psc3,psc5,psc7 + real*8 usc3,usc5 + real*8 alsq2,alsq2n + real*8 exp2a,ralpha + real*8 gfd,gfdr + real*8 xr,yr,zr + real*8 xix,yix,zix + real*8 xiy,yiy,ziy + real*8 xiz,yiz,ziz + real*8 xkx,ykx,zkx + real*8 xky,yky,zky + real*8 xkz,ykz,zkz + real*8 r,r2,rr1,rr3 + real*8 rr5,rr7,rr9,rr11 + real*8 erl,erli + real*8 vxx,vyy,vzz + real*8 vyx,vzx,vzy + real*8 emtt,eptt + real*8 frcxi(3),frcxk(3) + real*8 frcyi(3),frcyk(3) + real*8 frczi(3),frczk(3) + real*8 ci,di(3),qi(9) + real*8 ck,dk(3),qk(9) + real*8 fridmp(3),findmp(3) + real*8 ftm2(3),ftm2i(3) + real*8 ftm2r(3),ftm2ri(3) + real*8 ttm2(3),ttm3(3) + real*8 ttm2i(3),ttm3i(3) + real*8 ttm2r(3),ttm3r(3) + real*8 ttm2ri(3),ttm3ri(3) + real*8 fdir(3),dixdk(3) + real*8 dkxui(3),dixuk(3) + real*8 dixukp(3),dkxuip(3) + real*8 uixqkr(3),ukxqir(3) + real*8 uixqkrp(3),ukxqirp(3) + real*8 qiuk(3),qkui(3) + real*8 qiukp(3),qkuip(3) + real*8 rxqiuk(3),rxqkui(3) + real*8 rxqiukp(3),rxqkuip(3) + real*8 qidk(3),qkdi(3) + real*8 qir(3),qkr(3) + real*8 qiqkr(3),qkqir(3) + real*8 qixqk(3),rxqir(3) + real*8 dixr(3),dkxr(3) + real*8 dixqkr(3),dkxqir(3) + real*8 rxqkr(3),qkrxqir(3) + real*8 rxqikr(3),rxqkir(3) + real*8 rxqidk(3),rxqkdi(3) + real*8 ddsc3(3),ddsc5(3) + real*8 ddsc7(3) + real*8 bn(0:5) + real*8 sc(10),gl(0:8) + real*8 sci(8),scip(8) + real*8 gli(7),glip(7) + real*8 gf(7),gfi(6) + real*8 gfr(7),gfri(6) + real*8 gti(6),gtri(6) + real*8 viri(3,3) + real*8, allocatable :: mscale(:) + real*8, allocatable :: pscale(:) + real*8, allocatable :: dscale(:) + real*8, allocatable :: uscale(:) + real*8, allocatable :: demi(:,:) + real*8, allocatable :: demk(:,:) + real*8, allocatable :: depi(:,:) + real*8, allocatable :: depk(:,:) + logical dorl,dorli + character*6 mode + external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm +c +c +c zero out the intramolecular portion of the Ewald energy +c + eintra = 0.0d0 + if (npole .eq. 0) return +c +c perform dynamic allocation of some local arrays +c + allocate (mscale(n)) + allocate (pscale(n)) + allocate (dscale(n)) + allocate (uscale(n)) + allocate (demi(3,n)) + allocate (demk(3,n)) + allocate (depi(3,n)) + allocate (depk(3,n)) +c +c set arrays needed to scale connected atom interactions +c + do i = 1, n + mscale(i) = 1.0d0 + pscale(i) = 1.0d0 + dscale(i) = 1.0d0 + uscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = electric / dielec + mode = 'EWALD' + call switch (mode) +c +c initialize local variables for OpenMP calculation +c + emtt = 0.0d0 + eptt = 0.0d0 + do i = 1, n + do j = 1, 3 + demi(j,i) = 0.0d0 + demk(j,i) = 0.0d0 + depi(j,i) = 0.0d0 + depk(j,i) = 0.0d0 + end do + end do + do i = 1, 3 + do j = 1, 3 + viri(j,i) = 0.0d0 + end do + end do +c +c set OpenMP directives for the major loop structure +c +!$OMP PARALLEL default(shared) firstprivate(f) +!$OMP& private(i,j,k,ii,kk,kkk,e,ei,bfac,damp,expdamp, +!$OMP& pdi,pti,pgamma,scale3,scale5,scale7,temp3,temp5,temp7, +!$OMP& dsc3,dsc5,dsc7,psc3,psc5,psc7,usc3,usc5,alsq2,alsq2n, +!$OMP& exp2a,ralpha,gfd,gfdr,xr,yr,zr,xix,yix,zix, +!$OMP& xiy,yiy,ziy,xiz,yiz,ziz,xkx,ykx,zkx,xky,yky,zky, +!$OMP& xkz,ykz,zkz,r,r2,rr1,rr3,rr5,rr7,rr9,rr11, +!$OMP& erl,erli,vxx,vyy,vzz,vyx,vzx,vzy, +!$OMP& frcxi,frcyi,frczi,frcxk,frcyk,frczk,ci,di,qi,ck,dk,qk, +!$OMP& fridmp,findmp,ftm2,ftm2i,ftm2r,ftm2ri,ttm2,ttm3, +!$OMP& ttm2i,ttm3i,ttm2r,ttm3r,ttm2ri,ttm3ri,fdir,dixdk, +!$OMP& dkxui,dixuk,dixukp,dkxuip,uixqkr,ukxqir,uixqkrp,ukxqirp, +!$OMP& qiuk,qkui,qiukp,qkuip,rxqiuk,rxqkui,rxqiukp,rxqkuip, +!$OMP& qidk,qkdi,qir,qkr,qiqkr,qkqir,qixqk,rxqir,dixr,dkxr, +!$OMP& dixqkr,dkxqir,rxqkr,qkrxqir,rxqikr,rxqkir,rxqidk,rxqkdi, +!$OMP& ddsc3,ddsc5,ddsc7,bn,sc,gl,sci,scip,gli,glip,gf,gfi, +!$OMP& gfr,gfri,gti,gtri,dorl,dorli) +!$OMP& firstprivate(mscale,pscale,dscale,uscale) +!$OMP DO reduction(+:emtt,eptt,viri,demi,depi,demk,depk) +!$OMP& schedule(dynamic) +c +c compute the real space portion of the Ewald summation +c + do i = 1, npole + ii = ipole(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + do k = 1, np11(ii) + if (i14(j,ii) .eq. ip11(k,ii)) + & pscale(i14(j,ii)) = p4scale * p41scale + end do + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, nelst(i) + jqmmm = mod(qmmm(ipole(elst(j,i))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + dscale(ipole(elst(j,i))) = 1.0d0 + uscale(ipole(elst(j,i))) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = mscale(ipole(elst(j,i))) + & * qmmmscale + pscale(ipole(elst(j,i))) = pscale(ipole(elst(j,i))) + & * qmmmscale + dscale(ipole(elst(j,i))) = dscale(ipole(elst(j,i))) + & * qmmmscale + uscale(ipole(elst(j,i))) = uscale(ipole(elst(j,i))) + & * qmmmscale + end if + end do + do kkk = 1, nelst(i) + k = elst(kkk,i) + kk = ipole(k) + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + call image (xr,yr,zr) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c calculate the real space error function terms +c + ralpha = aewald * r + bn(0) = erfc(ralpha) / r + alsq2 = 2.0d0 * aewald**2 + alsq2n = 0.0d0 + if (aewald .gt. 0.0d0) alsq2n = 1.0d0 / (sqrtpi*aewald) + exp2a = exp(-ralpha**2) + do j = 1, 5 + bfac = dble(2*j-1) + alsq2n = alsq2 * alsq2n + bn(j) = (bfac*bn(j-1)+alsq2n*exp2a) / r2 + end do +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + dsc3 = 1.0d0 - scale3*dscale(kk) + dsc5 = 1.0d0 - scale5*dscale(kk) + dsc7 = 1.0d0 - scale7*dscale(kk) + psc3 = 1.0d0 - scale3*pscale(kk) + psc5 = 1.0d0 - scale5*pscale(kk) + psc7 = 1.0d0 - scale7*pscale(kk) + usc3 = 1.0d0 - scale3*uscale(kk) + usc5 = 1.0d0 - scale5*uscale(kk) +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate the scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate the scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c compute the energy contributions for this interaction +c + e = bn(0)*gl(0) + bn(1)*(gl(1)+gl(6)) + & + bn(2)*(gl(2)+gl(7)+gl(8)) + & + bn(3)*(gl(3)+gl(5)) + bn(4)*gl(4) + ei = 0.5d0 * (bn(1)*(gli(1)+gli(6)) + & + bn(2)*(gli(2)+gli(7)) + bn(3)*gli(3)) +c +c get the real energy without any screening function +c + erl = rr1*gl(0) + rr3*(gl(1)+gl(6)) + & + rr5*(gl(2)+gl(7)+gl(8)) + & + rr7*(gl(3)+gl(5)) + rr9*gl(4) + erl = erl * (1.0d0-mscale(kk)) + erli = 0.5d0*(rr3*(gli(1)+gli(6))*psc3 + & + rr5*(gli(2)+gli(7))*psc5 + & + rr7*gli(3)*psc7) + e = e - erl + ei = ei - erli + e = f * e + ei = f * ei + emtt = emtt + e + eptt = eptt + ei +c +c increment the total intramolecular energy; assumes +c intramolecular distances are less than half of cell +c length and less than the ewald cutoff +c + if (molcule(ii) .eq. molcule(kk)) then + eintra = eintra + mscale(kk)*erl*f + eintra = eintra + 0.5d0*pscale(kk) + & * (rr3*(gli(1)+gli(6))*scale3 + & + rr5*(gli(2)+gli(7))*scale5 + & + rr7*gli(3)*scale7) + end if +c +c set flags to compute components without screening +c + dorl = .false. + dorli = .false. + if (mscale(kk) .ne. 1.0d0) dorl = .true. + if (psc3 .ne. 0.0d0) dorli = .true. + if (dsc3 .ne. 0.0d0) dorli = .true. + if (usc3 .ne. 0.0d0) dorli = .true. +c +c zero out force and torque components without screening +c + do j = 1, 3 + ftm2r(j) = 0.0d0 + ftm2ri(j) = 0.0d0 + ttm2r(j) = 0.0d0 + ttm2ri(j) = 0.0d0 + ttm3r(j) = 0.0d0 + ttm3ri(j) = 0.0d0 + end do +c +c get the permanent force with screening +c + gf(1) = bn(1)*gl(0) + bn(2)*(gl(1)+gl(6)) + & + bn(3)*(gl(2)+gl(7)+gl(8)) + & + bn(4)*(gl(3)+gl(5)) + bn(5)*gl(4) + gf(2) = -ck*bn(1) + sc(4)*bn(2) - sc(6)*bn(3) + gf(3) = ci*bn(1) + sc(3)*bn(2) + sc(5)*bn(3) + gf(4) = 2.0d0 * bn(2) + gf(5) = 2.0d0 * (-ck*bn(2)+sc(4)*bn(3)-sc(6)*bn(4)) + gf(6) = 2.0d0 * (-ci*bn(2)-sc(3)*bn(3)-sc(5)*bn(4)) + gf(7) = 4.0d0 * bn(3) + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the permanent force without screening +c + if (dorl) then + gfr(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gfr(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gfr(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gfr(4) = 2.0d0 * rr5 + gfr(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gfr(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gfr(7) = 4.0d0 * rr7 + ftm2r(1) = gfr(1)*xr + gfr(2)*di(1) + gfr(3)*dk(1) + & + gfr(4)*(qkdi(1)-qidk(1)) + & + gfr(5)*qir(1) + gfr(6)*qkr(1) + & + gfr(7)*(qiqkr(1)+qkqir(1)) + ftm2r(2) = gfr(1)*yr + gfr(2)*di(2) + gfr(3)*dk(2) + & + gfr(4)*(qkdi(2)-qidk(2)) + & + gfr(5)*qir(2) + gfr(6)*qkr(2) + & + gfr(7)*(qiqkr(2)+qkqir(2)) + ftm2r(3) = gfr(1)*zr + gfr(2)*di(3) + gfr(3)*dk(3) + & + gfr(4)*(qkdi(3)-qidk(3)) + & + gfr(5)*qir(3) + gfr(6)*qkr(3) + & + gfr(7)*(qiqkr(3)+qkqir(3)) + end if +c +c get the induced force with screening +c + gfi(1) = 0.5d0*bn(2)*(gli(1)+glip(1)+gli(6)+glip(6)) + & + 0.5d0*bn(2)*scip(2) + & + 0.5d0*bn(3)*(gli(2)+glip(2)+gli(7)+glip(7)) + & - 0.5d0*bn(3)*(sci(3)*scip(4)+scip(3)*sci(4)) + & + 0.5d0*bn(4)*(gli(3)+glip(3)) + gfi(2) = -ck*bn(1) + sc(4)*bn(2) - sc(6)*bn(3) + gfi(3) = ci*bn(1) + sc(3)*bn(2) + sc(5)*bn(3) + gfi(4) = 2.0d0 * bn(2) + gfi(5) = bn(3) * (sci(4)+scip(4)) + gfi(6) = -bn(3) * (sci(3)+scip(3)) + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (gfi(2)*(uind(1,i)+uinp(1,i)) + & + bn(2)*(sci(4)*uinp(1,i)+scip(4)*uind(1,i)) + & + gfi(3)*(uind(1,k)+uinp(1,k)) + & + bn(2)*(sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + & + (sci(4)+scip(4))*bn(2)*di(1) + & + (sci(3)+scip(3))*bn(2)*dk(1) + & + gfi(4)*(qkui(1)+qkuip(1)-qiuk(1)-qiukp(1))) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (gfi(2)*(uind(2,i)+uinp(2,i)) + & + bn(2)*(sci(4)*uinp(2,i)+scip(4)*uind(2,i)) + & + gfi(3)*(uind(2,k)+uinp(2,k)) + & + bn(2)*(sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + & + (sci(4)+scip(4))*bn(2)*di(2) + & + (sci(3)+scip(3))*bn(2)*dk(2) + & + gfi(4)*(qkui(2)+qkuip(2)-qiuk(2)-qiukp(2))) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (gfi(2)*(uind(3,i)+uinp(3,i)) + & + bn(2)*(sci(4)*uinp(3,i)+scip(4)*uind(3,i)) + & + gfi(3)*(uind(3,k)+uinp(3,k)) + & + bn(2)*(sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + & + (sci(4)+scip(4))*bn(2)*di(3) + & + (sci(3)+scip(3))*bn(2)*dk(3) + & + gfi(4)*(qkui(3)+qkuip(3)-qiuk(3)-qiukp(3))) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c get the induced force without screening +c + if (dorli) then + gfri(1) = 0.5d0*rr5*((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*usc3) + & + 0.5d0*rr7*((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*usc5) + & + 0.5d0*rr9*(gli(3)*psc7+glip(3)*dsc7) + gfri(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfri(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfri(4) = 2.0d0 * rr5 + gfri(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfri(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) + ftm2ri(1) = gfri(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*usc5*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfri(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfri(5)*qir(1) + gfri(6)*qkr(1) + ftm2ri(2) = gfri(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*usc5*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfri(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfri(5)*qir(2) + gfri(6)*qkr(2) + ftm2ri(3) = gfri(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*usc5*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfri(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfri(5)*qir(3) + gfri(6)*qkr(3) + end if +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify the forces for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (bn(2)*scip(2) + & - bn(3)*(scip(3)*sci(4)+sci(3)*scip(4))) + gfdr = 0.5d0 * (rr5*scip(2)*usc3 + & - rr7*(scip(3)*sci(4) + & +sci(3)*scip(4))*usc5) + ftm2i(1) = ftm2i(1) - gfd*xr - 0.5d0*bn(2)* + & (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + ftm2i(2) = ftm2i(2) - gfd*yr - 0.5d0*bn(2)* + & (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + ftm2i(3) = ftm2i(3) - gfd*zr - 0.5d0*bn(2)* + & (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + fdir(1) = gfdr*xr + 0.5d0*usc5*rr5* + & (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfdr*yr + 0.5d0*usc5*rr5* + & (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfdr*zr + 0.5d0*usc5*rr5* + & (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) + fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) + fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) + fdir(3) + findmp(3) + end if +c +c get the permanent torque with screening +c + ttm2(1) = -bn(1)*dixdk(1) + gf(2)*dixr(1) + & + gf(4)*(dixqkr(1)+dkxqir(1) + & +rxqidk(1)-2.0d0*qixqk(1)) + & - gf(5)*rxqir(1) + & - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -bn(1)*dixdk(2) + gf(2)*dixr(2) + & + gf(4)*(dixqkr(2)+dkxqir(2) + & +rxqidk(2)-2.0d0*qixqk(2)) + & - gf(5)*rxqir(2) + & - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -bn(1)*dixdk(3) + gf(2)*dixr(3) + & + gf(4)*(dixqkr(3)+dkxqir(3) + & +rxqidk(3)-2.0d0*qixqk(3)) + & - gf(5)*rxqir(3) + & - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = bn(1)*dixdk(1) + gf(3)*dkxr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1) + & +rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(6)*rxqkr(1) + & - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = bn(1)*dixdk(2) + gf(3)*dkxr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2) + & +rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(6)*rxqkr(2) + & - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = bn(1)*dixdk(3) + gf(3)*dkxr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3) + & +rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(6)*rxqkr(3) + & - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the permanent torque without screening +c + if (dorl) then + ttm2r(1) = -rr3*dixdk(1) + gfr(2)*dixr(1) + & + gfr(4)*(dixqkr(1)+dkxqir(1) + & +rxqidk(1)-2.0d0*qixqk(1)) + & - gfr(5)*rxqir(1) + & - gfr(7)*(rxqikr(1)+qkrxqir(1)) + ttm2r(2) = -rr3*dixdk(2) + gfr(2)*dixr(2) + & + gfr(4)*(dixqkr(2)+dkxqir(2) + & +rxqidk(2)-2.0d0*qixqk(2)) + & - gfr(5)*rxqir(2) + & - gfr(7)*(rxqikr(2)+qkrxqir(2)) + ttm2r(3) = -rr3*dixdk(3) + gfr(2)*dixr(3) + & + gfr(4)*(dixqkr(3)+dkxqir(3) + & +rxqidk(3)-2.0d0*qixqk(3)) + & - gfr(5)*rxqir(3) + & - gfr(7)*(rxqikr(3)+qkrxqir(3)) + ttm3r(1) = rr3*dixdk(1) + gfr(3)*dkxr(1) + & - gfr(4)*(dixqkr(1)+dkxqir(1) + & +rxqkdi(1)-2.0d0*qixqk(1)) + & - gfr(6)*rxqkr(1) + & - gfr(7)*(rxqkir(1)-qkrxqir(1)) + ttm3r(2) = rr3*dixdk(2) + gfr(3)*dkxr(2) + & - gfr(4)*(dixqkr(2)+dkxqir(2) + & +rxqkdi(2)-2.0d0*qixqk(2)) + & - gfr(6)*rxqkr(2) + & - gfr(7)*(rxqkir(2)-qkrxqir(2)) + ttm3r(3) = rr3*dixdk(3) + gfr(3)*dkxr(3) + & - gfr(4)*(dixqkr(3)+dkxqir(3) + & +rxqkdi(3)-2.0d0*qixqk(3)) + & - gfr(6)*rxqkr(3) + & - gfr(7)*(rxqkir(3)-qkrxqir(3)) + end if +c +c get the induced torque with screening +c + gti(2) = 0.5d0 * bn(2) * (sci(4)+scip(4)) + gti(3) = 0.5d0 * bn(2) * (sci(3)+scip(3)) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) + ttm2i(1) = -0.5d0*bn(1)*(dixuk(1)+dixukp(1)) + & + gti(2)*dixr(1) - gti(5)*rxqir(1) + & + 0.5d0*gti(4)*(ukxqir(1)+rxqiuk(1) + & +ukxqirp(1)+rxqiukp(1)) + ttm2i(2) = -0.5d0*bn(1)*(dixuk(2)+dixukp(2)) + & + gti(2)*dixr(2) - gti(5)*rxqir(2) + & + 0.5d0*gti(4)*(ukxqir(2)+rxqiuk(2) + & +ukxqirp(2)+rxqiukp(2)) + ttm2i(3) = -0.5d0*bn(1)*(dixuk(3)+dixukp(3)) + & + gti(2)*dixr(3) - gti(5)*rxqir(3) + & + 0.5d0*gti(4)*(ukxqir(3)+rxqiuk(3) + & +ukxqirp(3)+rxqiukp(3)) + ttm3i(1) = -0.5d0*bn(1)*(dkxui(1)+dkxuip(1)) + & + gti(3)*dkxr(1) - gti(6)*rxqkr(1) + & - 0.5d0*gti(4)*(uixqkr(1)+rxqkui(1) + & +uixqkrp(1)+rxqkuip(1)) + ttm3i(2) = -0.5d0*bn(1)*(dkxui(2)+dkxuip(2)) + & + gti(3)*dkxr(2) - gti(6)*rxqkr(2) + & - 0.5d0*gti(4)*(uixqkr(2)+rxqkui(2) + & +uixqkrp(2)+rxqkuip(2)) + ttm3i(3) = -0.5d0*bn(1)*(dkxui(3)+dkxuip(3)) + & + gti(3)*dkxr(3) - gti(6)*rxqkr(3) + & - 0.5d0*gti(4)*(uixqkr(3)+rxqkui(3) + & +uixqkrp(3)+rxqkuip(3)) +c +c get the induced torque without screening +c + if (dorli) then + gtri(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gtri(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gtri(4) = gfri(4) + gtri(5) = gfri(5) + gtri(6) = gfri(6) + ttm2ri(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gtri(2)*dixr(1) - gtri(5)*rxqir(1) + & + gtri(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 + ttm2ri(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gtri(2)*dixr(2) - gtri(5)*rxqir(2) + & + gtri(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 + ttm2ri(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gtri(2)*dixr(3) - gtri(5)*rxqir(3) + & + gtri(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 + ttm3ri(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gtri(3)*dkxr(1) - gtri(6)*rxqkr(1) + & - gtri(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 + ttm3ri(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gtri(3)*dkxr(2) - gtri(6)*rxqkr(2) + & - gtri(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 + ttm3ri(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gtri(3)*dkxr(3) - gtri(6)*rxqkr(3) + & - gtri(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 + end if +c +c handle the case where scaling is used +c + do j = 1, 3 + ftm2(j) = f * (ftm2(j)-(1.0d0-mscale(kk))*ftm2r(j)) + ftm2i(j) = f * (ftm2i(j)-ftm2ri(j)) + ttm2(j) = f * (ttm2(j)-(1.0d0-mscale(kk))*ttm2r(j)) + ttm2i(j) = f * (ttm2i(j)-ttm2ri(j)) + ttm3(j) = f * (ttm3(j)-(1.0d0-mscale(kk))*ttm3r(j)) + ttm3i(j) = f * (ttm3i(j)-ttm3ri(j)) + end do +c +c increment gradient due to force and torque on first site +c + demi(1,ii) = demi(1,ii) + ftm2(1) + demi(2,ii) = demi(2,ii) + ftm2(2) + demi(3,ii) = demi(3,ii) + ftm2(3) + depi(1,ii) = depi(1,ii) + ftm2i(1) + depi(2,ii) = depi(2,ii) + ftm2i(2) + depi(3,ii) = depi(3,ii) + ftm2i(3) + call torque3 (i,ttm2,ttm2i,frcxi,frcyi,frczi,demi,depi) +c +c increment gradient due to force and torque on second site +c + demk(1,kk) = demk(1,kk) - ftm2(1) + demk(2,kk) = demk(2,kk) - ftm2(2) + demk(3,kk) = demk(3,kk) - ftm2(3) + depk(1,kk) = depk(1,kk) - ftm2i(1) + depk(2,kk) = depk(2,kk) - ftm2i(2) + depk(3,kk) = depk(3,kk) - ftm2i(3) + call torque3 (k,ttm3,ttm3i,frcxk,frcyk,frczk,demk,depk) +c +c increment the internal virial tensor components +c + iaz = zaxis(i) + iax = xaxis(i) + iay = yaxis(i) + kaz = zaxis(k) + kax = xaxis(k) + kay = yaxis(k) + if (iaz .eq. 0) iaz = ii + if (iax .eq. 0) iax = ii + if (iay .eq. 0) iay = ii + if (kaz .eq. 0) kaz = kk + if (kax .eq. 0) kax = kk + if (kay .eq. 0) kay = kk + xiz = x(iaz) - x(ii) + yiz = y(iaz) - y(ii) + ziz = z(iaz) - z(ii) + xix = x(iax) - x(ii) + yix = y(iax) - y(ii) + zix = z(iax) - z(ii) + xiy = x(iay) - x(ii) + yiy = y(iay) - y(ii) + ziy = z(iay) - z(ii) + xkz = x(kaz) - x(kk) + ykz = y(kaz) - y(kk) + zkz = z(kaz) - z(kk) + xkx = x(kax) - x(kk) + ykx = y(kax) - y(kk) + zkx = z(kax) - z(kk) + xky = x(kay) - x(kk) + yky = y(kay) - y(kk) + zky = z(kay) - z(kk) + vxx = -xr*(ftm2(1)+ftm2i(1)) + xix*frcxi(1) + & + xiy*frcyi(1) + xiz*frczi(1) + xkx*frcxk(1) + & + xky*frcyk(1) + xkz*frczk(1) + vyx = -yr*(ftm2(1)+ftm2i(1)) + yix*frcxi(1) + & + yiy*frcyi(1) + yiz*frczi(1) + ykx*frcxk(1) + & + yky*frcyk(1) + ykz*frczk(1) + vzx = -zr*(ftm2(1)+ftm2i(1)) + zix*frcxi(1) + & + ziy*frcyi(1) + ziz*frczi(1) + zkx*frcxk(1) + & + zky*frcyk(1) + zkz*frczk(1) + vyy = -yr*(ftm2(2)+ftm2i(2)) + yix*frcxi(2) + & + yiy*frcyi(2) + yiz*frczi(2) + ykx*frcxk(2) + & + yky*frcyk(2) + ykz*frczk(2) + vzy = -zr*(ftm2(2)+ftm2i(2)) + zix*frcxi(2) + & + ziy*frcyi(2) + ziz*frczi(2) + zkx*frcxk(2) + & + zky*frcyk(2) + zkz*frczk(2) + vzz = -zr*(ftm2(3)+ftm2i(3)) + zix*frcxi(3) + & + ziy*frcyi(3) + ziz*frczi(3) + zkx*frcxk(3) + & + zky*frcyk(3) + zkz*frczk(3) + viri(1,1) = viri(1,1) + vxx + viri(2,1) = viri(2,1) + vyx + viri(3,1) = viri(3,1) + vzx + viri(1,2) = viri(1,2) + vyx + viri(2,2) = viri(2,2) + vyy + viri(3,2) = viri(3,2) + vzy + viri(1,3) = viri(1,3) + vzx + viri(2,3) = viri(2,3) + vzy + viri(3,3) = viri(3,3) + vzz + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = 1, nelst(i) + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + dscale(ipole(elst(j,i))) = 1.0d0 + uscale(ipole(elst(j,i))) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do + end do +c +c end OpenMP directives for the major loop structure +c +!$OMP END DO +!$OMP END PARALLEL +c +c add local copies to global variables for OpenMP calculation +c + em = em + emtt + ep = ep + eptt + do i = 1, n + do j = 1, 3 + dem(j,i) = dem(j,i) + demi(j,i) + demk(j,i) + dep(j,i) = dep(j,i) + depi(j,i) + depk(j,i) + end do + end do + do i = 1, 3 + do j = 1, 3 + vir(j,i) = vir(j,i) + viri(j,i) + end do + end do +c +c perform deallocation of some local arrays +c + deallocate (mscale) + deallocate (pscale) + deallocate (dscale) + deallocate (uscale) + deallocate (demi) + deallocate (demk) + deallocate (depi) + deallocate (depk) + return + end +c +c +c ################################################################## +c ## ## +c ## subroutine emrecip1 -- mpole Ewald recip energy & derivs ## +c ## ## +c ################################################################## +c +c +c "emrecip1" evaluates the reciprocal space portion of the particle +c mesh Ewald summation energy and gradient due to atomic multipole +c interactions and dipole polarizability +c +c literature reference: +c +c C. Sagui, L. G. Pedersen and T. A. Darden, "Towards an Accurate +c Representation of Electrostatics in Classical Force Fields: +c Efficient Implementation of Multipolar Interactions in +c Biomolecular Simulations", Journal of Chemical Physics, 120, +c 73-87 (2004) +c +c modifications for nonperiodic systems suggested by Tom Darden +c during May 2007 +c +c + subroutine emrecip1 + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'boxes.i' + include 'chgpot.i' + include 'deriv.i' + include 'energi.i' + include 'ewald.i' + include 'math.i' + include 'mpole.i' + include 'pme.i' + include 'polar.i' + include 'polpot.i' + include 'potent.i' + include 'virial.i' + integer i,j,k,ii + integer j1,j2,j3 + integer k1,k2,k3 + integer m1,m2,m3 + integer ntot,nff + integer nf1,nf2,nf3 + integer deriv1(10) + integer deriv2(10) + integer deriv3(10) + real*8 e,eterm + real*8 r1,r2,r3 + real*8 h1,h2,h3 + real*8 f1,f2,f3 + real*8 vxx,vyx,vzx + real*8 vyy,vzy,vzz + real*8 volterm,denom + real*8 hsq,expterm + real*8 term,pterm + real*8 vterm,struc2 + real*8 cphim(4),cphid(4) + real*8 cphip(4) + real*8 a(3,3),ftc(10,10) + real*8, allocatable :: frc(:,:) + real*8, allocatable :: trq(:,:) + real*8, allocatable :: fuind(:,:) + real*8, allocatable :: fuinp(:,:) + real*8, allocatable :: cmp(:,:) + real*8, allocatable :: fmp(:,:) + real*8, allocatable :: fphi(:,:) + real*8, allocatable :: fphid(:,:) + real*8, allocatable :: fphip(:,:) + real*8, allocatable :: fphidp(:,:) + real*8, allocatable :: cphi(:,:) + real*8, allocatable :: qgrip(:,:,:,:) +c +c derivative indices into the fphi and fphidp arrays +c + data deriv1 / 2, 5, 8, 9, 11, 16, 18, 14, 15, 20 / + data deriv2 / 3, 8, 6, 10, 14, 12, 19, 16, 20, 17 / + data deriv3 / 4, 9, 10, 7, 15, 17, 13, 20, 18, 19 / +c +c +c return if the Ewald coefficient is zero +c + if (aewald .lt. 1.0d-6) return +c +c perform dynamic allocation of some local arrays +c + allocate (frc(3,n)) + allocate (trq(3,npole)) + allocate (fuind(3,npole)) + allocate (fuinp(3,npole)) + allocate (cmp(10,npole)) + allocate (fmp(10,npole)) + allocate (fphi(20,npole)) + allocate (fphid(10,npole)) + allocate (fphip(10,npole)) + allocate (fphidp(20,npole)) + allocate (cphi(10,npole)) +c +c zero out the temporary virial accumulation variables +c + vxx = 0.0d0 + vyx = 0.0d0 + vzx = 0.0d0 + vyy = 0.0d0 + vzy = 0.0d0 + vzz = 0.0d0 +c +c copy multipole moments and coordinates to local storage +c + do i = 1, npole + cmp(1,i) = rpole(1,i) + cmp(2,i) = rpole(2,i) + cmp(3,i) = rpole(3,i) + cmp(4,i) = rpole(4,i) + cmp(5,i) = rpole(5,i) + cmp(6,i) = rpole(9,i) + cmp(7,i) = rpole(13,i) + cmp(8,i) = 2.0d0 * rpole(6,i) + cmp(9,i) = 2.0d0 * rpole(7,i) + cmp(10,i) = 2.0d0 * rpole(10,i) + end do +c +c get the fractional to Cartesian transformation matrix +c + call frac_to_cart (ftc) +c +c compute the arrays of B-spline coefficients +c + if (.not. use_polar) then + call bspline_fill + call table_fill + end if +c +c perform dynamic allocation of some local arrays +c + allocate (qgrip(2,nfft1,nfft2,nfft3)) +c +c assign permanent and induced multipoles to PME grid +c and perform the 3-D FFT forward transformation +c + if (use_polar) then + do i = 1, npole + do j = 2, 4 + cmp(j,i) = cmp(j,i) + uinp(j-1,i) + end do + end do + call cmp_to_fmp (cmp,fmp) + call grid_mpole (fmp) + call fftfront + do k = 1, nfft3 + do j = 1, nfft2 + do i = 1, nfft1 + qgrip(1,i,j,k) = qgrid(1,i,j,k) + qgrip(2,i,j,k) = qgrid(2,i,j,k) + end do + end do + end do + do i = 1, npole + do j = 2, 4 + cmp(j,i) = cmp(j,i) + uind(j-1,i) - uinp(j-1,i) + end do + end do + call cmp_to_fmp (cmp,fmp) + call grid_mpole (fmp) + call fftfront + do i = 1, npole + do j = 2, 4 + cmp(j,i) = cmp(j,i) - uind(j-1,i) + end do + end do + else + call cmp_to_fmp (cmp,fmp) + call grid_mpole (fmp) + call fftfront + do k = 1, nfft3 + do j = 1, nfft2 + do i = 1, nfft1 + qgrip(1,i,j,k) = qgrid(1,i,j,k) + qgrip(2,i,j,k) = qgrid(2,i,j,k) + end do + end do + end do + end if +c +c make the scalar summation over reciprocal lattice +c + ntot = nfft1 * nfft2 * nfft3 + pterm = (pi/aewald)**2 + volterm = pi * volbox + nff = nfft1 * nfft2 + nf1 = (nfft1+1) / 2 + nf2 = (nfft2+1) / 2 + nf3 = (nfft3+1) / 2 + do i = 1, ntot-1 + k3 = i/nff + 1 + j = i - (k3-1)*nff + k2 = j/nfft1 + 1 + k1 = j - (k2-1)*nfft1 + 1 + m1 = k1 - 1 + m2 = k2 - 1 + m3 = k3 - 1 + if (k1 .gt. nf1) m1 = m1 - nfft1 + if (k2 .gt. nf2) m2 = m2 - nfft2 + if (k3 .gt. nf3) m3 = m3 - nfft3 + r1 = dble(m1) + r2 = dble(m2) + r3 = dble(m3) + h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3 + h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3 + h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3 + hsq = h1*h1 + h2*h2 + h3*h3 + term = -pterm * hsq + expterm = 0.0d0 + if (term .gt. -50.0d0) then + denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3) + expterm = exp(term) / denom + if (.not. use_bounds) then + expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) + else if (octahedron) then + if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 + end if + struc2 = qgrid(1,k1,k2,k3)*qgrip(1,k1,k2,k3) + & + qgrid(2,k1,k2,k3)*qgrip(2,k1,k2,k3) + eterm = 0.5d0 * electric * expterm * struc2 + vterm = (2.0d0/hsq) * (1.0d0-term) * eterm + vxx = vxx + h1*h1*vterm - eterm + vyx = vyx + h2*h1*vterm + vzx = vzx + h3*h1*vterm + vyy = vyy + h2*h2*vterm - eterm + vzy = vzy + h3*h2*vterm + vzz = vzz + h3*h3*vterm - eterm + end if + qfac(k1,k2,k3) = expterm + end do +c +c assign just the induced multipoles to PME grid +c and perform the 3-D FFT forward transformation +c + if (use_polar .and. poltyp.eq.'DIRECT') then + do i = 1, npole + do j = 1, 10 + cmp(j,i) = 0.0d0 + end do + do j = 2, 4 + cmp(j,i) = uinp(j-1,i) + end do + end do + call cmp_to_fmp (cmp,fmp) + call grid_mpole (fmp) + call fftfront + do k = 1, nfft3 + do j = 1, nfft2 + do i = 1, nfft1 + qgrip(1,i,j,k) = qgrid(1,i,j,k) + qgrip(2,i,j,k) = qgrid(2,i,j,k) + end do + end do + end do + do i = 1, npole + do j = 2, 4 + cmp(j,i) = uind(j-1,i) + end do + end do + call cmp_to_fmp (cmp,fmp) + call grid_mpole (fmp) + call fftfront + do i = 1, npole + cmp(1,i) = rpole(1,i) + cmp(2,i) = rpole(2,i) + cmp(3,i) = rpole(3,i) + cmp(4,i) = rpole(4,i) + cmp(5,i) = rpole(5,i) + cmp(6,i) = rpole(9,i) + cmp(7,i) = rpole(13,i) + cmp(8,i) = 2.0d0 * rpole(6,i) + cmp(9,i) = 2.0d0 * rpole(7,i) + cmp(10,i) = 2.0d0 * rpole(10,i) + end do +c +c make the scalar summation over reciprocal lattice +c + do i = 1, ntot-1 + k3 = i/nff + 1 + j = i - (k3-1)*nff + k2 = j/nfft1 + 1 + k1 = j - (k2-1)*nfft1 + 1 + m1 = k1 - 1 + m2 = k2 - 1 + m3 = k3 - 1 + if (k1 .gt. nf1) m1 = m1 - nfft1 + if (k2 .gt. nf2) m2 = m2 - nfft2 + if (k3 .gt. nf3) m3 = m3 - nfft3 + r1 = dble(m1) + r2 = dble(m2) + r3 = dble(m3) + h1 = recip(1,1)*r1 + recip(1,2)*r2 + recip(1,3)*r3 + h2 = recip(2,1)*r1 + recip(2,2)*r2 + recip(2,3)*r3 + h3 = recip(3,1)*r1 + recip(3,2)*r2 + recip(3,3)*r3 + hsq = h1*h1 + h2*h2 + h3*h3 + term = -pterm * hsq + expterm = 0.0d0 + if (term .gt. -50.0d0) then + denom = volterm*hsq*bsmod1(k1)*bsmod2(k2)*bsmod3(k3) + expterm = exp(term) / denom + if (.not. use_bounds) then + expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) + else if (octahedron) then + if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 + end if + struc2 = qgrid(1,k1,k2,k3)*qgrip(1,k1,k2,k3) + & + qgrid(2,k1,k2,k3)*qgrip(2,k1,k2,k3) + eterm = 0.5d0 * electric * expterm * struc2 + vterm = (2.0d0/hsq) * (1.0d0-term) * eterm + vxx = vxx - h1*h1*vterm + eterm + vyx = vyx - h2*h1*vterm + vzx = vzx - h3*h1*vterm + vyy = vyy - h2*h2*vterm + eterm + vzy = vzy - h3*h2*vterm + vzz = vzz - h3*h3*vterm + eterm + end if + end do + end if +c +c perform deallocation of some local arrays +c + deallocate (qgrip) +c +c transform permanent multipoles without induced dipoles +c + if (use_polar) then + call cmp_to_fmp (cmp,fmp) + call grid_mpole (fmp) + call fftfront + end if +c +c account for the zeroth grid point for a finite system +c + qfac(1,1,1) = 0.0d0 + if (.not. use_bounds) then + expterm = 0.5d0 * pi / xbox + struc2 = qgrid(1,1,1,1)**2 + qgrid(2,1,1,1)**2 + e = 0.5d0 * expterm * struc2 + qfac(1,1,1) = expterm + end if +c +c complete the transformation of the PME grid +c + do k = 1, nfft3 + do j = 1, nfft2 + do i = 1, nfft1 + term = qfac(i,j,k) + qgrid(1,i,j,k) = term * qgrid(1,i,j,k) + qgrid(2,i,j,k) = term * qgrid(2,i,j,k) + end do + end do + end do +c +c perform 3-D FFT backward transform and get potential +c + call fftback + call fphi_mpole (fphi) + do i = 1, npole + do j = 1, 20 + fphi(j,i) = electric * fphi(j,i) + end do + end do + call fphi_to_cphi (fphi,cphi) +c +c increment the permanent multipole energy and gradient +c + e = 0.0d0 + do i = 1, npole + f1 = 0.0d0 + f2 = 0.0d0 + f3 = 0.0d0 + do k = 1, 10 + e = e + fmp(k,i)*fphi(k,i) + f1 = f1 + fmp(k,i)*fphi(deriv1(k),i) + f2 = f2 + fmp(k,i)*fphi(deriv2(k),i) + f3 = f3 + fmp(k,i)*fphi(deriv3(k),i) + end do + f1 = dble(nfft1) * f1 + f2 = dble(nfft2) * f2 + f3 = dble(nfft3) * f3 + frc(1,i) = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3 + frc(2,i) = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3 + frc(3,i) = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3 + end do + e = 0.5d0 * e + em = em + e + do i = 1, npole + ii = ipole(i) + dem(1,ii) = dem(1,ii) + frc(1,i) + dem(2,ii) = dem(2,ii) + frc(2,i) + dem(3,ii) = dem(3,ii) + frc(3,i) + end do +c +c distribute torques into the permanent multipole gradient +c + do i = 1, npole + trq(1,i) = cmp(4,i)*cphi(3,i) - cmp(3,i)*cphi(4,i) + & + 2.0d0*(cmp(7,i)-cmp(6,i))*cphi(10,i) + & + cmp(9,i)*cphi(8,i) + cmp(10,i)*cphi(6,i) + & - cmp(8,i)*cphi(9,i) - cmp(10,i)*cphi(7,i) + trq(2,i) = cmp(2,i)*cphi(4,i) - cmp(4,i)*cphi(2,i) + & + 2.0d0*(cmp(5,i)-cmp(7,i))*cphi(9,i) + & + cmp(8,i)*cphi(10,i) + cmp(9,i)*cphi(7,i) + & - cmp(9,i)*cphi(5,i) - cmp(10,i)*cphi(8,i) + trq(3,i) = cmp(3,i)*cphi(2,i) - cmp(2,i)*cphi(3,i) + & + 2.0d0*(cmp(6,i)-cmp(5,i))*cphi(8,i) + & + cmp(8,i)*cphi(5,i) + cmp(10,i)*cphi(9,i) + & - cmp(8,i)*cphi(6,i) - cmp(9,i)*cphi(10,i) + end do + do i = 1, n + frc(1,i) = 0.0d0 + frc(2,i) = 0.0d0 + frc(3,i) = 0.0d0 + end do + call torque2 (trq,frc) + do i = 1, n + dem(1,i) = dem(1,i) + frc(1,i) + dem(2,i) = dem(2,i) + frc(2,i) + dem(3,i) = dem(3,i) + frc(3,i) + end do +c +c permanent multipole contribution to the internal virial +c + do i = 1, npole + vxx = vxx - cmp(2,i)*cphi(2,i) - 2.0d0*cmp(5,i)*cphi(5,i) + & - cmp(8,i)*cphi(8,i) - cmp(9,i)*cphi(9,i) + vyx = vyx - 0.5d0*(cmp(3,i)*cphi(2,i)+cmp(2,i)*cphi(3,i)) + & - (cmp(5,i)+cmp(6,i))*cphi(8,i) + & - 0.5d0*cmp(8,i)*(cphi(5,i)+cphi(6,i)) + & - 0.5d0*(cmp(9,i)*cphi(10,i)+cmp(10,i)*cphi(9,i)) + vzx = vzx - 0.5d0*(cmp(4,i)*cphi(2,i)+cmp(2,i)*cphi(4,i)) + & - (cmp(5,i)+cmp(7,i))*cphi(9,i) + & - 0.5d0*cmp(9,i)*(cphi(5,i)+cphi(7,i)) + & - 0.5d0*(cmp(8,i)*cphi(10,i)+cmp(10,i)*cphi(8,i)) + vyy = vyy - cmp(3,i)*cphi(3,i) - 2.0d0*cmp(6,i)*cphi(6,i) + & - cmp(8,i)*cphi(8,i) - cmp(10,i)*cphi(10,i) + vzy = vzy - 0.5d0*(cmp(4,i)*cphi(3,i)+cmp(3,i)*cphi(4,i)) + & - (cmp(6,i)+cmp(7,i))*cphi(10,i) + & - 0.5d0*cmp(10,i)*(cphi(6,i)+cphi(7,i)) + & - 0.5d0*(cmp(8,i)*cphi(9,i)+cmp(9,i)*cphi(8,i)) + vzz = vzz - cmp(4,i)*cphi(4,i) - 2.0d0*cmp(7,i)*cphi(7,i) + & - cmp(9,i)*cphi(9,i) - cmp(10,i)*cphi(10,i) + end do +c +c convert Cartesian induced dipoles to fractional coordinates +c + if (use_polar) then + do i = 1, 3 + a(1,i) = dble(nfft1) * recip(i,1) + a(2,i) = dble(nfft2) * recip(i,2) + a(3,i) = dble(nfft3) * recip(i,3) + end do + do i = 1, npole + do j = 1, 3 + fuind(j,i) = a(j,1)*uind(1,i) + a(j,2)*uind(2,i) + & + a(j,3)*uind(3,i) + fuinp(j,i) = a(j,1)*uinp(1,i) + a(j,2)*uinp(2,i) + & + a(j,3)*uinp(3,i) + end do + end do +c +c assign PME grid and perform 3-D FFT forward transform +c + call grid_uind (fuind,fuinp) + call fftfront +c +c account for the zeroth grid point for a finite system +c + if (.not. use_bounds) then + expterm = 0.5d0 * pi / xbox + struc2 = qgrid(1,1,1,1)**2 + qgrid(2,1,1,1)**2 + e = 0.5d0 * expterm * struc2 + end if +c +c complete the transformation of the PME grid +c + do k = 1, nfft3 + do j = 1, nfft2 + do i = 1, nfft1 + term = qfac(i,j,k) + qgrid(1,i,j,k) = term * qgrid(1,i,j,k) + qgrid(2,i,j,k) = term * qgrid(2,i,j,k) + end do + end do + end do +c +c perform 3-D FFT backward transform and get potential +c + call fftback + call fphi_uind (fphid,fphip,fphidp) + do i = 1, npole + do j = 1, 10 + fphid(j,i) = electric * fphid(j,i) + fphip(j,i) = electric * fphip(j,i) + end do + do j = 1, 20 + fphidp(j,i) = electric * fphidp(j,i) + end do + end do +c +c increment the induced dipole energy and gradient +c + e = 0.0d0 + do i = 1, npole + f1 = 0.0d0 + f2 = 0.0d0 + f3 = 0.0d0 + do k = 1, 3 + j1 = deriv1(k+1) + j2 = deriv2(k+1) + j3 = deriv3(k+1) + e = e + fuind(k,i)*fphi(k+1,i) + f1 = f1 + (fuind(k,i)+fuinp(k,i))*fphi(j1,i) + & + fuind(k,i)*fphip(j1,i) + & + fuinp(k,i)*fphid(j1,i) + f2 = f2 + (fuind(k,i)+fuinp(k,i))*fphi(j2,i) + & + fuind(k,i)*fphip(j2,i) + & + fuinp(k,i)*fphid(j2,i) + f3 = f3 + (fuind(k,i)+fuinp(k,i))*fphi(j3,i) + & + fuind(k,i)*fphip(j3,i) + & + fuinp(k,i)*fphid(j3,i) + if (poltyp .eq. 'DIRECT') then + f1 = f1 - fuind(k,i)*fphip(j1,i) + & - fuinp(k,i)*fphid(j1,i) + f2 = f2 - fuind(k,i)*fphip(j2,i) + & - fuinp(k,i)*fphid(j2,i) + f3 = f3 - fuind(k,i)*fphip(j3,i) + & - fuinp(k,i)*fphid(j3,i) + end if + end do + do k = 1, 10 + f1 = f1 + fmp(k,i)*fphidp(deriv1(k),i) + f2 = f2 + fmp(k,i)*fphidp(deriv2(k),i) + f3 = f3 + fmp(k,i)*fphidp(deriv3(k),i) + end do + f1 = 0.5d0 * dble(nfft1) * f1 + f2 = 0.5d0 * dble(nfft2) * f2 + f3 = 0.5d0 * dble(nfft3) * f3 + frc(1,i) = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3 + frc(2,i) = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3 + frc(3,i) = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3 + end do + e = 0.5d0 * e + ep = ep + e + do i = 1, npole + ii = ipole(i) + dep(1,ii) = dep(1,ii) + frc(1,i) + dep(2,ii) = dep(2,ii) + frc(2,i) + dep(3,ii) = dep(3,ii) + frc(3,i) + end do +c +c set the potential to be the induced dipole average +c + do i = 1, npole + do k = 1, 10 + fphidp(k,i) = 0.5d0 * fphidp(k,i) + end do + end do + call fphi_to_cphi (fphidp,cphi) +c +c distribute torques into the induced dipole gradient +c + do i = 1, npole + trq(1,i) = cmp(4,i)*cphi(3,i) - cmp(3,i)*cphi(4,i) + & + 2.0d0*(cmp(7,i)-cmp(6,i))*cphi(10,i) + & + cmp(9,i)*cphi(8,i) + cmp(10,i)*cphi(6,i) + & - cmp(8,i)*cphi(9,i) - cmp(10,i)*cphi(7,i) + trq(2,i) = cmp(2,i)*cphi(4,i) - cmp(4,i)*cphi(2,i) + & + 2.0d0*(cmp(5,i)-cmp(7,i))*cphi(9,i) + & + cmp(8,i)*cphi(10,i) + cmp(9,i)*cphi(7,i) + & - cmp(9,i)*cphi(5,i) - cmp(10,i)*cphi(8,i) + trq(3,i) = cmp(3,i)*cphi(2,i) - cmp(2,i)*cphi(3,i) + & + 2.0d0*(cmp(6,i)-cmp(5,i))*cphi(8,i) + & + cmp(8,i)*cphi(5,i) + cmp(10,i)*cphi(9,i) + & - cmp(8,i)*cphi(6,i) - cmp(9,i)*cphi(10,i) + end do + do i = 1, n + frc(1,i) = 0.0d0 + frc(2,i) = 0.0d0 + frc(3,i) = 0.0d0 + end do + call torque2 (trq,frc) + do i = 1, n + dep(1,i) = dep(1,i) + frc(1,i) + dep(2,i) = dep(2,i) + frc(2,i) + dep(3,i) = dep(3,i) + frc(3,i) + end do +c +c induced dipole contribution to the internal virial +c + do i = 1, npole + do j = 2, 4 + cphim(j) = 0.0d0 + cphid(j) = 0.0d0 + cphip(j) = 0.0d0 + do k = 2, 4 + cphim(j) = cphim(j) + ftc(j,k)*fphi(k,i) + cphid(j) = cphid(j) + ftc(j,k)*fphid(k,i) + cphip(j) = cphip(j) + ftc(j,k)*fphip(k,i) + end do + end do + vxx = vxx - cphi(2,i)*cmp(2,i) + & - 0.5d0*(cphim(2)*(uind(1,i)+uinp(1,i)) + & +cphid(2)*uinp(1,i)+cphip(2)*uind(1,i)) + vyx = vyx - 0.5d0*(cphi(2,i)*cmp(3,i)+cphi(3,i)*cmp(2,i)) + & - 0.25d0*(cphim(2)*(uind(2,i)+uinp(2,i)) + & +cphim(3)*(uind(1,i)+uinp(1,i)) + & +cphid(2)*uinp(2,i)+cphip(2)*uind(2,i) + & +cphid(3)*uinp(1,i)+cphip(3)*uind(1,i)) + vzx = vzx - 0.5d0*(cphi(2,i)*cmp(4,i)+cphi(4,i)*cmp(2,i)) + & - 0.25d0*(cphim(2)*(uind(3,i)+uinp(3,i)) + & +cphim(4)*(uind(1,i)+uinp(1,i)) + & +cphid(2)*uinp(3,i)+cphip(2)*uind(3,i) + & +cphid(4)*uinp(1,i)+cphip(4)*uind(1,i)) + vyy = vyy - cphi(3,i)*cmp(3,i) + & - 0.5d0*(cphim(3)*(uind(2,i)+uinp(2,i)) + & +cphid(3)*uinp(2,i)+cphip(3)*uind(2,i)) + vzy = vzy - 0.5d0*(cphi(3,i)*cmp(4,i)+cphi(4,i)*cmp(3,i)) + & - 0.25d0*(cphim(3)*(uind(3,i)+uinp(3,i)) + & +cphim(4)*(uind(2,i)+uinp(2,i)) + & +cphid(3)*uinp(3,i)+cphip(3)*uind(3,i) + & +cphid(4)*uinp(2,i)+cphip(4)*uind(2,i)) + vzz = vzz - cphi(4,i)*cmp(4,i) + & - 0.5d0*(cphim(4)*(uind(3,i)+uinp(3,i)) + & +cphid(4)*uinp(3,i)+cphip(4)*uind(3,i)) + vxx = vxx - 2.0d0*cmp(5,i)*cphi(5,i) - cmp(8,i)*cphi(8,i) + & - cmp(9,i)*cphi(9,i) + vyx = vyx - (cmp(5,i)+cmp(6,i))*cphi(8,i) + & - 0.5d0*(cmp(8,i)*(cphi(6,i)+cphi(5,i)) + & +cmp(9,i)*cphi(10,i)+cmp(10,i)*cphi(9,i)) + vzx = vzx - (cmp(5,i)+cmp(7,i))*cphi(9,i) + & - 0.5d0*(cmp(9,i)*(cphi(5,i)+cphi(7,i)) + & +cmp(8,i)*cphi(10,i)+cmp(10,i)*cphi(8,i)) + vyy = vyy - 2.0d0*cmp(6,i)*cphi(6,i) - cmp(8,i)*cphi(8,i) + & - cmp(10,i)*cphi(10,i) + vzy = vzy - (cmp(6,i)+cmp(7,i))*cphi(10,i) + & - 0.5d0*(cmp(10,i)*(cphi(6,i)+cphi(7,i)) + & +cmp(8,i)*cphi(9,i)+cmp(9,i)*cphi(8,i)) + vzz = vzz - 2.0d0*cmp(7,i)*cphi(7,i) - cmp(9,i)*cphi(9,i) + & - cmp(10,i)*cphi(10,i) + if (poltyp .eq. 'DIRECT') then + vxx = vxx + 0.5d0*(cphid(2)*uinp(1,i)+cphip(2)*uind(1,i)) + vyx = vyx + 0.25d0*(cphid(2)*uinp(2,i)+cphip(2)*uind(2,i) + & +cphid(3)*uinp(1,i)+cphip(3)*uind(1,i)) + vzx = vzx + 0.25d0*(cphid(2)*uinp(3,i)+cphip(2)*uind(3,i) + & +cphid(4)*uinp(1,i)+cphip(4)*uind(1,i)) + vyy = vyy + 0.5d0*(cphid(3)*uinp(2,i)+cphip(3)*uind(2,i)) + vzy = vzy + 0.25d0*(cphid(3)*uinp(3,i)+cphip(3)*uind(3,i) + & +cphid(4)*uinp(2,i)+cphip(4)*uind(2,i)) + vzz = vzz + 0.5d0*(cphid(4)*uinp(3,i)+cphip(4)*uind(3,i)) + end if + end do + end if +c +c increment the internal virial tensor components +c + vir(1,1) = vir(1,1) + vxx + vir(2,1) = vir(2,1) + vyx + vir(3,1) = vir(3,1) + vzx + vir(1,2) = vir(1,2) + vyx + vir(2,2) = vir(2,2) + vyy + vir(3,2) = vir(3,2) + vzy + vir(1,3) = vir(1,3) + vzx + vir(2,3) = vir(2,3) + vzy + vir(3,3) = vir(3,3) + vzz +c +c perform deallocation of some local arrays +c + deallocate (frc) + deallocate (trq) + deallocate (fuind) + deallocate (fuinp) + deallocate (cmp) + deallocate (fmp) + deallocate (fphi) + deallocate (fphid) + deallocate (fphip) + deallocate (fphidp) + deallocate (cphi) + return + end +c +c +c ##################################################### +c ## ## +c ## subroutine empole1qmmm -- QM/MM corrections ## +c ## ## +c ##################################################### +c +c +c "empole1qmmm" corrects the atomic multipole and dipole +c polarizability interaction energy using a double loop +c only MM-MM, MM-Y and Y-Y interactions must be retained +c +c + subroutine empole1qmmm + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'boxes.i' + include 'cell.i' + include 'chgpot.i' + include 'couple.i' + include 'cutoff.i' + include 'deriv.i' + include 'energi.i' + include 'group.i' + include 'inter.i' + include 'molcul.i' + include 'mplpot.i' + include 'mpole.i' + include 'polar.i' + include 'polgrp.i' + include 'polpot.i' + include 'shunt.i' + include 'usage.i' + include 'virial.i' + integer i,j,k + integer ii,kk,jcell + integer ix,iy,iz + integer kx,ky,kz + integer iax,iay,iaz + integer kax,kay,kaz + real*8 e,ei,f,fgrp,gfd + real*8 damp,expdamp + real*8 pdi,pti,pgamma + real*8 scale3,scale3i + real*8 scale5,scale5i + real*8 scale7,scale7i + real*8 temp3,temp5,temp7 + real*8 psc3,psc5,psc7 + real*8 dsc3,dsc5,dsc7 + real*8 xr,yr,zr + real*8 xix,yix,zix + real*8 xiy,yiy,ziy + real*8 xiz,yiz,ziz + real*8 xkx,ykx,zkx + real*8 xky,yky,zky + real*8 xkz,ykz,zkz + real*8 r,r2,rr1,rr3 + real*8 rr5,rr7,rr9,rr11 + real*8 vxx,vyy,vzz + real*8 vyx,vzx,vzy + real*8 ci,di(3),qi(9) + real*8 ck,dk(3),qk(9) + real*8 frcxi(3),frcxk(3) + real*8 frcyi(3),frcyk(3) + real*8 frczi(3),frczk(3) + real*8 fridmp(3),findmp(3) + real*8 ftm2(3),ftm2i(3) + real*8 ttm2(3),ttm3(3) + real*8 ttm2i(3),ttm3i(3) + real*8 dixdk(3),fdir(3) + real*8 dixuk(3),dkxui(3) + real*8 dixukp(3),dkxuip(3) + real*8 uixqkr(3),ukxqir(3) + real*8 uixqkrp(3),ukxqirp(3) + real*8 qiuk(3),qkui(3) + real*8 qiukp(3),qkuip(3) + real*8 rxqiuk(3),rxqkui(3) + real*8 rxqiukp(3),rxqkuip(3) + real*8 qidk(3),qkdi(3) + real*8 qir(3),qkr(3) + real*8 qiqkr(3),qkqir(3) + real*8 qixqk(3),rxqir(3) + real*8 dixr(3),dkxr(3) + real*8 dixqkr(3),dkxqir(3) + real*8 rxqkr(3),qkrxqir(3) + real*8 rxqikr(3),rxqkir(3) + real*8 rxqidk(3),rxqkdi(3) + real*8 ddsc3(3),ddsc5(3) + real*8 ddsc7(3) + real*8 gl(0:8),gli(7),glip(7) + real*8 sc(10),sci(8),scip(8) + real*8 gf(7),gfi(6),gti(6) + real*8, allocatable :: mscale(:) + real*8, allocatable :: pscale(:) + real*8, allocatable :: dscale(:) + real*8, allocatable :: uscale(:) + logical proceed,usei,usek + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm,kqmmm,ikqmmm +c +c +c check the sign of multipole components at chiral sites +c + call chkpole +c +c rotate the multipole components into the global frame +c + call rotpole +c +c compute the induced dipoles at each polarizable atom +c + call induce +c +c perform dynamic allocation of some local arrays +c + allocate (mscale(n)) + allocate (pscale(n)) + allocate (dscale(n)) + allocate (uscale(n)) +c +c set arrays needed to scale connected atom interactions +c + if (npole .eq. 0) return + do i = 1, n + mscale(i) = 1.0d0 + pscale(i) = 1.0d0 + dscale(i) = 1.0d0 + uscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = electric / dielec + mode = 'MPOLE' + call switch (mode) +c +c set scale factors for permanent multipole and induced terms +c + do i = 1, npole-1 + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + do k = 1, np11(ii) + if (i14(j,ii) .eq. ip11(k,ii)) + & pscale(i14(j,ii)) = p4scale * p41scale + end do + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do + do k = i+1, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) +cqmmm + kqmmm = mod(qmmm(kk),3) + ikqmmm = iqmmm + kqmmm + proceed = .true. + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + if (.not. use_intra) proceed = .true. + if (proceed) proceed = (usei .or. usek) +cqmmm + if (proceed) proceed = (ikqmmm .ne. 0) + if (.not. proceed) goto 10 + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + if (use_bounds) call image (xr,yr,zr) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + scale3i = scale3 * uscale(kk) + scale5i = scale5 * uscale(kk) + scale7i = scale7 * uscale(kk) + dsc3 = scale3 * dscale(kk) + dsc5 = scale5 * dscale(kk) + dsc7 = scale7 * dscale(kk) + psc3 = scale3 * pscale(kk) + psc5 = scale5 * pscale(kk) + psc7 = scale7 * pscale(kk) +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c compute the energy contributions for this interaction +c + e = rr1*gl(0) + rr3*(gl(1)+gl(6)) + & + rr5*(gl(2)+gl(7)+gl(8)) + & + rr7*(gl(3)+gl(5)) + rr9*gl(4) + ei = 0.5d0*(rr3*(gli(1)+gli(6))*psc3 + & + rr5*(gli(2)+gli(7))*psc5 + & + rr7*gli(3)*psc7) + e = f * mscale(kk) * e + ei = f * ei + em = em - e + ep = ep - ei +c +c increment the total intermolecular energy +c + if (molcule(ii) .ne. molcule(kk)) then + einter = einter - e - ei + end if +c +c intermediate variables for the permanent components +c + gf(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gf(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gf(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gf(4) = 2.0d0 * rr5 + gf(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gf(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gf(7) = 4.0d0 * rr7 +c +c intermediate variables for the induced components +c + gfi(1) = 0.5d0 * rr5 * ((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*scale3i) + & + 0.5d0 * rr7 * ((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*scale5i) + & + 0.5d0 * rr9 * (gli(3)*psc7+glip(3)*dsc7) + gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfi(4) = 2.0d0 * rr5 + gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) +c +c get the permanent force components +c + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the induced force components +c + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify induced force for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (rr5*scip(2)*scale3i + & - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i) + temp5 = 0.5d0 * rr5 * scale5i + fdir(1) = gfd*xr + temp5 + & * (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfd*yr + temp5 + & * (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfd*zr + temp5 + & * (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3) + end if +c +c intermediate terms for induced torque on multipoles +c + gti(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gti(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) +c +c get the permanent torque components +c + ttm2(1) = -rr3*dixdk(1) + gf(2)*dixr(1) - gf(5)*rxqir(1) + & + gf(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -rr3*dixdk(2) + gf(2)*dixr(2) - gf(5)*rxqir(2) + & + gf(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -rr3*dixdk(3) + gf(2)*dixr(3) - gf(5)*rxqir(3) + & + gf(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = rr3*dixdk(1) + gf(3)*dkxr(1) - gf(6)*rxqkr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = rr3*dixdk(2) + gf(3)*dkxr(2) - gf(6)*rxqkr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = rr3*dixdk(3) + gf(3)*dkxr(3) - gf(6)*rxqkr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the induced torque components +c + ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1) + ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2) + ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3) + ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1) + ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2) + ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3) +c +c handle the case where scaling is used +c + do j = 1, 3 + ftm2(j) = f * ftm2(j) * mscale(kk) + ftm2i(j) = f * ftm2i(j) + ttm2(j) = f * ttm2(j) * mscale(kk) + ttm2i(j) = f * ttm2i(j) + ttm3(j) = f * ttm3(j) * mscale(kk) + ttm3i(j) = f * ttm3i(j) + end do +c +c increment gradient due to force and torque on first site +c + dem(1,ii) = dem(1,ii) - ftm2(1) + dem(2,ii) = dem(2,ii) - ftm2(2) + dem(3,ii) = dem(3,ii) - ftm2(3) + dep(1,ii) = dep(1,ii) - ftm2i(1) + dep(2,ii) = dep(2,ii) - ftm2i(2) + dep(3,ii) = dep(3,ii) - ftm2i(3) + call torque (i,ttm2,ttm2i,frcxi,frcyi,frczi) +c +c increment gradient due to force and torque on second site +c + dem(1,kk) = dem(1,kk) + ftm2(1) + dem(2,kk) = dem(2,kk) + ftm2(2) + dem(3,kk) = dem(3,kk) + ftm2(3) + dep(1,kk) = dep(1,kk) + ftm2i(1) + dep(2,kk) = dep(2,kk) + ftm2i(2) + dep(3,kk) = dep(3,kk) + ftm2i(3) + call torque (k,ttm3,ttm3i,frcxk,frcyk,frczk) +c +c increment the internal virial tensor components +c + iaz = iz + iax = ix + iay = iy + kaz = kz + kax = kx + kay = ky + if (iaz .eq. 0) iaz = ii + if (iax .eq. 0) iax = ii + if (iay .eq. 0) iay = ii + if (kaz .eq. 0) kaz = kk + if (kax .eq. 0) kax = kk + if (kay .eq. 0) kay = kk + xiz = x(iaz) - x(ii) + yiz = y(iaz) - y(ii) + ziz = z(iaz) - z(ii) + xix = x(iax) - x(ii) + yix = y(iax) - y(ii) + zix = z(iax) - z(ii) + xiy = x(iay) - x(ii) + yiy = y(iay) - y(ii) + ziy = z(iay) - z(ii) + xkz = x(kaz) - x(kk) + ykz = y(kaz) - y(kk) + zkz = z(kaz) - z(kk) + xkx = x(kax) - x(kk) + ykx = y(kax) - y(kk) + zkx = z(kax) - z(kk) + xky = x(kay) - x(kk) + yky = y(kay) - y(kk) + zky = z(kay) - z(kk) + vxx = -xr*(ftm2(1)+ftm2i(1)) + xix*frcxi(1) + & + xiy*frcyi(1) + xiz*frczi(1) + xkx*frcxk(1) + & + xky*frcyk(1) + xkz*frczk(1) + vyx = -yr*(ftm2(1)+ftm2i(1)) + yix*frcxi(1) + & + yiy*frcyi(1) + yiz*frczi(1) + ykx*frcxk(1) + & + yky*frcyk(1) + ykz*frczk(1) + vzx = -zr*(ftm2(1)+ftm2i(1)) + zix*frcxi(1) + & + ziy*frcyi(1) + ziz*frczi(1) + zkx*frcxk(1) + & + zky*frcyk(1) + zkz*frczk(1) + vyy = -yr*(ftm2(2)+ftm2i(2)) + yix*frcxi(2) + & + yiy*frcyi(2) + yiz*frczi(2) + ykx*frcxk(2) + & + yky*frcyk(2) + ykz*frczk(2) + vzy = -zr*(ftm2(2)+ftm2i(2)) + zix*frcxi(2) + & + ziy*frcyi(2) + ziz*frczi(2) + zkx*frcxk(2) + & + zky*frcyk(2) + zkz*frczk(2) + vzz = -zr*(ftm2(3)+ftm2i(3)) + zix*frcxi(3) + & + ziy*frcyi(3) + ziz*frczi(3) + zkx*frcxk(3) + & + zky*frcyk(3) + zkz*frczk(3) + vir(1,1) = vir(1,1) - vxx + vir(2,1) = vir(2,1) - vyx + vir(3,1) = vir(3,1) - vzx + vir(1,2) = vir(1,2) - vyx + vir(2,2) = vir(2,2) - vyy + vir(3,2) = vir(3,2) - vzy + vir(1,3) = vir(1,3) - vzx + vir(2,3) = vir(2,3) - vzy + vir(3,3) = vir(3,3) - vzz + end if + 10 continue + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (use_replica) then +c +c calculate interaction with other unit cells +c + do i = 1, npole + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + if (iqmmm .eq. 0) goto 99 + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do + do k = i, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + proceed = .true. + if (proceed) proceed = (usei .or. usek) + if (.not. proceed) goto 20 + do jcell = 1, ncell + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + call imager (xr,yr,zr,jcell) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + scale3i = scale3 + scale5i = scale5 + scale7i = scale7 + dsc3 = scale3 + dsc5 = scale5 + dsc7 = scale7 + psc3 = scale3 + psc5 = scale5 + psc7 = scale7 + if (use_polymer) then + if (r2 .le. polycut2) then + scale3i = scale3i * uscale(kk) + scale5i = scale5i * uscale(kk) + scale7i = scale7i * uscale(kk) + dsc3 = dsc3 * dscale(kk) + dsc5 = dsc5 * dscale(kk) + dsc7 = dsc7 * dscale(kk) + psc3 = psc3 * pscale(kk) + psc5 = psc5 * pscale(kk) + psc7 = psc7 * pscale(kk) + end if + end if +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c compute the energy contributions for this interaction +c + e = rr1*gl(0) + rr3*(gl(1)+gl(6)) + & + rr5*(gl(2)+gl(7)+gl(8)) + & + rr7*(gl(3)+gl(5)) + rr9*gl(4) + ei = 0.5d0*(rr3*(gli(1)+gli(6))*psc3 + & + rr5*(gli(2)+gli(7))*psc5 + & + rr7*gli(3)*psc7) + e = f * e + ei = f * ei + if (use_polymer) then + if (r2 .le. polycut2) then + e = e * mscale(kk) + end if + end if + if (use_group) then + e = e * fgrp +c ei = ei * fgrp + end if + if (ii .eq. kk) then + e = 0.5d0 * e + ei = 0.5d0 * ei + end if + em = em - e + ep = ep - ei +c +c increment the total intermolecular energy +c + if (molcule(ii) .ne. molcule(kk)) then + einter = einter - e - ei + end if +c +c intermediate variables for the permanent components +c + gf(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gf(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gf(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gf(4) = 2.0d0 * rr5 + gf(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gf(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gf(7) = 4.0d0 * rr7 +c +c intermediate variables for the induced components +c + gfi(1) = 0.5d0 * rr5 * ((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*scale3i) + & + 0.5d0 * rr7 * ((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*scale5i) + & + 0.5d0 * rr9 * (gli(3)*psc7+glip(3)*dsc7) + gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfi(4) = 2.0d0 * rr5 + gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) +c +c get the permanent force components +c + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the induced force components +c + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify induced force for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (rr5*scip(2)*scale3i + & - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i) + temp5 = 0.5d0 * rr5 * scale5i + fdir(1) = gfd*xr + temp5 + & * (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfd*yr + temp5 + & * (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfd*zr + temp5 + & * (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3) + end if +c +c intermediate terms for induced torque on multipoles +c + gti(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gti(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) +c +c get the permanent torque components +c + ttm2(1) = -rr3*dixdk(1) + gf(2)*dixr(1) - gf(5)*rxqir(1) + & + gf(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -rr3*dixdk(2) + gf(2)*dixr(2) - gf(5)*rxqir(2) + & + gf(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -rr3*dixdk(3) + gf(2)*dixr(3) - gf(5)*rxqir(3) + & + gf(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = rr3*dixdk(1) + gf(3)*dkxr(1) - gf(6)*rxqkr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = rr3*dixdk(2) + gf(3)*dkxr(2) - gf(6)*rxqkr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = rr3*dixdk(3) + gf(3)*dkxr(3) - gf(6)*rxqkr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the induced torque components +c + ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1) + ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2) + ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3) + ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1) + ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2) + ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3) +c +c handle the case where scaling is used +c + do j = 1, 3 + ftm2(j) = f * ftm2(j) + ftm2i(j) = f * ftm2i(j) + ttm2(j) = f * ttm2(j) + ttm2i(j) = f * ttm2i(j) + ttm3(j) = f * ttm3(j) + ttm3i(j) = f * ttm3i(j) + end do + if (use_polymer) then + if (r2 .le. polycut2) then + do j = 1, 3 + ftm2(j) = ftm2(j) * mscale(kk) + ttm2(j) = ttm2(j) * mscale(kk) + ttm3(j) = ttm3(j) * mscale(kk) + end do + end if + end if + if (use_group) then + do j = 1, 3 + ftm2(j) = ftm2(j) * fgrp + ttm2(j) = ttm2(j) * fgrp + ttm3(j) = ttm3(j) * fgrp +c ftm2i(j) = ftm2i(j) * fgrp +c ttm2i(j) = ttm2i(j) * fgrp +c ttm3i(j) = ttm3i(j) * fgrp + end do + end if + if (ii .eq. kk) then + do j = 1, 3 + ftm2(j) = 0.5d0 * ftm2(j) + ftm2i(j) = 0.5d0 * ftm2i(j) + ttm2(j) = 0.5d0 * ttm2(j) + ttm2i(j) = 0.5d0 * ttm2i(j) + ttm3(j) = 0.5d0 * ttm3(j) + ttm3i(j) = 0.5d0 * ttm3i(j) + end do + end if +c +c increment gradient due to force and torque on first site +c + dem(1,ii) = dem(1,ii) - ftm2(1) + dem(2,ii) = dem(2,ii) - ftm2(2) + dem(3,ii) = dem(3,ii) - ftm2(3) + dep(1,ii) = dep(1,ii) - ftm2i(1) + dep(2,ii) = dep(2,ii) - ftm2i(2) + dep(3,ii) = dep(3,ii) - ftm2i(3) + call torque (i,ttm2,ttm2i,frcxi,frcyi,frczi) +c +c increment gradient due to force and torque on second site +c + dem(1,kk) = dem(1,kk) + ftm2(1) + dem(2,kk) = dem(2,kk) + ftm2(2) + dem(3,kk) = dem(3,kk) + ftm2(3) + dep(1,kk) = dep(1,kk) + ftm2i(1) + dep(2,kk) = dep(2,kk) + ftm2i(2) + dep(3,kk) = dep(3,kk) + ftm2i(3) + call torque (k,ttm3,ttm3i,frcxk,frcyk,frczk) +c +c increment the internal virial tensor components +c + iaz = iz + iax = ix + iay = iy + kaz = kz + kax = kx + kay = ky + if (iaz .eq. 0) iaz = ii + if (iax .eq. 0) iax = ii + if (iay .eq. 0) iay = ii + if (kaz .eq. 0) kaz = kk + if (kax .eq. 0) kax = kk + if (kay .eq. 0) kay = kk + xiz = x(iaz) - x(ii) + yiz = y(iaz) - y(ii) + ziz = z(iaz) - z(ii) + xix = x(iax) - x(ii) + yix = y(iax) - y(ii) + zix = z(iax) - z(ii) + xiy = x(iay) - x(ii) + yiy = y(iay) - y(ii) + ziy = z(iay) - z(ii) + xkz = x(kaz) - x(kk) + ykz = y(kaz) - y(kk) + zkz = z(kaz) - z(kk) + xkx = x(kax) - x(kk) + ykx = y(kax) - y(kk) + zkx = z(kax) - z(kk) + xky = x(kay) - x(kk) + yky = y(kay) - y(kk) + zky = z(kay) - z(kk) + vxx = -xr*(ftm2(1)+ftm2i(1)) + xix*frcxi(1) + & + xiy*frcyi(1) + xiz*frczi(1) + xkx*frcxk(1) + & + xky*frcyk(1) + xkz*frczk(1) + vyx = -yr*(ftm2(1)+ftm2i(1)) + yix*frcxi(1) + & + yiy*frcyi(1) + yiz*frczi(1) + ykx*frcxk(1) + & + yky*frcyk(1) + ykz*frczk(1) + vzx = -zr*(ftm2(1)+ftm2i(1)) + zix*frcxi(1) + & + ziy*frcyi(1) + ziz*frczi(1) + zkx*frcxk(1) + & + zky*frcyk(1) + zkz*frczk(1) + vyy = -yr*(ftm2(2)+ftm2i(2)) + yix*frcxi(2) + & + yiy*frcyi(2) + yiz*frczi(2) + ykx*frcxk(2) + & + yky*frcyk(2) + ykz*frczk(2) + vzy = -zr*(ftm2(2)+ftm2i(2)) + zix*frcxi(2) + & + ziy*frcyi(2) + ziz*frczi(2) + zkx*frcxk(2) + & + zky*frcyk(2) + zkz*frczk(2) + vzz = -zr*(ftm2(3)+ftm2i(3)) + zix*frcxi(3) + & + ziy*frcyi(3) + ziz*frczi(3) + zkx*frcxk(3) + & + zky*frcyk(3) + zkz*frczk(3) + vir(1,1) = vir(1,1) - vxx + vir(2,1) = vir(2,1) - vyx + vir(3,1) = vir(3,1) - vzx + vir(1,2) = vir(1,2) - vyx + vir(2,2) = vir(2,2) - vyy + vir(3,2) = vir(3,2) - vzy + vir(1,3) = vir(1,3) - vzx + vir(2,3) = vir(2,3) - vzy + vir(3,3) = vir(3,3) - vzz + end if + end do + 20 continue + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do +cqmmm + 99 continue + end do + end if +c +c perform deallocation of some local arrays +c + deallocate (mscale) + deallocate (pscale) + deallocate (dscale) + deallocate (uscale) + return + end + diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/elecpol1.f 6.2.06/source/elecpol1.f --- 6.2.06/source_orig/elecpol1.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/elecpol1.f 2013-10-21 18:20:56.685885295 +0200 @@ -0,0 +1,921 @@ +cqmmm +c "elecpol1" calculates the electrostatic potential (in e/A), +c field (in e/A^2) and field derivatives (in e/A^3) +c on site i (either HLA, QM or Y) due to all MM +c permanent and induced multipoles +c ** in the case of ESPF at order 1 ** +c ** field derivatives are numerically derived ** +c + subroutine elecpol (i,QMMM_EP) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'deriv.i' + include 'hessn.i' + include 'mpole.i' + include 'potent.i' + integer i,j,k + integer nlist + integer, allocatable :: list(:) + real*8 eps,old + real*8, allocatable :: d0(:,:) + logical biglist + logical reinduce + logical twosided +c +c +c set the default stepsize and flag for induced dipoles +c + eps = 1.0d-5 + biglist = .false. + reinduce = .false. + twosided = .false. + if (n .le. 100) then + biglist = .true. + reinduce = .true. + twosided = .true. + end if +c +c perform dynamic allocation of some local arrays +c + allocate (list(npole)) + allocate (d0(3,n)) +c +c find the multipole definitions involving the current atom; +c results in a faster but approximate Hessian calculation +c + nlist = 0 + do k = 1, npole + if (biglist .or. ipole(k).eq.i .or. zaxis(k).eq.i + & .or. xaxis(k).eq.i .or. yaxis(k).eq.i) then + nlist = nlist + 1 + list(nlist) = k + end if + end do +c +c get multipole first derivatives for the base structure +c + if (.not. twosided) then + call empole2a (nlist,list,reinduce) + do k = 1, n + do j = 1, 3 + d0(j,k) = dem(j,k) + dep(j,k) + end do + end do + end if +c +c find numerical x-components via perturbed structures +c + old = x(i) + if (twosided) then + x(i) = x(i) - 0.5d0*eps + call empole2a (nlist,list,reinduce) + do k = 1, n + do j = 1, 3 + d0(j,k) = dem(j,k) + dep(j,k) + end do + end do + end if + x(i) = x(i) + eps + call empole2a (nlist,list,reinduce) + x(i) = old + do k = 1, n + do j = 1, 3 + hessx(j,k) = hessx(j,k) + (dem(j,k)+dep(j,k)-d0(j,k))/eps + end do + end do +c +c find numerical y-components via perturbed structures +c + old = y(i) + if (twosided) then + y(i) = y(i) - 0.5d0*eps + call empole2a (nlist,list,reinduce) + do k = 1, n + do j = 1, 3 + d0(j,k) = dem(j,k) + dep(j,k) + end do + end do + end if + y(i) = y(i) + eps + call empole2a (nlist,list,reinduce) + y(i) = old + do k = 1, n + do j = 1, 3 + hessy(j,k) = hessy(j,k) + (dem(j,k)+dep(j,k)-d0(j,k))/eps + end do + end do +c +c find numerical z-components via perturbed structures +c + old = z(i) + if (twosided) then + z(i) = z(i) - 0.5d0*eps + call empole2a (nlist,list,reinduce) + do k = 1, n + do j = 1, 3 + d0(j,k) = dem(j,k) + dep(j,k) + end do + end do + end if + z(i) = z(i) + eps + call empole2a (nlist,list,reinduce) + z(i) = old + do k = 1, n + do j = 1, 3 + hessz(j,k) = hessz(j,k) + (dem(j,k)+dep(j,k)-d0(j,k))/eps + end do + end do +c +c perform deallocation of some local arrays +c + deallocate (list) + deallocate (d0) + return + end +c +c +c ################################################################# +c ## ## +c ## subroutine empole2a -- mpole & polar Hessian; numerical ## +c ## ## +c ################################################################# +c +c +c "empole2a" computes multipole and dipole polarization first +c derivatives for a single atom with respect to Cartesian +c coordinates; used to get finite difference second derivatives +c +c + subroutine empole2a (nlist,list,reinduce) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'boxes.i' + include 'chgpot.i' + include 'couple.i' + include 'cutoff.i' + include 'deriv.i' + include 'group.i' + include 'molcul.i' + include 'mplpot.i' + include 'mpole.i' + include 'polar.i' + include 'polgrp.i' + include 'polpot.i' + include 'potent.i' + include 'shunt.i' + include 'usage.i' + integer i,j,k,nlist + integer ii,iii,kk + integer ix,iy,iz + integer kx,ky,kz + integer list(*) + real*8 f,fgrp,gfd + real*8 damp,expdamp + real*8 pdi,pti,pgamma + real*8 scale3,scale3i + real*8 scale5,scale5i + real*8 scale7,scale7i + real*8 temp3,temp5,temp7 + real*8 psc3,psc5,psc7 + real*8 dsc3,dsc5,dsc7 + real*8 xr,yr,zr + real*8 r,r2,rr1,rr3 + real*8 rr5,rr7,rr9,rr11 + real*8 ci,di(3),qi(9) + real*8 ck,dk(3),qk(9) + real*8 frcxi(3),frcxk(3) + real*8 frcyi(3),frcyk(3) + real*8 frczi(3),frczk(3) + real*8 fridmp(3),findmp(3) + real*8 ftm2(3),ftm2i(3) + real*8 ttm2(3),ttm3(3) + real*8 ttm2i(3),ttm3i(3) + real*8 dixdk(3),fdir(3) + real*8 dixuk(3),dkxui(3) + real*8 dixukp(3),dkxuip(3) + real*8 uixqkr(3),ukxqir(3) + real*8 uixqkrp(3),ukxqirp(3) + real*8 qiuk(3),qkui(3) + real*8 qiukp(3),qkuip(3) + real*8 rxqiuk(3),rxqkui(3) + real*8 rxqiukp(3),rxqkuip(3) + real*8 qidk(3),qkdi(3) + real*8 qir(3),qkr(3) + real*8 qiqkr(3),qkqir(3) + real*8 qixqk(3),rxqir(3) + real*8 dixr(3),dkxr(3) + real*8 dixqkr(3),dkxqir(3) + real*8 rxqkr(3),qkrxqir(3) + real*8 rxqikr(3),rxqkir(3) + real*8 rxqidk(3),rxqkdi(3) + real*8 ddsc3(3),ddsc5(3) + real*8 ddsc7(3) + real*8 gl(0:8),gli(7),glip(7) + real*8 sc(10),sci(8),scip(8) + real*8 gf(7),gfi(6),gti(6) + real*8, allocatable :: mscale(:) + real*8, allocatable :: pscale(:) + real*8, allocatable :: dscale(:) + real*8, allocatable :: uscale(:) + logical proceed + logical usei,usek + logical reinduce + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm,kqmmm,ikqmmm +c +c +c zero out the multipole and polarization first derivatives +c + do i = 1, n + do j = 1, 3 + dem(j,i) = 0.0d0 + dep(j,i) = 0.0d0 + end do + end do + if (nlist .eq. 0) return +c +c perform dynamic allocation of some local arrays +c + allocate (mscale(n)) + allocate (pscale(n)) + allocate (dscale(n)) + allocate (uscale(n)) +c +c set arrays needed to scale connected atom interactions +c + do i = 1, n + mscale(i) = 1.0d0 + pscale(i) = 1.0d0 + dscale(i) = 1.0d0 + uscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = electric / dielec + mode = 'MPOLE' + call switch (mode) +c +c check the sign of multipole components at chiral sites +c + if (reinduce) then + call chkpole +c +c rotate the multipole components into the global frame +c + call rotpole +c +c compute the induced dipoles at each polarizable atom +c + call induce + end if +c +c set scale factors for permanent multipole and induced terms +c + do iii = 1, nlist + i = list(iii) + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + do k = 1, np11(ii) + if (i14(j,ii) .eq. ip11(k,ii)) + & pscale(i14(j,ii)) = p4scale * p41scale + end do + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do + do k = i+1, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) +cqmmm + kqmmm = mod(qmmm(kk),3) + ikqmmm = iqmmm + kqmmm + proceed = .true. + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + if (.not. use_intra) proceed = .true. + if (proceed) proceed = (usei .or. usek) +cqmmm + if (proceed) proceed = (ikqmmm .eq. 0) + if (.not. proceed) goto 10 + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + if (use_bounds) call image (xr,yr,zr) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + scale3i = scale3 * uscale(kk) + scale5i = scale5 * uscale(kk) + scale7i = scale7 * uscale(kk) + dsc3 = scale3 * dscale(kk) + dsc5 = scale5 * dscale(kk) + dsc7 = scale7 * dscale(kk) + psc3 = scale3 * pscale(kk) + psc5 = scale5 * pscale(kk) + psc7 = scale7 * pscale(kk) +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c intermediate variables for the permanent components +c + gf(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gf(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gf(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gf(4) = 2.0d0 * rr5 + gf(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gf(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gf(7) = 4.0d0 * rr7 +c +c intermediate variables for the induced components +c + gfi(1) = 0.5d0 * rr5 * ((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*scale3i) + & + 0.5d0 * rr7 * ((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*scale5i) + & + 0.5d0 * rr9 * (gli(3)*psc7+glip(3)*dsc7) + gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfi(4) = 2.0d0 * rr5 + gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) +c +c get the permanent force components +c + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the induced force components +c + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify induced force for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (rr5*scip(2)*scale3i + & - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i) + temp5 = 0.5d0 * rr5 * scale5i + fdir(1) = gfd*xr + temp5 + & * (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfd*yr + temp5 + & * (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfd*zr + temp5 + & * (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3) + end if +c +c intermediate variables for induced torque components +c + gti(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gti(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) +c +c get the permanent torque components +c + ttm2(1) = -rr3*dixdk(1) + gf(2)*dixr(1) - gf(5)*rxqir(1) + & + gf(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -rr3*dixdk(2) + gf(2)*dixr(2) - gf(5)*rxqir(2) + & + gf(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -rr3*dixdk(3) + gf(2)*dixr(3) - gf(5)*rxqir(3) + & + gf(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = rr3*dixdk(1) + gf(3)*dkxr(1) - gf(6)*rxqkr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = rr3*dixdk(2) + gf(3)*dkxr(2) - gf(6)*rxqkr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = rr3*dixdk(3) + gf(3)*dkxr(3) - gf(6)*rxqkr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the induced torque components +c + ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1) + ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2) + ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3) + ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1) + ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2) + ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3) +c +c handle the case where scaling is used +c + do j = 1, 3 + ftm2(j) = f * ftm2(j) * mscale(kk) + ftm2i(j) = f * ftm2i(j) + ttm2(j) = f * ttm2(j) * mscale(kk) + ttm2i(j) = f * ttm2i(j) + ttm3(j) = f * ttm3(j) * mscale(kk) + ttm3i(j) = f * ttm3i(j) + end do +c +c increment gradient due to force and torque on first site +c + dem(1,ii) = dem(1,ii) + ftm2(1) + dem(2,ii) = dem(2,ii) + ftm2(2) + dem(3,ii) = dem(3,ii) + ftm2(3) + dep(1,ii) = dep(1,ii) + ftm2i(1) + dep(2,ii) = dep(2,ii) + ftm2i(2) + dep(3,ii) = dep(3,ii) + ftm2i(3) + call torque (i,ttm2,ttm2i,frcxi,frcyi,frczi) +c +c increment gradient due to force and torque on second site +c + dem(1,kk) = dem(1,kk) - ftm2(1) + dem(2,kk) = dem(2,kk) - ftm2(2) + dem(3,kk) = dem(3,kk) - ftm2(3) + dep(1,kk) = dep(1,kk) - ftm2i(1) + dep(2,kk) = dep(2,kk) - ftm2i(2) + dep(3,kk) = dep(3,kk) - ftm2i(3) + call torque (k,ttm3,ttm3i,frcxk,frcyk,frczk) + end if + 10 continue + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do + end do +c +c perform deallocation of some local arrays +c + deallocate (mscale) + deallocate (pscale) + deallocate (dscale) + deallocate (uscale) +c +c zero out the derivatives for terms that are not used +c + if (.not. use_mpole) then + do i = 1, n + do j = 1, 3 + dem(j,i) = 0.0d0 + end do + end do + end if + if (.not. use_polar) then + do i = 1, n + do j = 1, 3 + dep(j,i) = 0.0d0 + end do + end do + end if + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/elecpot.f 6.2.06/source/elecpot.f --- 6.2.06/source_orig/elecpot.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/elecpot.f 2013-11-30 10:24:44.206831059 +0100 @@ -0,0 +1,858 @@ +cqmmm +c "elecpot" calculates the electrostatic potential (in e/A), +c field (in e/A^2) and field derivatives (in e/A^3) +c on site i (either HLA, QM or Y) due to all MM point charges +c + subroutine elecpot (i,nComp,QMMM_EP) + implicit none + include 'sizes.i' + include 'cutoff.i' + include 'warp.i' + integer i, nComp + real*8 QMMM_EP(nComp) +c +c +c choose the method for summing over pairwise interactions +c + if (use_smooth) then + call elecpotc (i,nComp,QMMM_EP) + else if (use_ewald) then + call elecpotb (i,nComp,QMMM_EP) + else + call elecpota (i,nComp,QMMM_EP) + end if + return + end +c +c +c "elecpota" calculates elecpot using a pairwise double loop +c +c + subroutine elecpota (i,nComp,QMMM_EP) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'cell.i' + include 'charge.i' + include 'chgpot.i' + include 'couple.i' + include 'group.i' + include 'hessn.i' + include 'shunt.i' + integer i,j,k,kk + integer in,kn,jcell + real*8 e,de,d2e + real*8 fi,fik,fgrp + real*8 d2edx,d2edy,d2edz + real*8 xi,yi,zi + real*8 xr,yr,zr + real*8 shift,taper,trans + real*8 dtaper,dtrans + real*8 d2taper,d2trans + real*8 r,rb,rb2 + real*8 r2,r3,r4 + real*8 r5,r6,r7 + real*8 term(3,3) + real*8, allocatable :: cscale(:) + logical proceed + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,nComp + real*8 QMMM_EP(nComp) +c +c +c initialization +c + do k = 1, nComp + QMMM_EP(k) = 0.0d0 + end do + fi = 1.0d0 / dielec +c +c place a charge +1 at i +c + in = i + do k = 1, nion + if (iion(k) .eq. i) then + in = jion(k) + goto 10 + end if + end do + 10 continue +c +c store the coordinates of the atom of interest +c + xi = x(i) + yi = y(i) + zi = z(i) +c +c perform dynamic allocation of some local arrays +c + allocate (cscale(n)) +c +c set array needed to scale connected atom interactions +c + do j = 1, nion + cscale(iion(j)) = 1.0d0 + end do + do j = 1, n12(in) + cscale(i12(j,in)) = c2scale + end do + do j = 1, n13(in) + cscale(i13(j,in)) = c3scale + end do + do j = 1, n14(in) + cscale(i14(j,in)) = c4scale + end do + do j = 1, n15(in) + cscale(i15(j,in)) = c5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = qmmm(i) + do j = 1, nion + if (.not. doespf) then + cscale(jion(j)) = 1.0d0 +cnf-begin +cnf +cnf At the moment, the use of 1-4 conditions for generating the external potential +cnf leads to unphysical results. Switch to the old scheme for which the close +cnv charges need to be set to 0. +cnf + else + cscale(jion(j)) = 1.0d0 + end if +cnf-end + cscale(jion(j)) = cscale(jion(j)) * qmmmscale + end do +c +c set cutoff distances and switching function coefficients +c + mode = 'CHARGE' + call switch (mode) +c +c calculate the charge interaction elements +c + do kk = 1, nion + k = iion(kk) + kn = jion(kk) + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + if (proceed) proceed = (kn .ne. i) +cqmmm + kqmmm = mod(qmmm(k),3) + if (proceed) proceed = (kqmmm .eq. 0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + xr = xi - x(k) + yr = yi - y(k) + zr = zi - z(k) + if (use_bounds) call image (xr,yr,zr) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + rb = r + ebuffer + rb2 = rb * rb + fik = fi * pchg(kk) * cscale(kn) + e = fik / rb + de = -fik / rb2 + d2e = -2.0d0 * de/rb +c +c use shifted energy switching if near the cutoff distance +c + shift = fik / (0.5d0*(off+cut)) + e = e - shift + if (r2 .gt. cut2) then + r3 = r2 * r + r4 = r2 * r2 + r5 = r2 * r3 + r6 = r3 * r3 + r7 = r3 * r4 + taper = c5*r5 + c4*r4 + c3*r3 + c2*r2 + c1*r + c0 + dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3 + & + 3.0d0*c3*r2 + 2.0d0*c2*r + c1 + d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2 + & + 6.0d0*c3*r + 2.0d0*c2 + trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4 + & + f3*r3 + f2*r2 + f1*r + f0) + dtrans = fik * (7.0d0*f7*r6 + 6.0d0*f6*r5 + & + 5.0d0*f5*r4 + 4.0d0*f4*r3 + & + 3.0d0*f3*r2 + 2.0d0*f2*r + f1) + d2trans = fik * (42.0d0*f7*r5 + 30.0d0*f6*r4 + & + 20.0d0*f5*r3 + 12.0d0*f4*r2 + & + 6.0d0*f3*r + 2.0d0*f2) + d2e = e*d2taper + 2.0d0*de*dtaper + & + d2e*taper + d2trans + de = e*dtaper + de*taper + dtrans + e = e*taper + trans + end if +c +c scale the interaction based on its group membership +c + if (use_group) then + e = e * fgrp + de = de * fgrp + d2e = d2e * fgrp + end if +c +c form the individual Hessian element components +c + de = de / r + d2e = (d2e-de) / r2 + d2edx = d2e * xr + d2edy = d2e * yr + d2edz = d2e * zr + term(1,1) = d2edx*xr + de + term(1,2) = d2edx*yr + term(1,3) = d2edx*zr + term(2,1) = term(1,2) + term(2,2) = d2edy*yr + de + term(2,3) = d2edy*zr + term(3,1) = term(1,3) + term(3,2) = term(2,3) + term(3,3) = d2edz*zr + de +cqmmm +c increment the potential and derivatives +c + QMMM_EP( 1) = QMMM_EP( 1) + e + QMMM_EP( 2) = QMMM_EP( 2) + de * xr + QMMM_EP( 3) = QMMM_EP( 3) + de * yr + QMMM_EP( 4) = QMMM_EP( 4) + de * zr + if (nComp .eq. 10) then + QMMM_EP( 5) = QMMM_EP( 5) + term(1,1) + QMMM_EP( 6) = QMMM_EP( 6) + term(2,2) + QMMM_EP( 7) = QMMM_EP( 7) + term(3,3) + QMMM_EP( 8) = QMMM_EP( 8) + term(1,2) + QMMM_EP( 9) = QMMM_EP( 9) + term(1,3) + QMMM_EP(10) = QMMM_EP(10) + term(2,3) + end if + end if + end if + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (.not. use_replica) return +c +c calculate interaction energy with other unit cells +c + do kk = 1, nion + k = iion(kk) + kn = jion(kk) + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + do jcell = 1, ncell + xr = xi - x(k) + yr = yi - y(k) + zr = zi - z(k) + call imager (xr,yr,zr,jcell) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + rb = r + ebuffer + rb2 = rb * rb + fik = fi * pchg(kk) + if (use_polymer) then + if (r2 .le. polycut2) fik = fik * cscale(kn) + end if + e = fik / r +c +c compute chain rule terms for Hessian matrix elements +c + de = -fik / rb2 + d2e = -2.0d0 * de/rb +c +c use shifted energy switching if near the cutoff distance +c + shift = fik / (0.5d0*(off+cut)) + e = e - shift + if (r2 .gt. cut2) then + r3 = r2 * r + r4 = r2 * r2 + r5 = r2 * r3 + r6 = r3 * r3 + r7 = r3 * r4 + taper = c5*r5 + c4*r4 + c3*r3 + c2*r2 + c1*r + c0 + dtaper = 5.0d0*c5*r4 + 4.0d0*c4*r3 + & + 3.0d0*c3*r2 + 2.0d0*c2*r + c1 + d2taper = 20.0d0*c5*r3 + 12.0d0*c4*r2 + & + 6.0d0*c3*r + 2.0d0*c2 + trans = fik * (f7*r7 + f6*r6 + f5*r5 + f4*r4 + & + f3*r3 + f2*r2 + f1*r + f0) + dtrans = fik * (7.0d0*f7*r6 + 6.0d0*f6*r5 + & + 5.0d0*f5*r4 + 4.0d0*f4*r3 + & + 3.0d0*f3*r2 + 2.0d0*f2*r + f1) + d2trans = fik * (42.0d0*f7*r5 + 30.0d0*f6*r4 + & + 20.0d0*f5*r3 + 12.0d0*f4*r2 + & + 6.0d0*f3*r + 2.0d0*f2) + d2e = e*d2taper + 2.0d0*de*dtaper + & + d2e*taper + d2trans + de = e*dtaper + de*taper + dtrans + e = e*taper + trans + end if +c +c scale the interaction based on its group membership +c + if (use_group) then + e = e * fgrp + de = de * fgrp + d2e = d2e * fgrp + end if +c +c form the individual Hessian element components +c + de = de / r + d2e = (d2e-de) / r2 + d2edx = d2e * xr + d2edy = d2e * yr + d2edz = d2e * zr + term(1,1) = d2edx*xr + de + term(1,2) = d2edx*yr + term(1,3) = d2edx*zr + term(2,1) = term(1,2) + term(2,2) = d2edy*yr + de + term(2,3) = d2edy*zr + term(3,1) = term(1,3) + term(3,2) = term(2,3) + term(3,3) = d2edz*zr + de +cqmmm +c increment the potential and derivatives +c + QMMM_EP( 1) = QMMM_EP( 1) + e + QMMM_EP( 2) = QMMM_EP( 2) + de * xr + QMMM_EP( 3) = QMMM_EP( 3) + de * yr + QMMM_EP( 4) = QMMM_EP( 4) + de * zr + if (nComp .eq. 10) then + QMMM_EP( 5) = QMMM_EP( 5) + term(1,1) + QMMM_EP( 6) = QMMM_EP( 6) + term(2,2) + QMMM_EP( 7) = QMMM_EP( 7) + term(3,3) + QMMM_EP( 8) = QMMM_EP( 8) + term(1,2) + QMMM_EP( 9) = QMMM_EP( 9) + term(1,3) + QMMM_EP(10) = QMMM_EP(10) + term(2,3) + end if + end if + end do + end if + end do +c +c perform deallocation of some local arrays +c + deallocate (cscale) + return + end +c +c +c "elecpotb" calculates elecpot using a particle mesh +c Ewald summation +c + subroutine elecpotb (i,nComp,QMMM_EP) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'cell.i' + include 'charge.i' + include 'chgpot.i' + include 'couple.i' + include 'cutoff.i' + include 'ewald.i' + include 'group.i' + include 'hessn.i' + include 'math.i' + integer i,j,k,kk + integer in,kn,jcell + real*8 fi,fik,fgrp + real*8 r,r2,rb,rb2 + real*8 e,de,d2e + real*8 d2edx,d2edy,d2edz + real*8 xi,yi,zi + real*8 xr,yr,zr + real*8 rew,erfc,cut2 + real*8 erfterm,expterm + real*8 scale,scaleterm + real*8 term(3,3) + real*8, allocatable :: cscale(:) + logical proceed + external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,nComp + real*8 QMMM_EP(nComp) +c +c +c initialization +c + do k = 1, nComp + QMMM_EP(k) = 0.0d0 + end do + fi = 1.0d0 / dielec + cut2 = ewaldcut * ewaldcut +c +c place a charge +1 at i +c + in = i + do k = 1, nion + if (iion(k) .eq. i) then + in = jion(k) + goto 10 + end if + end do + 10 continue +c +c store the coordinates of the atom of interest +c + xi = x(i) + yi = y(i) + zi = z(i) +c +c perform dynamic allocation of some local arrays +c + allocate (cscale(n)) +c +c set array needed to scale connected atom interactions +c + do j = 1, nion + cscale(iion(j)) = 1.0d0 + end do + do j = 1, n12(in) + cscale(i12(j,in)) = c2scale + end do + do j = 1, n13(in) + cscale(i13(j,in)) = c3scale + end do + do j = 1, n14(in) + cscale(i14(j,in)) = c4scale + end do + do j = 1, n15(in) + cscale(i15(j,in)) = c5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = qmmm(i) + do j = 1, nion + if (.not. doespf) cscale(jion(j)) = 1.0d0 +cnf-begin +cnf +cnf At the moment, the use of 1-4 conditions for generating the external potential +cnf leads to unphysical results. Switch to the old scheme for which the close +cnv charges need to be set to 0. +cnf + cscale(jion(j)) = 1.0d0 +cnf-end + cscale(jion(j)) = cscale(jion(j)) * qmmmscale + end do +c +c calculate the real space Ewald interaction Hessian elements +c + do kk = 1, nion + k = iion(kk) + kn = jion(kk) + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + proceed = .true. + if (proceed) proceed = (kn .ne. i) +cqmmm + kqmmm = mod(qmmm(k),3) + if (proceed) proceed = (kqmmm .eq. 0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + xr = xi - x(k) + yr = yi - y(k) + zr = zi - z(k) + call image (xr,yr,zr) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. cut2) then + r = sqrt(r2) + rb = r + ebuffer + rb2 = rb * rb + fik = fi * pchg(kk) * cscale(kn) + rew = aewald * r + erfterm = erfc (rew) + expterm = exp(-rew**2) + scale = cscale(kn) + if (use_group) scale = scale * fgrp + scaleterm = scale - 1.0d0 +c +c compute chain rule terms for Hessian matrix elements +c + e = (fik/rb) * (erfterm+scaleterm) + de = -fik * ((erfterm+scaleterm)/rb2 + & + (2.0d0*aewald/sqrtpi)*expterm/r) + d2e = -2.0d0*de/rb + 2.0d0*(fik/(rb*rb2))*scaleterm + & + (4.0d0*fik*aewald**3/sqrtpi)*expterm + & + 2.0d0*(fik/(rb*rb2))*scaleterm +c +c form the individual Hessian element components +c + de = de / r + d2e = (d2e-de) / r2 + d2edx = d2e * xr + d2edy = d2e * yr + d2edz = d2e * zr + term(1,1) = d2edx*xr + de + term(1,2) = d2edx*yr + term(1,3) = d2edx*zr + term(2,1) = term(1,2) + term(2,2) = d2edy*yr + de + term(2,3) = d2edy*zr + term(3,1) = term(1,3) + term(3,2) = term(2,3) + term(3,3) = d2edz*zr + de +cqmmm +c increment the potential and derivatives +c + QMMM_EP( 1) = QMMM_EP( 1) + e + QMMM_EP( 2) = QMMM_EP( 2) + de * xr + QMMM_EP( 3) = QMMM_EP( 3) + de * yr + QMMM_EP( 4) = QMMM_EP( 4) + de * zr + if (nComp .eq. 10) then + QMMM_EP( 5) = QMMM_EP( 5) + term(1,1) + QMMM_EP( 6) = QMMM_EP( 6) + term(2,2) + QMMM_EP( 7) = QMMM_EP( 7) + term(3,3) + QMMM_EP( 8) = QMMM_EP( 8) + term(1,2) + QMMM_EP( 9) = QMMM_EP( 9) + term(1,3) + QMMM_EP(10) = QMMM_EP(10) + term(2,3) + end if + end if + end if + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (.not. use_replica) return +c +c calculate interaction energy with other unit cells +c + do kk = 1, nion + k = iion(kk) + kn = jion(kk) + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + proceed = .true. +c +c compute the energy contribution for this interaction +c + if (proceed) then + do jcell = 1, ncell + xr = xi - x(k) + yr = yi - y(k) + zr = zi - z(k) + call imager (xr,yr,zr,jcell) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. cut2) then + r = sqrt(r2) + rb = r + ebuffer + rb2 = rb * rb + fik = fi * pchg(kk) + rew = aewald * r + erfterm = erfc (rew) + expterm = exp(-rew**2) + scale = 1.0d0 + if (use_group) scale = scale * fgrp + if (use_polymer) then + if (r2 .le. polycut2) then + scale = scale * cscale(kn) + end if + end if + scaleterm = scale - 1.0d0 +c +c compute chain rule terms for Hessian matrix elements +c + e = (fik/rb) * (erfterm+scaleterm) + de = -fik * ((erfterm+scaleterm)/rb2 + & + (2.0d0*aewald/sqrtpi)*exp(-rew**2)/r) + d2e = -2.0d0*de/rb + 2.0d0*(fik/(rb*rb2))*scaleterm + & + (4.0d0*fik*aewald**3/sqrtpi)*expterm + & + 2.0d0*(fik/(rb*rb2))*scaleterm +c +c form the individual Hessian element components +c + de = de / r + d2e = (d2e-de) / r2 + d2edx = d2e * xr + d2edy = d2e * yr + d2edz = d2e * zr + term(1,1) = d2edx*xr + de + term(1,2) = d2edx*yr + term(1,3) = d2edx*zr + term(2,1) = term(1,2) + term(2,2) = d2edy*yr + de + term(2,3) = d2edy*zr + term(3,1) = term(1,3) + term(3,2) = term(2,3) + term(3,3) = d2edz*zr + de +cqmmm +c increment the potential and derivatives +c + QMMM_EP( 1) = QMMM_EP( 1) + e + QMMM_EP( 2) = QMMM_EP( 2) + de * xr + QMMM_EP( 3) = QMMM_EP( 3) + de * yr + QMMM_EP( 4) = QMMM_EP( 4) + de * zr + if (nComp .eq. 10) then + QMMM_EP( 5) = QMMM_EP( 5) + term(1,1) + QMMM_EP( 6) = QMMM_EP( 6) + term(2,2) + QMMM_EP( 7) = QMMM_EP( 7) + term(3,3) + QMMM_EP( 8) = QMMM_EP( 8) + term(1,2) + QMMM_EP( 9) = QMMM_EP( 9) + term(1,3) + QMMM_EP(10) = QMMM_EP(10) + term(2,3) + end if + end if + end do + end if + end do +c +c perform deallocation of some local arrays +c + deallocate (cscale) + return + end +c +c +c "elecpotc" calculates elecpot for use with potential +c smoothing methods +c +c + subroutine elecpotc (i,nComp,QMMM_EP) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'charge.i' + include 'chgpot.i' + include 'couple.i' + include 'group.i' + include 'hessn.i' + include 'math.i' + include 'warp.i' + integer i,j,k,kk + integer in,kn + real*8 fi,fik,fgrp + real*8 r,r2,rb,rb2 + real*8 e,de,d2e + real*8 d2edx,d2edy,d2edz + real*8 xi,yi,zi + real*8 xr,yr,zr + real*8 erf,erfterm + real*8 expcut,expterm + real*8 wterm,width + real*8 width2,width3 + real*8 term(3,3) + real*8, allocatable :: cscale(:) + logical proceed + external erf +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,nComp + real*8 QMMM_EP(nComp) +c +c +c initialization +c + do k = 1, nComp + QMMM_EP(k) = 0.0d0 + end do + fi = 1.0d0 / dielec +c +c place a charge +1 at i +c + in = i + do k = 1, nion + if (iion(k) .eq. i) then + in = jion(k) + goto 10 + end if + end do + return + 10 continue +c +c store the coordinates of the atom of interest +c + xi = x(i) + yi = y(i) + zi = z(i) +c +c perform dynamic allocation of some local arrays +c + allocate (cscale(n)) +c +c set array needed to scale connected atom interactions +c + do j = 1, nion + cscale(iion(j)) = 1.0d0 + end do + do j = 1, n12(in) + cscale(i12(j,in)) = c2scale + end do + do j = 1, n13(in) + cscale(i13(j,in)) = c3scale + end do + do j = 1, n14(in) + cscale(i14(j,in)) = c4scale + end do + do j = 1, n15(in) + cscale(i15(j,in)) = c5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = qmmm(i) + do j = 1, nion + if (.not. doespf) cscale(jion(j)) = 1.0d0 +cnf-begin +cnf +cnf At the moment, the use of 1-4 conditions for generating the external potential +cnf leads to unphysical results. Switch to the old scheme for which the close +cnv charges need to be set to 0. +cnf + cscale(jion(j)) = 1.0d0 +cnf-end + cscale(jion(j)) = cscale(jion(j)) * qmmmscale + end do +c +c set the smallest exponential terms to be calculated +c + expcut = -50.0d0 +c +c set the extent of smoothing to be performed +c + width = deform * diffc + if (use_dem) then + if (width .gt. 0.0d0) width = 0.5d0 / sqrt(width) + else if (use_gda) then + wterm = sqrt(3.0d0/(2.0d0*diffc)) + end if + width2 = width * width + width3 = width * width2 +c +c calculate the charge interaction energy Hessian elements +c + do kk = 1, nion + k = iion(kk) + kn = jion(kk) + proceed = .true. + if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) + if (proceed) proceed = (kn .ne. i) +cqmmm + kqmmm = mod(qmmm(k),3) + if (proceed) proceed = (kqmmm .eq. 0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + xr = xi - x(k) + yr = yi - y(k) + zr = zi - z(k) + r2 = xr*xr + yr*yr + zr*zr + r = sqrt(r2) + rb = r + ebuffer + rb2 = rb * rb + fik = fi * pchg(kk) * cscale(kn) +c +c compute chain rule terms for Hessian matrix elements +c + e = fik / rb + de = -fik / rb2 + d2e = -2.0d0 * de/rb +c +c transform the potential function via smoothing +c + if (use_dem) then + if (width .gt. 0.0d0) then + erfterm = erf(width*rb) + expterm = -rb2 * width2 + if (expterm .gt. expcut) then + expterm = 2.0d0*fik*width*exp(expterm) + & / (sqrtpi*rb) + else + expterm = 0.0d0 + end if + e = e * erfterm + de = de*erfterm + expterm + d2e = -2.0d0 * (de/rb + expterm*rb*width2) + end if + else if (use_gda) then + width = m2(i) + m2(k) + if (width .gt. 0.0d0) then + width = wterm / sqrt(width) + width2 = width * width + erfterm = erf(width*rb) + expterm = -rb2 * width2 + if (expterm .gt. expcut) then + expterm = 2.0d0*fik*width*exp(expterm) + & / (sqrtpi*rb) + else + expterm = 0.0d0 + end if + e = e * erfterm + de = de*erfterm + expterm + d2e = -2.0d0 * (de/rb + expterm*r*width2) + end if + else if (use_tophat) then + if (width .gt. rb) then + e = fik * (3.0d0*width2-rb2) / (2.0d0*width3) + d2e = -fik / width3 + de = d2e * rb + end if + else if (use_stophat) then + wterm = rb + width + e = fik / wterm + de = -fik / (wterm*wterm) + d2e = -2.0d0 * de / wterm + end if +c +c scale the interaction based on its group membership +c + if (use_group) then + de = de * fgrp + d2e = d2e * fgrp + end if +c +c form the individual Hessian element components +c + de = de / r + d2e = (d2e-de) / r2 + d2edx = d2e * xr + d2edy = d2e * yr + d2edz = d2e * zr + term(1,1) = d2edx*xr + de + term(1,2) = d2edx*yr + term(1,3) = d2edx*zr + term(2,1) = term(1,2) + term(2,2) = d2edy*yr + de + term(2,3) = d2edy*zr + term(3,1) = term(1,3) + term(3,2) = term(2,3) + term(3,3) = d2edz*zr + de +cqmmm +c increment the potential and derivatives +c + QMMM_EP( 1) = QMMM_EP( 1) + e + QMMM_EP( 2) = QMMM_EP( 2) + de * xr + QMMM_EP( 3) = QMMM_EP( 3) + de * yr + QMMM_EP( 4) = QMMM_EP( 4) + de * zr + if (nComp .eq. 10) then + QMMM_EP( 5) = QMMM_EP( 5) + term(1,1) + QMMM_EP( 6) = QMMM_EP( 6) + term(2,2) + QMMM_EP( 7) = QMMM_EP( 7) + term(3,3) + QMMM_EP( 8) = QMMM_EP( 8) + term(1,2) + QMMM_EP( 9) = QMMM_EP( 9) + term(1,3) + QMMM_EP(10) = QMMM_EP(10) + term(2,3) + end if + end if + end do +c +c perform deallocation of some local arrays +c + deallocate (cscale) + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/elj1.f 6.2.06/source/elj1.f --- 6.2.06/source_orig/elj1.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/elj1.f 2013-10-21 18:20:56.325885311 +0200 @@ -105,6 +105,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -159,6 +162,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -184,6 +190,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -329,6 +339,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -354,6 +367,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -559,6 +575,9 @@ logical proceed,usei logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -628,6 +647,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -680,6 +702,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -897,6 +923,9 @@ real*8, allocatable :: devt(:,:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -977,6 +1006,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -1002,6 +1034,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -1245,6 +1281,9 @@ real*8, allocatable :: zred(:) real*8, allocatable :: vscale(:) logical proceed,usei +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -1304,6 +1343,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -1329,6 +1371,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/elj2.f 6.2.06/source/elj2.f --- 6.2.06/source_orig/elj2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/elj2.f 2013-10-21 18:20:56.501885303 +0200 @@ -91,6 +91,9 @@ real*8, allocatable :: vscale(:) logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c perform dynamic allocation of some local arrays @@ -151,6 +154,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -176,6 +181,11 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (k .ne. i) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1 + & .and. ikqmmm .ne. 4) c c compute the Hessian elements for this interaction c @@ -377,6 +387,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -401,6 +413,9 @@ kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1) c c compute the Hessian elements for this interaction c @@ -707,6 +722,9 @@ real*8 zred(*) real*8, allocatable :: vscale(:) logical proceed +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c perform dynamic allocation of some local arrays @@ -773,6 +791,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -798,6 +818,11 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (k .ne. i) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm. ne. 1 + & .and. ikqmmm .ne. 4) c c compute the Hessian elements for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/elj3.f 6.2.06/source/elj3.f --- 6.2.06/source_orig/elj3.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/elj3.f 2013-10-21 18:20:56.505885303 +0200 @@ -112,6 +112,9 @@ logical proceed,usei logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -164,6 +167,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -189,6 +195,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -299,6 +309,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -324,6 +337,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -497,6 +513,9 @@ logical prime,repeat logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -564,6 +583,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -616,6 +638,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -807,6 +833,9 @@ logical proceed,usei logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -879,6 +908,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -904,6 +936,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -1107,6 +1143,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei logical header,huge +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -1155,6 +1194,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -1180,6 +1222,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/elj.f 6.2.06/source/elj.f --- 6.2.06/source_orig/elj.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/elj.f 2013-10-21 18:20:56.745885292 +0200 @@ -90,6 +90,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -137,6 +140,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -162,6 +168,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -241,6 +251,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -266,6 +279,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -398,6 +414,9 @@ logical proceed,usei logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -460,6 +479,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -512,6 +534,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -653,6 +679,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -714,6 +743,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -739,6 +771,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -895,6 +931,9 @@ real*8, allocatable :: zred(:) real*8, allocatable :: vscale(:) logical proceed,usei +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -946,6 +985,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -971,6 +1013,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/embed.f 6.2.06/source/embed.f --- 6.2.06/source_orig/embed.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/embed.f 2013-10-23 11:36:27.051130195 +0200 @@ -519,7 +519,7 @@ list(i) = idfix(1,i) list(i+ndfix) = idfix(2,i) end do - call sort3 (nlist,list,key) + call tk_sort3 (nlist,list,key) j = -1 do i = 1, nlist k = list(i) @@ -1113,13 +1113,13 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) c c get a distance selection method and extent of metrization c if (keyword(1:15) .eq. 'TRIAL-DISTANCE ') then call gettext (record,method,next) - call upcase (method) + call tk_upcase (method) if (method .eq. 'HAVEL') then call getnumb (record,npart,next) else if (method .eq. 'PARTIAL') then @@ -1316,7 +1316,7 @@ do i = 1, n value(i) = random () end do - call sort2 (n,value,list) + call tk_sort2 (n,value,list) gap = 0.0d0 do i = 1, n-1 k = list(i) @@ -1417,7 +1417,7 @@ do i = 1, npair value(i) = random () end do - call sort2 (npair,value,list) + call tk_sort2 (npair,value,list) eps = 1.0d-10 gap = 0.0d0 do i = 1, npair diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/emm3hb1.f 6.2.06/source/emm3hb1.f --- 6.2.06/source_orig/emm3hb1.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/emm3hb1.f 2013-10-21 18:20:56.429885306 +0200 @@ -133,6 +133,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei,use_hb character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -195,6 +198,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -220,6 +226,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -473,6 +483,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -498,6 +511,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -838,6 +854,9 @@ logical prime,repeat logical use_hb character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -915,6 +934,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -968,6 +990,10 @@ if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) if (proceed) proceed = (vscale(k) .ne. 0.0d0) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -1326,6 +1352,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei,use_hb character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and first derivatives @@ -1388,6 +1417,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -1413,6 +1445,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/emm3hb2.f 6.2.06/source/emm3hb2.f --- 6.2.06/source_orig/emm3hb2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/emm3hb2.f 2013-10-21 18:20:56.421885307 +0200 @@ -88,6 +88,9 @@ real*8, allocatable :: vscale(:) logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c perform dynamic allocation of some local arrays @@ -156,6 +159,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -181,6 +186,11 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (k .ne. i) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1 + & .and. ikqmmm .ne. 4) c c compute the Hessian elements for this interaction c @@ -441,6 +451,8 @@ xi = xred(i) yi = yred(i) zi = zred(i) +cqmmm + iqmmm = qmmm(i) c c set interaction scaling coefficients for connected atoms c @@ -465,6 +477,9 @@ kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (iqmmm .ne. 1 .and. kqmmm .ne. 1) c c compute the Hessian elements for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/emm3hb3.f 6.2.06/source/emm3hb3.f --- 6.2.06/source_orig/emm3hb3.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/emm3hb3.f 2013-10-21 18:20:56.501885303 +0200 @@ -134,6 +134,9 @@ logical proceed,usei logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -194,6 +197,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -219,6 +225,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -375,6 +385,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -400,6 +413,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -637,6 +653,9 @@ logical prime,repeat logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -712,6 +731,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -764,6 +786,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -1027,6 +1053,9 @@ logical proceed,usei logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy and partitioning terms @@ -1087,6 +1116,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -1112,6 +1144,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/emm3hb.f 6.2.06/source/emm3hb.f --- 6.2.06/source_orig/emm3hb.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/emm3hb.f 2013-10-21 18:20:56.685885295 +0200 @@ -112,6 +112,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -167,6 +170,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -192,6 +198,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -317,6 +327,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -342,6 +355,9 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + if (proceed) proceed = (kqmmm .ne. 1) c c compute the energy contribution for this interaction c @@ -539,6 +555,9 @@ logical proceed,usei logical prime,repeat character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -609,6 +628,9 @@ yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -661,6 +683,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c @@ -877,6 +903,9 @@ real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the van der Waals energy contribution @@ -932,6 +961,9 @@ yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) +cqmmm + iqmmm = qmmm(i) + if (usei) usei = (iqmmm .ne. 1) c c set interaction scaling coefficients for connected atoms c @@ -957,6 +989,10 @@ proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k) .or. use(kv)) +cqmmm + kqmmm = qmmm(k) + ikqmmm = iqmmm + kqmmm + if (proceed) proceed = (kqmmm .ne. 1 .and. ikqmmm .ne. 4) c c compute the energy contribution for this interaction c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/empole1.f 6.2.06/source/empole1.f --- 6.2.06/source_orig/empole1.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/empole1.f 2013-10-21 18:20:56.349885310 +0200 @@ -25,6 +25,8 @@ include 'mpole.i' include 'potent.i' integer i,j,ii +cqmmm + include 'qmmm.i' c c c choose the method for summing over multipole interactions @@ -42,6 +44,8 @@ call empole1a end if end if +cqmmm + if (nbinqm .ne. 0 .and. e4qmmm .eq. 0) call empole1qmmm c c zero out energy and derivative terms which are not in use c @@ -166,6 +170,9 @@ real*8, allocatable :: uscale(:) logical proceed,usei,usek character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out multipole and polarization energy and derivatives @@ -276,6 +283,26 @@ dscale(ip14(j,ii)) = d4scale uscale(ip14(j,ii)) = u4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do do k = i+1, npole kk = ipole(k) kz = zaxis(k) @@ -845,6 +872,13 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -942,6 +976,26 @@ dscale(ip14(j,ii)) = d4scale uscale(ip14(j,ii)) = u4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do do k = i, npole kk = ipole(k) kz = zaxis(k) @@ -1567,6 +1621,13 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -1711,6 +1772,9 @@ real*8, allocatable :: uscale(:) logical proceed,usei,usek character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out multipole and polarization energy and derivatives @@ -1821,6 +1885,30 @@ dscale(ip14(j,ii)) = d4scale uscale(ip14(j,ii)) = u4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, nelst(i) + jqmmm = mod(qmmm(ipole(elst(j,i))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + dscale(ipole(elst(j,i))) = 1.0d0 + uscale(ipole(elst(j,i))) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = mscale(ipole(elst(j,i))) + & * qmmmscale + pscale(ipole(elst(j,i))) = pscale(ipole(elst(j,i))) + & * qmmmscale + dscale(ipole(elst(j,i))) = dscale(ipole(elst(j,i))) + & * qmmmscale + uscale(ipole(elst(j,i))) = uscale(ipole(elst(j,i))) + & * qmmmscale + end if + end do do kkk = 1, nelst(i) k = elst(kkk,i) kk = ipole(k) @@ -2391,6 +2479,13 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(i) + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + dscale(ipole(elst(j,i))) = 1.0d0 + uscale(ipole(elst(j,i))) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -2773,6 +2868,9 @@ real*8, allocatable :: uscale(:) character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the intramolecular portion of the Ewald energy @@ -2860,6 +2958,26 @@ dscale(ip14(j,ii)) = d4scale uscale(ip14(j,ii)) = u4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do do k = i+1, npole kk = ipole(k) xr = x(kk) - x(ii) @@ -3567,6 +3685,13 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -3660,6 +3785,26 @@ dscale(ip14(j,ii)) = d4scale uscale(ip14(j,ii)) = u4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do do k = i, npole kk = ipole(k) do jcell = 1, ncell @@ -4401,6 +4546,13 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -4792,6 +4944,9 @@ logical dorl,dorli character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the intramolecular portion of the Ewald energy @@ -4924,6 +5079,30 @@ dscale(ip14(j,ii)) = d4scale uscale(ip14(j,ii)) = u4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, nelst(i) + jqmmm = mod(qmmm(ipole(elst(j,i))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + dscale(ipole(elst(j,i))) = 1.0d0 + uscale(ipole(elst(j,i))) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = mscale(ipole(elst(j,i))) + & * qmmmscale + pscale(ipole(elst(j,i))) = pscale(ipole(elst(j,i))) + & * qmmmscale + dscale(ipole(elst(j,i))) = dscale(ipole(elst(j,i))) + & * qmmmscale + uscale(ipole(elst(j,i))) = uscale(ipole(elst(j,i))) + & * qmmmscale + end if + end do do kkk = 1, nelst(i) k = elst(kkk,i) kk = ipole(k) @@ -5691,6 +5870,13 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(i) + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + dscale(ipole(elst(j,i))) = 1.0d0 + uscale(ipole(elst(j,i))) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -6447,3 +6633,1603 @@ deallocate (cphi) return end +c +c +c ##################################################### +c ## ## +c ## subroutine empole1qmmm -- QM/MM corrections ## +c ## ## +c ##################################################### +c +c +c "empole1qmmm" corrects the atomic multipole and dipole +c polarizability interaction energy using a double loop +c only MM-MM, MM-Y and Y-Y interactions must be retained +c +c + subroutine empole1qmmm + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'boxes.i' + include 'cell.i' + include 'chgpot.i' + include 'couple.i' + include 'cutoff.i' + include 'deriv.i' + include 'energi.i' + include 'group.i' + include 'inter.i' + include 'molcul.i' + include 'mplpot.i' + include 'mpole.i' + include 'polar.i' + include 'polgrp.i' + include 'polpot.i' + include 'shunt.i' + include 'usage.i' + include 'virial.i' + integer i,j,k + integer ii,kk,jcell + integer ix,iy,iz + integer kx,ky,kz + integer iax,iay,iaz + integer kax,kay,kaz + real*8 e,ei,f,fgrp,gfd + real*8 damp,expdamp + real*8 pdi,pti,pgamma + real*8 scale3,scale3i + real*8 scale5,scale5i + real*8 scale7,scale7i + real*8 temp3,temp5,temp7 + real*8 psc3,psc5,psc7 + real*8 dsc3,dsc5,dsc7 + real*8 xr,yr,zr + real*8 xix,yix,zix + real*8 xiy,yiy,ziy + real*8 xiz,yiz,ziz + real*8 xkx,ykx,zkx + real*8 xky,yky,zky + real*8 xkz,ykz,zkz + real*8 r,r2,rr1,rr3 + real*8 rr5,rr7,rr9,rr11 + real*8 vxx,vyy,vzz + real*8 vyx,vzx,vzy + real*8 ci,di(3),qi(9) + real*8 ck,dk(3),qk(9) + real*8 frcxi(3),frcxk(3) + real*8 frcyi(3),frcyk(3) + real*8 frczi(3),frczk(3) + real*8 fridmp(3),findmp(3) + real*8 ftm2(3),ftm2i(3) + real*8 ttm2(3),ttm3(3) + real*8 ttm2i(3),ttm3i(3) + real*8 dixdk(3),fdir(3) + real*8 dixuk(3),dkxui(3) + real*8 dixukp(3),dkxuip(3) + real*8 uixqkr(3),ukxqir(3) + real*8 uixqkrp(3),ukxqirp(3) + real*8 qiuk(3),qkui(3) + real*8 qiukp(3),qkuip(3) + real*8 rxqiuk(3),rxqkui(3) + real*8 rxqiukp(3),rxqkuip(3) + real*8 qidk(3),qkdi(3) + real*8 qir(3),qkr(3) + real*8 qiqkr(3),qkqir(3) + real*8 qixqk(3),rxqir(3) + real*8 dixr(3),dkxr(3) + real*8 dixqkr(3),dkxqir(3) + real*8 rxqkr(3),qkrxqir(3) + real*8 rxqikr(3),rxqkir(3) + real*8 rxqidk(3),rxqkdi(3) + real*8 ddsc3(3),ddsc5(3) + real*8 ddsc7(3) + real*8 gl(0:8),gli(7),glip(7) + real*8 sc(10),sci(8),scip(8) + real*8 gf(7),gfi(6),gti(6) + real*8, allocatable :: mscale(:) + real*8, allocatable :: pscale(:) + real*8, allocatable :: dscale(:) + real*8, allocatable :: uscale(:) + logical proceed,usei,usek + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm,kqmmm,ikqmmm +c +c +c check the sign of multipole components at chiral sites +c + call chkpole +c +c rotate the multipole components into the global frame +c + call rotpole +c +c compute the induced dipoles at each polarizable atom +c + call induce +c +c perform dynamic allocation of some local arrays +c + allocate (mscale(n)) + allocate (pscale(n)) + allocate (dscale(n)) + allocate (uscale(n)) +c +c set arrays needed to scale connected atom interactions +c + if (npole .eq. 0) return + do i = 1, n + mscale(i) = 1.0d0 + pscale(i) = 1.0d0 + dscale(i) = 1.0d0 + uscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = electric / dielec + mode = 'MPOLE' + call switch (mode) +c +c set scale factors for permanent multipole and induced terms +c + do i = 1, npole-1 + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + do k = 1, np11(ii) + if (i14(j,ii) .eq. ip11(k,ii)) + & pscale(i14(j,ii)) = p4scale * p41scale + end do + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do + do k = i+1, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) +cqmmm + kqmmm = mod(qmmm(kk),3) + ikqmmm = iqmmm + kqmmm + proceed = .true. + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + if (.not. use_intra) proceed = .true. + if (proceed) proceed = (usei .or. usek) +cqmmm + if (proceed) proceed = (ikqmmm .ne. 0) + if (.not. proceed) goto 10 + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + if (use_bounds) call image (xr,yr,zr) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + scale3i = scale3 * uscale(kk) + scale5i = scale5 * uscale(kk) + scale7i = scale7 * uscale(kk) + dsc3 = scale3 * dscale(kk) + dsc5 = scale5 * dscale(kk) + dsc7 = scale7 * dscale(kk) + psc3 = scale3 * pscale(kk) + psc5 = scale5 * pscale(kk) + psc7 = scale7 * pscale(kk) +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c compute the energy contributions for this interaction +c + e = rr1*gl(0) + rr3*(gl(1)+gl(6)) + & + rr5*(gl(2)+gl(7)+gl(8)) + & + rr7*(gl(3)+gl(5)) + rr9*gl(4) + ei = 0.5d0*(rr3*(gli(1)+gli(6))*psc3 + & + rr5*(gli(2)+gli(7))*psc5 + & + rr7*gli(3)*psc7) + e = f * mscale(kk) * e + ei = f * ei + em = em - e + ep = ep - ei +c +c increment the total intermolecular energy +c + if (molcule(ii) .ne. molcule(kk)) then + einter = einter - e - ei + end if +c +c intermediate variables for the permanent components +c + gf(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gf(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gf(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gf(4) = 2.0d0 * rr5 + gf(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gf(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gf(7) = 4.0d0 * rr7 +c +c intermediate variables for the induced components +c + gfi(1) = 0.5d0 * rr5 * ((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*scale3i) + & + 0.5d0 * rr7 * ((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*scale5i) + & + 0.5d0 * rr9 * (gli(3)*psc7+glip(3)*dsc7) + gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfi(4) = 2.0d0 * rr5 + gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) +c +c get the permanent force components +c + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the induced force components +c + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify induced force for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (rr5*scip(2)*scale3i + & - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i) + temp5 = 0.5d0 * rr5 * scale5i + fdir(1) = gfd*xr + temp5 + & * (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfd*yr + temp5 + & * (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfd*zr + temp5 + & * (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3) + end if +c +c intermediate terms for induced torque on multipoles +c + gti(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gti(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) +c +c get the permanent torque components +c + ttm2(1) = -rr3*dixdk(1) + gf(2)*dixr(1) - gf(5)*rxqir(1) + & + gf(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -rr3*dixdk(2) + gf(2)*dixr(2) - gf(5)*rxqir(2) + & + gf(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -rr3*dixdk(3) + gf(2)*dixr(3) - gf(5)*rxqir(3) + & + gf(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = rr3*dixdk(1) + gf(3)*dkxr(1) - gf(6)*rxqkr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = rr3*dixdk(2) + gf(3)*dkxr(2) - gf(6)*rxqkr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = rr3*dixdk(3) + gf(3)*dkxr(3) - gf(6)*rxqkr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the induced torque components +c + ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1) + ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2) + ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3) + ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1) + ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2) + ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3) +c +c handle the case where scaling is used +c + do j = 1, 3 + ftm2(j) = f * ftm2(j) * mscale(kk) + ftm2i(j) = f * ftm2i(j) + ttm2(j) = f * ttm2(j) * mscale(kk) + ttm2i(j) = f * ttm2i(j) + ttm3(j) = f * ttm3(j) * mscale(kk) + ttm3i(j) = f * ttm3i(j) + end do +c +c increment gradient due to force and torque on first site +c + dem(1,ii) = dem(1,ii) - ftm2(1) + dem(2,ii) = dem(2,ii) - ftm2(2) + dem(3,ii) = dem(3,ii) - ftm2(3) + dep(1,ii) = dep(1,ii) - ftm2i(1) + dep(2,ii) = dep(2,ii) - ftm2i(2) + dep(3,ii) = dep(3,ii) - ftm2i(3) + call torque (i,ttm2,ttm2i,frcxi,frcyi,frczi) +c +c increment gradient due to force and torque on second site +c + dem(1,kk) = dem(1,kk) + ftm2(1) + dem(2,kk) = dem(2,kk) + ftm2(2) + dem(3,kk) = dem(3,kk) + ftm2(3) + dep(1,kk) = dep(1,kk) + ftm2i(1) + dep(2,kk) = dep(2,kk) + ftm2i(2) + dep(3,kk) = dep(3,kk) + ftm2i(3) + call torque (k,ttm3,ttm3i,frcxk,frcyk,frczk) +c +c increment the internal virial tensor components +c + iaz = iz + iax = ix + iay = iy + kaz = kz + kax = kx + kay = ky + if (iaz .eq. 0) iaz = ii + if (iax .eq. 0) iax = ii + if (iay .eq. 0) iay = ii + if (kaz .eq. 0) kaz = kk + if (kax .eq. 0) kax = kk + if (kay .eq. 0) kay = kk + xiz = x(iaz) - x(ii) + yiz = y(iaz) - y(ii) + ziz = z(iaz) - z(ii) + xix = x(iax) - x(ii) + yix = y(iax) - y(ii) + zix = z(iax) - z(ii) + xiy = x(iay) - x(ii) + yiy = y(iay) - y(ii) + ziy = z(iay) - z(ii) + xkz = x(kaz) - x(kk) + ykz = y(kaz) - y(kk) + zkz = z(kaz) - z(kk) + xkx = x(kax) - x(kk) + ykx = y(kax) - y(kk) + zkx = z(kax) - z(kk) + xky = x(kay) - x(kk) + yky = y(kay) - y(kk) + zky = z(kay) - z(kk) + vxx = -xr*(ftm2(1)+ftm2i(1)) + xix*frcxi(1) + & + xiy*frcyi(1) + xiz*frczi(1) + xkx*frcxk(1) + & + xky*frcyk(1) + xkz*frczk(1) + vyx = -yr*(ftm2(1)+ftm2i(1)) + yix*frcxi(1) + & + yiy*frcyi(1) + yiz*frczi(1) + ykx*frcxk(1) + & + yky*frcyk(1) + ykz*frczk(1) + vzx = -zr*(ftm2(1)+ftm2i(1)) + zix*frcxi(1) + & + ziy*frcyi(1) + ziz*frczi(1) + zkx*frcxk(1) + & + zky*frcyk(1) + zkz*frczk(1) + vyy = -yr*(ftm2(2)+ftm2i(2)) + yix*frcxi(2) + & + yiy*frcyi(2) + yiz*frczi(2) + ykx*frcxk(2) + & + yky*frcyk(2) + ykz*frczk(2) + vzy = -zr*(ftm2(2)+ftm2i(2)) + zix*frcxi(2) + & + ziy*frcyi(2) + ziz*frczi(2) + zkx*frcxk(2) + & + zky*frcyk(2) + zkz*frczk(2) + vzz = -zr*(ftm2(3)+ftm2i(3)) + zix*frcxi(3) + & + ziy*frcyi(3) + ziz*frczi(3) + zkx*frcxk(3) + & + zky*frcyk(3) + zkz*frczk(3) + vir(1,1) = vir(1,1) - vxx + vir(2,1) = vir(2,1) - vyx + vir(3,1) = vir(3,1) - vzx + vir(1,2) = vir(1,2) - vyx + vir(2,2) = vir(2,2) - vyy + vir(3,2) = vir(3,2) - vzy + vir(1,3) = vir(1,3) - vzx + vir(2,3) = vir(2,3) - vzy + vir(3,3) = vir(3,3) - vzz + end if + 10 continue + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (use_replica) then +c +c calculate interaction with other unit cells +c + do i = 1, npole + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + di(1) = rpole(2,i) + di(2) = rpole(3,i) + di(3) = rpole(4,i) + qi(1) = rpole(5,i) + qi(2) = rpole(6,i) + qi(3) = rpole(7,i) + qi(4) = rpole(8,i) + qi(5) = rpole(9,i) + qi(6) = rpole(10,i) + qi(7) = rpole(11,i) + qi(8) = rpole(12,i) + qi(9) = rpole(13,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = d1scale + uscale(ip11(j,ii)) = u1scale + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = d2scale + uscale(ip12(j,ii)) = u2scale + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = d3scale + uscale(ip13(j,ii)) = u3scale + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = d4scale + uscale(ip14(j,ii)) = u4scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + if (iqmmm .eq. 0) goto 99 + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do + do k = i, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + proceed = .true. + if (proceed) proceed = (usei .or. usek) + if (.not. proceed) goto 20 + do jcell = 1, ncell + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + call imager (xr,yr,zr,jcell) + r2 = xr*xr + yr*yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dk(1) = rpole(2,k) + dk(2) = rpole(3,k) + dk(3) = rpole(4,k) + qk(1) = rpole(5,k) + qk(2) = rpole(6,k) + qk(3) = rpole(7,k) + qk(4) = rpole(8,k) + qk(5) = rpole(9,k) + qk(6) = rpole(10,k) + qk(7) = rpole(11,k) + qk(8) = rpole(12,k) + qk(9) = rpole(13,k) +c +c apply Thole polarization damping to scale factors +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + rr11 = 9.0d0 * rr9 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + do j = 1, 3 + ddsc3(j) = 0.0d0 + ddsc5(j) = 0.0d0 + ddsc7(j) = 0.0d0 + end do + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + temp3 = -3.0d0 * damp * expdamp / r2 + temp5 = -damp + temp7 = -0.2d0 - 0.6d0*damp + ddsc3(1) = temp3 * xr + ddsc3(2) = temp3 * yr + ddsc3(3) = temp3 * zr + ddsc5(1) = temp5 * ddsc3(1) + ddsc5(2) = temp5 * ddsc3(2) + ddsc5(3) = temp5 * ddsc3(3) + ddsc7(1) = temp7 * ddsc5(1) + ddsc7(2) = temp7 * ddsc5(2) + ddsc7(3) = temp7 * ddsc5(3) + end if + end if + scale3i = scale3 + scale5i = scale5 + scale7i = scale7 + dsc3 = scale3 + dsc5 = scale5 + dsc7 = scale7 + psc3 = scale3 + psc5 = scale5 + psc7 = scale7 + if (use_polymer) then + if (r2 .le. polycut2) then + scale3i = scale3i * uscale(kk) + scale5i = scale5i * uscale(kk) + scale7i = scale7i * uscale(kk) + dsc3 = dsc3 * dscale(kk) + dsc5 = dsc5 * dscale(kk) + dsc7 = dsc7 * dscale(kk) + psc3 = psc3 * pscale(kk) + psc5 = psc5 * pscale(kk) + psc7 = psc7 * pscale(kk) + end if + end if +c +c construct necessary auxiliary vectors +c + dixdk(1) = di(2)*dk(3) - di(3)*dk(2) + dixdk(2) = di(3)*dk(1) - di(1)*dk(3) + dixdk(3) = di(1)*dk(2) - di(2)*dk(1) + dixuk(1) = di(2)*uind(3,k) - di(3)*uind(2,k) + dixuk(2) = di(3)*uind(1,k) - di(1)*uind(3,k) + dixuk(3) = di(1)*uind(2,k) - di(2)*uind(1,k) + dkxui(1) = dk(2)*uind(3,i) - dk(3)*uind(2,i) + dkxui(2) = dk(3)*uind(1,i) - dk(1)*uind(3,i) + dkxui(3) = dk(1)*uind(2,i) - dk(2)*uind(1,i) + dixukp(1) = di(2)*uinp(3,k) - di(3)*uinp(2,k) + dixukp(2) = di(3)*uinp(1,k) - di(1)*uinp(3,k) + dixukp(3) = di(1)*uinp(2,k) - di(2)*uinp(1,k) + dkxuip(1) = dk(2)*uinp(3,i) - dk(3)*uinp(2,i) + dkxuip(2) = dk(3)*uinp(1,i) - dk(1)*uinp(3,i) + dkxuip(3) = dk(1)*uinp(2,i) - dk(2)*uinp(1,i) + dixr(1) = di(2)*zr - di(3)*yr + dixr(2) = di(3)*xr - di(1)*zr + dixr(3) = di(1)*yr - di(2)*xr + dkxr(1) = dk(2)*zr - dk(3)*yr + dkxr(2) = dk(3)*xr - dk(1)*zr + dkxr(3) = dk(1)*yr - dk(2)*xr + qir(1) = qi(1)*xr + qi(4)*yr + qi(7)*zr + qir(2) = qi(2)*xr + qi(5)*yr + qi(8)*zr + qir(3) = qi(3)*xr + qi(6)*yr + qi(9)*zr + qkr(1) = qk(1)*xr + qk(4)*yr + qk(7)*zr + qkr(2) = qk(2)*xr + qk(5)*yr + qk(8)*zr + qkr(3) = qk(3)*xr + qk(6)*yr + qk(9)*zr + qiqkr(1) = qi(1)*qkr(1) + qi(4)*qkr(2) + qi(7)*qkr(3) + qiqkr(2) = qi(2)*qkr(1) + qi(5)*qkr(2) + qi(8)*qkr(3) + qiqkr(3) = qi(3)*qkr(1) + qi(6)*qkr(2) + qi(9)*qkr(3) + qkqir(1) = qk(1)*qir(1) + qk(4)*qir(2) + qk(7)*qir(3) + qkqir(2) = qk(2)*qir(1) + qk(5)*qir(2) + qk(8)*qir(3) + qkqir(3) = qk(3)*qir(1) + qk(6)*qir(2) + qk(9)*qir(3) + qixqk(1) = qi(2)*qk(3) + qi(5)*qk(6) + qi(8)*qk(9) + & - qi(3)*qk(2) - qi(6)*qk(5) - qi(9)*qk(8) + qixqk(2) = qi(3)*qk(1) + qi(6)*qk(4) + qi(9)*qk(7) + & - qi(1)*qk(3) - qi(4)*qk(6) - qi(7)*qk(9) + qixqk(3) = qi(1)*qk(2) + qi(4)*qk(5) + qi(7)*qk(8) + & - qi(2)*qk(1) - qi(5)*qk(4) - qi(8)*qk(7) + rxqir(1) = yr*qir(3) - zr*qir(2) + rxqir(2) = zr*qir(1) - xr*qir(3) + rxqir(3) = xr*qir(2) - yr*qir(1) + rxqkr(1) = yr*qkr(3) - zr*qkr(2) + rxqkr(2) = zr*qkr(1) - xr*qkr(3) + rxqkr(3) = xr*qkr(2) - yr*qkr(1) + rxqikr(1) = yr*qiqkr(3) - zr*qiqkr(2) + rxqikr(2) = zr*qiqkr(1) - xr*qiqkr(3) + rxqikr(3) = xr*qiqkr(2) - yr*qiqkr(1) + rxqkir(1) = yr*qkqir(3) - zr*qkqir(2) + rxqkir(2) = zr*qkqir(1) - xr*qkqir(3) + rxqkir(3) = xr*qkqir(2) - yr*qkqir(1) + qkrxqir(1) = qkr(2)*qir(3) - qkr(3)*qir(2) + qkrxqir(2) = qkr(3)*qir(1) - qkr(1)*qir(3) + qkrxqir(3) = qkr(1)*qir(2) - qkr(2)*qir(1) + qidk(1) = qi(1)*dk(1) + qi(4)*dk(2) + qi(7)*dk(3) + qidk(2) = qi(2)*dk(1) + qi(5)*dk(2) + qi(8)*dk(3) + qidk(3) = qi(3)*dk(1) + qi(6)*dk(2) + qi(9)*dk(3) + qkdi(1) = qk(1)*di(1) + qk(4)*di(2) + qk(7)*di(3) + qkdi(2) = qk(2)*di(1) + qk(5)*di(2) + qk(8)*di(3) + qkdi(3) = qk(3)*di(1) + qk(6)*di(2) + qk(9)*di(3) + qiuk(1) = qi(1)*uind(1,k) + qi(4)*uind(2,k) + & + qi(7)*uind(3,k) + qiuk(2) = qi(2)*uind(1,k) + qi(5)*uind(2,k) + & + qi(8)*uind(3,k) + qiuk(3) = qi(3)*uind(1,k) + qi(6)*uind(2,k) + & + qi(9)*uind(3,k) + qkui(1) = qk(1)*uind(1,i) + qk(4)*uind(2,i) + & + qk(7)*uind(3,i) + qkui(2) = qk(2)*uind(1,i) + qk(5)*uind(2,i) + & + qk(8)*uind(3,i) + qkui(3) = qk(3)*uind(1,i) + qk(6)*uind(2,i) + & + qk(9)*uind(3,i) + qiukp(1) = qi(1)*uinp(1,k) + qi(4)*uinp(2,k) + & + qi(7)*uinp(3,k) + qiukp(2) = qi(2)*uinp(1,k) + qi(5)*uinp(2,k) + & + qi(8)*uinp(3,k) + qiukp(3) = qi(3)*uinp(1,k) + qi(6)*uinp(2,k) + & + qi(9)*uinp(3,k) + qkuip(1) = qk(1)*uinp(1,i) + qk(4)*uinp(2,i) + & + qk(7)*uinp(3,i) + qkuip(2) = qk(2)*uinp(1,i) + qk(5)*uinp(2,i) + & + qk(8)*uinp(3,i) + qkuip(3) = qk(3)*uinp(1,i) + qk(6)*uinp(2,i) + & + qk(9)*uinp(3,i) + dixqkr(1) = di(2)*qkr(3) - di(3)*qkr(2) + dixqkr(2) = di(3)*qkr(1) - di(1)*qkr(3) + dixqkr(3) = di(1)*qkr(2) - di(2)*qkr(1) + dkxqir(1) = dk(2)*qir(3) - dk(3)*qir(2) + dkxqir(2) = dk(3)*qir(1) - dk(1)*qir(3) + dkxqir(3) = dk(1)*qir(2) - dk(2)*qir(1) + uixqkr(1) = uind(2,i)*qkr(3) - uind(3,i)*qkr(2) + uixqkr(2) = uind(3,i)*qkr(1) - uind(1,i)*qkr(3) + uixqkr(3) = uind(1,i)*qkr(2) - uind(2,i)*qkr(1) + ukxqir(1) = uind(2,k)*qir(3) - uind(3,k)*qir(2) + ukxqir(2) = uind(3,k)*qir(1) - uind(1,k)*qir(3) + ukxqir(3) = uind(1,k)*qir(2) - uind(2,k)*qir(1) + uixqkrp(1) = uinp(2,i)*qkr(3) - uinp(3,i)*qkr(2) + uixqkrp(2) = uinp(3,i)*qkr(1) - uinp(1,i)*qkr(3) + uixqkrp(3) = uinp(1,i)*qkr(2) - uinp(2,i)*qkr(1) + ukxqirp(1) = uinp(2,k)*qir(3) - uinp(3,k)*qir(2) + ukxqirp(2) = uinp(3,k)*qir(1) - uinp(1,k)*qir(3) + ukxqirp(3) = uinp(1,k)*qir(2) - uinp(2,k)*qir(1) + rxqidk(1) = yr*qidk(3) - zr*qidk(2) + rxqidk(2) = zr*qidk(1) - xr*qidk(3) + rxqidk(3) = xr*qidk(2) - yr*qidk(1) + rxqkdi(1) = yr*qkdi(3) - zr*qkdi(2) + rxqkdi(2) = zr*qkdi(1) - xr*qkdi(3) + rxqkdi(3) = xr*qkdi(2) - yr*qkdi(1) + rxqiuk(1) = yr*qiuk(3) - zr*qiuk(2) + rxqiuk(2) = zr*qiuk(1) - xr*qiuk(3) + rxqiuk(3) = xr*qiuk(2) - yr*qiuk(1) + rxqkui(1) = yr*qkui(3) - zr*qkui(2) + rxqkui(2) = zr*qkui(1) - xr*qkui(3) + rxqkui(3) = xr*qkui(2) - yr*qkui(1) + rxqiukp(1) = yr*qiukp(3) - zr*qiukp(2) + rxqiukp(2) = zr*qiukp(1) - xr*qiukp(3) + rxqiukp(3) = xr*qiukp(2) - yr*qiukp(1) + rxqkuip(1) = yr*qkuip(3) - zr*qkuip(2) + rxqkuip(2) = zr*qkuip(1) - xr*qkuip(3) + rxqkuip(3) = xr*qkuip(2) - yr*qkuip(1) +c +c calculate scalar products for permanent components +c + sc(2) = di(1)*dk(1) + di(2)*dk(2) + di(3)*dk(3) + sc(3) = di(1)*xr + di(2)*yr + di(3)*zr + sc(4) = dk(1)*xr + dk(2)*yr + dk(3)*zr + sc(5) = qir(1)*xr + qir(2)*yr + qir(3)*zr + sc(6) = qkr(1)*xr + qkr(2)*yr + qkr(3)*zr + sc(7) = qir(1)*dk(1) + qir(2)*dk(2) + qir(3)*dk(3) + sc(8) = qkr(1)*di(1) + qkr(2)*di(2) + qkr(3)*di(3) + sc(9) = qir(1)*qkr(1) + qir(2)*qkr(2) + qir(3)*qkr(3) + sc(10) = qi(1)*qk(1) + qi(2)*qk(2) + qi(3)*qk(3) + & + qi(4)*qk(4) + qi(5)*qk(5) + qi(6)*qk(6) + & + qi(7)*qk(7) + qi(8)*qk(8) + qi(9)*qk(9) +c +c calculate scalar products for induced components +c + sci(1) = uind(1,i)*dk(1) + uind(2,i)*dk(2) + & + uind(3,i)*dk(3) + di(1)*uind(1,k) + & + di(2)*uind(2,k) + di(3)*uind(3,k) + sci(2) = uind(1,i)*uind(1,k) + uind(2,i)*uind(2,k) + & + uind(3,i)*uind(3,k) + sci(3) = uind(1,i)*xr + uind(2,i)*yr + uind(3,i)*zr + sci(4) = uind(1,k)*xr + uind(2,k)*yr + uind(3,k)*zr + sci(7) = qir(1)*uind(1,k) + qir(2)*uind(2,k) + & + qir(3)*uind(3,k) + sci(8) = qkr(1)*uind(1,i) + qkr(2)*uind(2,i) + & + qkr(3)*uind(3,i) + scip(1) = uinp(1,i)*dk(1) + uinp(2,i)*dk(2) + & + uinp(3,i)*dk(3) + di(1)*uinp(1,k) + & + di(2)*uinp(2,k) + di(3)*uinp(3,k) + scip(2) = uind(1,i)*uinp(1,k)+uind(2,i)*uinp(2,k) + & + uind(3,i)*uinp(3,k)+uinp(1,i)*uind(1,k) + & + uinp(2,i)*uind(2,k)+uinp(3,i)*uind(3,k) + scip(3) = uinp(1,i)*xr + uinp(2,i)*yr + uinp(3,i)*zr + scip(4) = uinp(1,k)*xr + uinp(2,k)*yr + uinp(3,k)*zr + scip(7) = qir(1)*uinp(1,k) + qir(2)*uinp(2,k) + & + qir(3)*uinp(3,k) + scip(8) = qkr(1)*uinp(1,i) + qkr(2)*uinp(2,i) + & + qkr(3)*uinp(3,i) +c +c calculate the gl functions for permanent components +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) + gl(4) = sc(5)*sc(6) + gl(5) = -4.0d0 * sc(9) + gl(6) = sc(2) + gl(7) = 2.0d0 * (sc(7)-sc(8)) + gl(8) = 2.0d0 * sc(10) +c +c calculate the gl functions for induced components +c + gli(1) = ck*sci(3) - ci*sci(4) + gli(2) = -sc(3)*sci(4) - sci(3)*sc(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) + gli(6) = sci(1) + gli(7) = 2.0d0 * (sci(7)-sci(8)) + glip(1) = ck*scip(3) - ci*scip(4) + glip(2) = -sc(3)*scip(4) - scip(3)*sc(4) + glip(3) = scip(3)*sc(6) - scip(4)*sc(5) + glip(6) = scip(1) + glip(7) = 2.0d0 * (scip(7)-scip(8)) +c +c compute the energy contributions for this interaction +c + e = rr1*gl(0) + rr3*(gl(1)+gl(6)) + & + rr5*(gl(2)+gl(7)+gl(8)) + & + rr7*(gl(3)+gl(5)) + rr9*gl(4) + ei = 0.5d0*(rr3*(gli(1)+gli(6))*psc3 + & + rr5*(gli(2)+gli(7))*psc5 + & + rr7*gli(3)*psc7) + e = f * e + ei = f * ei + if (use_polymer) then + if (r2 .le. polycut2) then + e = e * mscale(kk) + end if + end if + if (use_group) then + e = e * fgrp +c ei = ei * fgrp + end if + if (ii .eq. kk) then + e = 0.5d0 * e + ei = 0.5d0 * ei + end if + em = em - e + ep = ep - ei +c +c increment the total intermolecular energy +c + if (molcule(ii) .ne. molcule(kk)) then + einter = einter - e - ei + end if +c +c intermediate variables for the permanent components +c + gf(1) = rr3*gl(0) + rr5*(gl(1)+gl(6)) + & + rr7*(gl(2)+gl(7)+gl(8)) + & + rr9*(gl(3)+gl(5)) + rr11*gl(4) + gf(2) = -ck*rr3 + sc(4)*rr5 - sc(6)*rr7 + gf(3) = ci*rr3 + sc(3)*rr5 + sc(5)*rr7 + gf(4) = 2.0d0 * rr5 + gf(5) = 2.0d0 * (-ck*rr5+sc(4)*rr7-sc(6)*rr9) + gf(6) = 2.0d0 * (-ci*rr5-sc(3)*rr7-sc(5)*rr9) + gf(7) = 4.0d0 * rr7 +c +c intermediate variables for the induced components +c + gfi(1) = 0.5d0 * rr5 * ((gli(1)+gli(6))*psc3 + & + (glip(1)+glip(6))*dsc3 + & + scip(2)*scale3i) + & + 0.5d0 * rr7 * ((gli(7)+gli(2))*psc5 + & + (glip(7)+glip(2))*dsc5 + & - (sci(3)*scip(4)+scip(3)*sci(4))*scale5i) + & + 0.5d0 * rr9 * (gli(3)*psc7+glip(3)*dsc7) + gfi(2) = -rr3*ck + rr5*sc(4) - rr7*sc(6) + gfi(3) = rr3*ci + rr5*sc(3) + rr7*sc(5) + gfi(4) = 2.0d0 * rr5 + gfi(5) = rr7 * (sci(4)*psc7+scip(4)*dsc7) + gfi(6) = -rr7 * (sci(3)*psc7+scip(3)*dsc7) +c +c get the permanent force components +c + ftm2(1) = gf(1)*xr + gf(2)*di(1) + gf(3)*dk(1) + & + gf(4)*(qkdi(1)-qidk(1)) + gf(5)*qir(1) + & + gf(6)*qkr(1) + gf(7)*(qiqkr(1)+qkqir(1)) + ftm2(2) = gf(1)*yr + gf(2)*di(2) + gf(3)*dk(2) + & + gf(4)*(qkdi(2)-qidk(2)) + gf(5)*qir(2) + & + gf(6)*qkr(2) + gf(7)*(qiqkr(2)+qkqir(2)) + ftm2(3) = gf(1)*zr + gf(2)*di(3) + gf(3)*dk(3) + & + gf(4)*(qkdi(3)-qidk(3)) + gf(5)*qir(3) + & + gf(6)*qkr(3) + gf(7)*(qiqkr(3)+qkqir(3)) +c +c get the induced force components +c + ftm2i(1) = gfi(1)*xr + 0.5d0* + & (- rr3*ck*(uind(1,i)*psc3+uinp(1,i)*dsc3) + & + rr5*sc(4)*(uind(1,i)*psc5+uinp(1,i)*dsc5) + & - rr7*sc(6)*(uind(1,i)*psc7+uinp(1,i)*dsc7)) + & + (rr3*ci*(uind(1,k)*psc3+uinp(1,k)*dsc3) + & + rr5*sc(3)*(uind(1,k)*psc5+uinp(1,k)*dsc5) + & + rr7*sc(5)*(uind(1,k)*psc7+uinp(1,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & + sci(3)*uinp(1,k)+scip(3)*uind(1,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(1) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(1) + & + 0.5d0*gfi(4)*((qkui(1)-qiuk(1))*psc5 + & + (qkuip(1)-qiukp(1))*dsc5) + & + gfi(5)*qir(1) + gfi(6)*qkr(1) + ftm2i(2) = gfi(1)*yr + 0.5d0* + & (- rr3*ck*(uind(2,i)*psc3+uinp(2,i)*dsc3) + & + rr5*sc(4)*(uind(2,i)*psc5+uinp(2,i)*dsc5) + & - rr7*sc(6)*(uind(2,i)*psc7+uinp(2,i)*dsc7)) + & + (rr3*ci*(uind(2,k)*psc3+uinp(2,k)*dsc3) + & + rr5*sc(3)*(uind(2,k)*psc5+uinp(2,k)*dsc5) + & + rr7*sc(5)*(uind(2,k)*psc7+uinp(2,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & + sci(3)*uinp(2,k)+scip(3)*uind(2,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(2) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(2) + & + 0.5d0*gfi(4)*((qkui(2)-qiuk(2))*psc5 + & + (qkuip(2)-qiukp(2))*dsc5) + & + gfi(5)*qir(2) + gfi(6)*qkr(2) + ftm2i(3) = gfi(1)*zr + 0.5d0* + & (- rr3*ck*(uind(3,i)*psc3+uinp(3,i)*dsc3) + & + rr5*sc(4)*(uind(3,i)*psc5+uinp(3,i)*dsc5) + & - rr7*sc(6)*(uind(3,i)*psc7+uinp(3,i)*dsc7)) + & + (rr3*ci*(uind(3,k)*psc3+uinp(3,k)*dsc3) + & + rr5*sc(3)*(uind(3,k)*psc5+uinp(3,k)*dsc5) + & + rr7*sc(5)*(uind(3,k)*psc7+uinp(3,k)*dsc7))*0.5d0 + & + rr5*scale5i*(sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & + sci(3)*uinp(3,k)+scip(3)*uind(3,k))*0.5d0 + & + 0.5d0*(sci(4)*psc5+scip(4)*dsc5)*rr5*di(3) + & + 0.5d0*(sci(3)*psc5+scip(3)*dsc5)*rr5*dk(3) + & + 0.5d0*gfi(4)*((qkui(3)-qiuk(3))*psc5 + & + (qkuip(3)-qiukp(3))*dsc5) + & + gfi(5)*qir(3) + gfi(6)*qkr(3) +c +c account for partially excluded induced interactions +c + temp3 = 0.5d0 * rr3 * ((gli(1)+gli(6))*pscale(kk) + & +(glip(1)+glip(6))*dscale(kk)) + temp5 = 0.5d0 * rr5 * ((gli(2)+gli(7))*pscale(kk) + & +(glip(2)+glip(7))*dscale(kk)) + temp7 = 0.5d0 * rr7 * (gli(3)*pscale(kk) + & +glip(3)*dscale(kk)) + fridmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + & + temp7*ddsc7(1) + fridmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + & + temp7*ddsc7(2) + fridmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) + & + temp7*ddsc7(3) +c +c find some scaling terms for induced-induced force +c + temp3 = 0.5d0 * rr3 * uscale(kk) * scip(2) + temp5 = -0.5d0 * rr5 * uscale(kk) + & * (sci(3)*scip(4)+scip(3)*sci(4)) + findmp(1) = temp3*ddsc3(1) + temp5*ddsc5(1) + findmp(2) = temp3*ddsc3(2) + temp5*ddsc5(2) + findmp(3) = temp3*ddsc3(3) + temp5*ddsc5(3) +c +c modify induced force for partially excluded interactions +c + ftm2i(1) = ftm2i(1) - fridmp(1) - findmp(1) + ftm2i(2) = ftm2i(2) - fridmp(2) - findmp(2) + ftm2i(3) = ftm2i(3) - fridmp(3) - findmp(3) +c +c correction to convert mutual to direct polarization force +c + if (poltyp .eq. 'DIRECT') then + gfd = 0.5d0 * (rr5*scip(2)*scale3i + & - rr7*(scip(3)*sci(4)+sci(3)*scip(4))*scale5i) + temp5 = 0.5d0 * rr5 * scale5i + fdir(1) = gfd*xr + temp5 + & * (sci(4)*uinp(1,i)+scip(4)*uind(1,i) + & +sci(3)*uinp(1,k)+scip(3)*uind(1,k)) + fdir(2) = gfd*yr + temp5 + & * (sci(4)*uinp(2,i)+scip(4)*uind(2,i) + & +sci(3)*uinp(2,k)+scip(3)*uind(2,k)) + fdir(3) = gfd*zr + temp5 + & * (sci(4)*uinp(3,i)+scip(4)*uind(3,i) + & +sci(3)*uinp(3,k)+scip(3)*uind(3,k)) + ftm2i(1) = ftm2i(1) - fdir(1) + findmp(1) + ftm2i(2) = ftm2i(2) - fdir(2) + findmp(2) + ftm2i(3) = ftm2i(3) - fdir(3) + findmp(3) + end if +c +c intermediate terms for induced torque on multipoles +c + gti(2) = 0.5d0 * rr5 * (sci(4)*psc5+scip(4)*dsc5) + gti(3) = 0.5d0 * rr5 * (sci(3)*psc5+scip(3)*dsc5) + gti(4) = gfi(4) + gti(5) = gfi(5) + gti(6) = gfi(6) +c +c get the permanent torque components +c + ttm2(1) = -rr3*dixdk(1) + gf(2)*dixr(1) - gf(5)*rxqir(1) + & + gf(4)*(dixqkr(1)+dkxqir(1)+rxqidk(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqikr(1)+qkrxqir(1)) + ttm2(2) = -rr3*dixdk(2) + gf(2)*dixr(2) - gf(5)*rxqir(2) + & + gf(4)*(dixqkr(2)+dkxqir(2)+rxqidk(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqikr(2)+qkrxqir(2)) + ttm2(3) = -rr3*dixdk(3) + gf(2)*dixr(3) - gf(5)*rxqir(3) + & + gf(4)*(dixqkr(3)+dkxqir(3)+rxqidk(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqikr(3)+qkrxqir(3)) + ttm3(1) = rr3*dixdk(1) + gf(3)*dkxr(1) - gf(6)*rxqkr(1) + & - gf(4)*(dixqkr(1)+dkxqir(1)+rxqkdi(1)-2.0d0*qixqk(1)) + & - gf(7)*(rxqkir(1)-qkrxqir(1)) + ttm3(2) = rr3*dixdk(2) + gf(3)*dkxr(2) - gf(6)*rxqkr(2) + & - gf(4)*(dixqkr(2)+dkxqir(2)+rxqkdi(2)-2.0d0*qixqk(2)) + & - gf(7)*(rxqkir(2)-qkrxqir(2)) + ttm3(3) = rr3*dixdk(3) + gf(3)*dkxr(3) - gf(6)*rxqkr(3) + & - gf(4)*(dixqkr(3)+dkxqir(3)+rxqkdi(3)-2.0d0*qixqk(3)) + & - gf(7)*(rxqkir(3)-qkrxqir(3)) +c +c get the induced torque components +c + ttm2i(1) = -rr3*(dixuk(1)*psc3+dixukp(1)*dsc3)*0.5d0 + & + gti(2)*dixr(1) + gti(4)*((ukxqir(1)+rxqiuk(1))*psc5 + & +(ukxqirp(1)+rxqiukp(1))*dsc5)*0.5d0 - gti(5)*rxqir(1) + ttm2i(2) = -rr3*(dixuk(2)*psc3+dixukp(2)*dsc3)*0.5d0 + & + gti(2)*dixr(2) + gti(4)*((ukxqir(2)+rxqiuk(2))*psc5 + & +(ukxqirp(2)+rxqiukp(2))*dsc5)*0.5d0 - gti(5)*rxqir(2) + ttm2i(3) = -rr3*(dixuk(3)*psc3+dixukp(3)*dsc3)*0.5d0 + & + gti(2)*dixr(3) + gti(4)*((ukxqir(3)+rxqiuk(3))*psc5 + & +(ukxqirp(3)+rxqiukp(3))*dsc5)*0.5d0 - gti(5)*rxqir(3) + ttm3i(1) = -rr3*(dkxui(1)*psc3+dkxuip(1)*dsc3)*0.5d0 + & + gti(3)*dkxr(1) - gti(4)*((uixqkr(1)+rxqkui(1))*psc5 + & +(uixqkrp(1)+rxqkuip(1))*dsc5)*0.5d0 - gti(6)*rxqkr(1) + ttm3i(2) = -rr3*(dkxui(2)*psc3+dkxuip(2)*dsc3)*0.5d0 + & + gti(3)*dkxr(2) - gti(4)*((uixqkr(2)+rxqkui(2))*psc5 + & +(uixqkrp(2)+rxqkuip(2))*dsc5)*0.5d0 - gti(6)*rxqkr(2) + ttm3i(3) = -rr3*(dkxui(3)*psc3+dkxuip(3)*dsc3)*0.5d0 + & + gti(3)*dkxr(3) - gti(4)*((uixqkr(3)+rxqkui(3))*psc5 + & +(uixqkrp(3)+rxqkuip(3))*dsc5)*0.5d0 - gti(6)*rxqkr(3) +c +c handle the case where scaling is used +c + do j = 1, 3 + ftm2(j) = f * ftm2(j) + ftm2i(j) = f * ftm2i(j) + ttm2(j) = f * ttm2(j) + ttm2i(j) = f * ttm2i(j) + ttm3(j) = f * ttm3(j) + ttm3i(j) = f * ttm3i(j) + end do + if (use_polymer) then + if (r2 .le. polycut2) then + do j = 1, 3 + ftm2(j) = ftm2(j) * mscale(kk) + ttm2(j) = ttm2(j) * mscale(kk) + ttm3(j) = ttm3(j) * mscale(kk) + end do + end if + end if + if (use_group) then + do j = 1, 3 + ftm2(j) = ftm2(j) * fgrp + ttm2(j) = ttm2(j) * fgrp + ttm3(j) = ttm3(j) * fgrp +c ftm2i(j) = ftm2i(j) * fgrp +c ttm2i(j) = ttm2i(j) * fgrp +c ttm3i(j) = ttm3i(j) * fgrp + end do + end if + if (ii .eq. kk) then + do j = 1, 3 + ftm2(j) = 0.5d0 * ftm2(j) + ftm2i(j) = 0.5d0 * ftm2i(j) + ttm2(j) = 0.5d0 * ttm2(j) + ttm2i(j) = 0.5d0 * ttm2i(j) + ttm3(j) = 0.5d0 * ttm3(j) + ttm3i(j) = 0.5d0 * ttm3i(j) + end do + end if +c +c increment gradient due to force and torque on first site +c + dem(1,ii) = dem(1,ii) - ftm2(1) + dem(2,ii) = dem(2,ii) - ftm2(2) + dem(3,ii) = dem(3,ii) - ftm2(3) + dep(1,ii) = dep(1,ii) - ftm2i(1) + dep(2,ii) = dep(2,ii) - ftm2i(2) + dep(3,ii) = dep(3,ii) - ftm2i(3) + call torque (i,ttm2,ttm2i,frcxi,frcyi,frczi) +c +c increment gradient due to force and torque on second site +c + dem(1,kk) = dem(1,kk) + ftm2(1) + dem(2,kk) = dem(2,kk) + ftm2(2) + dem(3,kk) = dem(3,kk) + ftm2(3) + dep(1,kk) = dep(1,kk) + ftm2i(1) + dep(2,kk) = dep(2,kk) + ftm2i(2) + dep(3,kk) = dep(3,kk) + ftm2i(3) + call torque (k,ttm3,ttm3i,frcxk,frcyk,frczk) +c +c increment the internal virial tensor components +c + iaz = iz + iax = ix + iay = iy + kaz = kz + kax = kx + kay = ky + if (iaz .eq. 0) iaz = ii + if (iax .eq. 0) iax = ii + if (iay .eq. 0) iay = ii + if (kaz .eq. 0) kaz = kk + if (kax .eq. 0) kax = kk + if (kay .eq. 0) kay = kk + xiz = x(iaz) - x(ii) + yiz = y(iaz) - y(ii) + ziz = z(iaz) - z(ii) + xix = x(iax) - x(ii) + yix = y(iax) - y(ii) + zix = z(iax) - z(ii) + xiy = x(iay) - x(ii) + yiy = y(iay) - y(ii) + ziy = z(iay) - z(ii) + xkz = x(kaz) - x(kk) + ykz = y(kaz) - y(kk) + zkz = z(kaz) - z(kk) + xkx = x(kax) - x(kk) + ykx = y(kax) - y(kk) + zkx = z(kax) - z(kk) + xky = x(kay) - x(kk) + yky = y(kay) - y(kk) + zky = z(kay) - z(kk) + vxx = -xr*(ftm2(1)+ftm2i(1)) + xix*frcxi(1) + & + xiy*frcyi(1) + xiz*frczi(1) + xkx*frcxk(1) + & + xky*frcyk(1) + xkz*frczk(1) + vyx = -yr*(ftm2(1)+ftm2i(1)) + yix*frcxi(1) + & + yiy*frcyi(1) + yiz*frczi(1) + ykx*frcxk(1) + & + yky*frcyk(1) + ykz*frczk(1) + vzx = -zr*(ftm2(1)+ftm2i(1)) + zix*frcxi(1) + & + ziy*frcyi(1) + ziz*frczi(1) + zkx*frcxk(1) + & + zky*frcyk(1) + zkz*frczk(1) + vyy = -yr*(ftm2(2)+ftm2i(2)) + yix*frcxi(2) + & + yiy*frcyi(2) + yiz*frczi(2) + ykx*frcxk(2) + & + yky*frcyk(2) + ykz*frczk(2) + vzy = -zr*(ftm2(2)+ftm2i(2)) + zix*frcxi(2) + & + ziy*frcyi(2) + ziz*frczi(2) + zkx*frcxk(2) + & + zky*frcyk(2) + zkz*frczk(2) + vzz = -zr*(ftm2(3)+ftm2i(3)) + zix*frcxi(3) + & + ziy*frcyi(3) + ziz*frczi(3) + zkx*frcxk(3) + & + zky*frcyk(3) + zkz*frczk(3) + vir(1,1) = vir(1,1) - vxx + vir(2,1) = vir(2,1) - vyx + vir(3,1) = vir(3,1) - vzx + vir(1,2) = vir(1,2) - vyx + vir(2,2) = vir(2,2) - vyy + vir(3,2) = vir(3,2) - vzy + vir(1,3) = vir(1,3) - vzx + vir(2,3) = vir(2,3) - vzy + vir(3,3) = vir(3,3) - vzz + end if + end do + 20 continue + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + do j = 1, np11(ii) + dscale(ip11(j,ii)) = 1.0d0 + uscale(ip11(j,ii)) = 1.0d0 + end do + do j = 1, np12(ii) + dscale(ip12(j,ii)) = 1.0d0 + uscale(ip12(j,ii)) = 1.0d0 + end do + do j = 1, np13(ii) + dscale(ip13(j,ii)) = 1.0d0 + uscale(ip13(j,ii)) = 1.0d0 + end do + do j = 1, np14(ii) + dscale(ip14(j,ii)) = 1.0d0 + uscale(ip14(j,ii)) = 1.0d0 + end do +cqmmm + 99 continue + end do + end if +c +c perform deallocation of some local arrays +c + deallocate (mscale) + deallocate (pscale) + deallocate (dscale) + deallocate (uscale) + return + end + diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/empole2.f 6.2.06/source/empole2.f --- 6.2.06/source_orig/empole2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/empole2.f 2013-10-21 18:20:56.281885313 +0200 @@ -253,6 +253,9 @@ logical usei,usek logical reinduce character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm,kqmmm,ikqmmm c c c zero out the multipole and polarization first derivatives @@ -364,16 +367,41 @@ dscale(ip14(j,ii)) = d4scale uscale(ip14(j,ii)) = u4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + uscale(ipole(j)) = uscale(ipole(j)) * qmmmscale + end if + end do do k = i+1, npole kk = ipole(k) kz = zaxis(k) kx = xaxis(k) ky = yaxis(k) usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) +cqmmm + kqmmm = mod(qmmm(kk),3) + ikqmmm = iqmmm + kqmmm proceed = .true. if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. usek) +cqmmm + if (proceed) proceed = (ikqmmm .eq. 0) if (.not. proceed) goto 10 xr = x(kk) - x(ii) yr = y(kk) - y(ii) @@ -854,6 +882,13 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + dscale(ipole(j)) = 1.0d0 + uscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/empole3.f 6.2.06/source/empole3.f --- 6.2.06/source_orig/empole3.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/empole3.f 2013-10-21 18:20:56.661885296 +0200 @@ -26,6 +26,8 @@ include 'mpole.i' include 'potent.i' integer i,ii +cqmmm + include 'qmmm.i' c c c choose the method for summing over multipole interactions @@ -43,6 +45,8 @@ call empole3a end if end if +cqmmm + if (nbinqm .ne. 0 .and. e4qmmm .eq. 0) call empole3qmmm c c zero out energy terms and analysis which are not in use c @@ -135,6 +139,9 @@ logical usei,usek logical muse,puse character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out multipole and polarization energy and partitioning @@ -226,6 +233,22 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do c c decide whether to compute the current interaction c @@ -397,6 +420,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -462,6 +490,22 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do c c decide whether to compute the current interaction c @@ -638,6 +682,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -735,6 +784,9 @@ logical usei,usek logical muse,puse character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out multipole and polarization energy and partitioning @@ -826,6 +878,24 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, nelst(i) + jqmmm = mod(qmmm(ipole(elst(j,i))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = mscale(ipole(elst(j,i))) + & * qmmmscale + pscale(ipole(elst(j,i))) = pscale(ipole(elst(j,i))) + & * qmmmscale + end if + end do c c decide whether to compute the current interaction c @@ -998,6 +1068,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(i) + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -1245,6 +1320,9 @@ logical muse,puse character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the intramolecular portion of the Ewald energy @@ -1313,6 +1391,22 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do do k = i+1, npole kk = ipole(k) xr = x(kk) - x(ii) @@ -1487,6 +1581,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -1548,6 +1647,22 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do do k = i, npole kk = ipole(k) do j = 1, ncell @@ -1724,6 +1839,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -1977,6 +2097,9 @@ logical muse,puse character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the intramolecular portion of the Ewald energy @@ -2072,6 +2195,24 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, nelst(i) + jqmmm = mod(qmmm(ipole(elst(j,i))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = mscale(ipole(elst(j,i))) + & * qmmmscale + pscale(ipole(elst(j,i))) = pscale(ipole(elst(j,i))) + & * qmmmscale + end if + end do do kkk = 1, nelst(i) k = elst(kkk,i) kk = ipole(k) @@ -2247,6 +2388,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(i) + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -2290,3 +2436,647 @@ deallocate (aeptt) return end +c +c +c ##################################################### +c ## ## +c ## subroutine empole3qmmm -- QM/MM corrections ## +c ## ## +c ##################################################### +c +c +c "empole3qmmm" corrects the atomic multipole and dipole +c polarizability interaction energy using a double loop +c only MM-MM, MM-Y and Y-Y interactions must be retained +c +c + subroutine empole3qmmm + implicit none + include 'sizes.i' + include 'action.i' + include 'analyz.i' + include 'atmtyp.i' + include 'atoms.i' + include 'bound.i' + include 'boxes.i' + include 'cell.i' + include 'chgpot.i' + include 'couple.i' + include 'energi.i' + include 'group.i' + include 'inform.i' + include 'inter.i' + include 'iounit.i' + include 'math.i' + include 'molcul.i' + include 'mplpot.i' + include 'mpole.i' + include 'polar.i' + include 'polgrp.i' + include 'polpot.i' + include 'potent.i' + include 'shunt.i' + include 'usage.i' + integer i,j,k + integer ii,kk + integer ix,iy,iz + integer kx,ky,kz + real*8 e,ei,fgrp + real*8 f,fm,fp + real*8 r,r2,xr,yr,zr + real*8 damp,expdamp + real*8 pdi,pti,pgamma + real*8 rr1,rr3,rr5 + real*8 rr7,rr9 + real*8 ci,dix,diy,diz + real*8 uix,uiy,uiz + real*8 qixx,qixy,qixz + real*8 qiyy,qiyz,qizz + real*8 ck,dkx,dky,dkz + real*8 ukx,uky,ukz + real*8 qkxx,qkxy,qkxz + real*8 qkyy,qkyz,qkzz + real*8 qix,qiy,qiz + real*8 qkx,qky,qkz + real*8 scale3,scale5 + real*8 scale7 + real*8 sc(10),sci(8) + real*8 gl(0:4),gli(3) + real*8, allocatable :: mscale(:) + real*8, allocatable :: pscale(:) + logical proceed + logical header,huge + logical usei,usek + logical muse,puse + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm,kqmmm,ikqmmm +c +c +c + header = .true. +c +c check the sign of multipole components at chiral sites +c + call chkpole +c +c rotate the multipole components into the global frame +c + call rotpole +c +c compute the induced dipoles at each polarizable atom +c + call induce +c +c perform dynamic allocation of some local arrays +c + allocate (mscale(n)) + allocate (pscale(n)) +c +c set arrays needed to scale connected atom interactions +c + if (npole .eq. 0) return + do i = 1, n + mscale(i) = 1.0d0 + pscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = electric / dielec + mode = 'MPOLE' + call switch (mode) +c +c calculate the multipole interaction energy term +c + do i = 1, npole-1 + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + dix = rpole(2,i) + diy = rpole(3,i) + diz = rpole(4,i) + qixx = rpole(5,i) + qixy = rpole(6,i) + qixz = rpole(7,i) + qiyy = rpole(9,i) + qiyz = rpole(10,i) + qizz = rpole(13,i) + uix = uind(1,i) + uiy = uind(2,i) + uiz = uind(3,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + do k = 1, np11(ii) + if (i14(j,ii) .eq. ip11(k,ii)) + & pscale(i14(j,ii)) = p4scale * p41scale + end do + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, n + jqmmm = mod(qmmm(j),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(j) = 1.0d0 + pscale(j) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(j) = mscale(j) * qmmmscale + pscale(j) = pscale(j) * qmmmscale + end if + end do +c +c decide whether to compute the current interaction +c + do k = i+1, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) +cqmmm + kqmmm = mod(qmmm(kk),3) + ikqmmm = iqmmm + kqmmm + proceed = .true. + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + if (.not. use_intra) proceed = .true. + if (proceed) proceed = (usei .or. usek) + if (proceed) proceed = (ikqmmm .ne. 0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + if (use_bounds) call image (xr,yr,zr) + r2 = xr*xr + yr* yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dkx = rpole(2,k) + dky = rpole(3,k) + dkz = rpole(4,k) + qkxx = rpole(5,k) + qkxy = rpole(6,k) + qkxz = rpole(7,k) + qkyy = rpole(9,k) + qkyz = rpole(10,k) + qkzz = rpole(13,k) + ukx = uind(1,k) + uky = uind(2,k) + ukz = uind(3,k) +c +c construct some intermediate quadrupole values +c + qix = qixx*xr + qixy*yr + qixz*zr + qiy = qixy*xr + qiyy*yr + qiyz*zr + qiz = qixz*xr + qiyz*yr + qizz*zr + qkx = qkxx*xr + qkxy*yr + qkxz*zr + qky = qkxy*xr + qkyy*yr + qkyz*zr + qkz = qkxz*xr + qkyz*yr + qkzz*zr +c +c calculate the scalar products for permanent multipoles +c + sc(2) = dix*dkx + diy*dky + diz*dkz + sc(3) = dix*xr + diy*yr + diz*zr + sc(4) = dkx*xr + dky*yr + dkz*zr + sc(5) = qix*xr + qiy*yr + qiz*zr + sc(6) = qkx*xr + qky*yr + qkz*zr + sc(7) = qix*dkx + qiy*dky + qiz*dkz + sc(8) = qkx*dix + qky*diy + qkz*diz + sc(9) = qix*qkx + qiy*qky + qiz*qkz + sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz) + & + qixx*qkxx + qiyy*qkyy + qizz*qkzz +c +c calculate the scalar products for polarization components +c + sci(2) = uix*dkx + dix*ukx + uiy*dky + & + diy*uky + uiz*dkz + diz*ukz + sci(3) = uix*xr + uiy*yr + uiz*zr + sci(4) = ukx*xr + uky*yr + ukz*zr + sci(7) = qix*ukx + qiy*uky + qiz*ukz + sci(8) = qkx*uix + qky*uiy + qkz*uiz +c +c calculate the gl functions for permanent multipoles +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + sc(2) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + & + 2.0d0*(sc(7)-sc(8)+sc(10)) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9) + gl(4) = sc(5)*sc(6) +c +c calculate the gl functions for polarization components +c + gli(1) = ck*sci(3) - ci*sci(4) + sci(2) + gli(2) = 2.0d0*(sci(7)-sci(8)) - sci(3)*sc(4) + & - sc(3)*sci(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) +c +c compute the energy contributions for this interaction +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + end if + end if + e = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5 + & + gl(3)*rr7 + gl(4)*rr9 + ei = gli(1)*rr3*scale3 + gli(2)*rr5*scale5 + & + gli(3)*rr7*scale7 +c +c apply the energy adjustments for scaled interactions +c + fm = f * mscale(kk) + fp = f * pscale(kk) + e = fm * e + ei = 0.5d0 * fp * ei +c +c scale the interaction based on its group membership; +c polarization cannot be group scaled as it is not pairwise +c + if (use_group) then + e = e * fgrp +c ei = ei * fgrp + end if +c +c increment the overall multipole and polarization energies +c + muse = (use_mpole .and. mscale(kk).ne.0.0d0) + puse = (use_polar .and. pscale(kk).ne.0.0d0) + if (muse) nem = nem - 1 + if (puse) nep = nep - 1 + em = em - e + ep = ep - ei + aem(ii) = aem(ii) - 0.5d0*e + aem(kk) = aem(kk) - 0.5d0*e + aep(ii) = aep(ii) - 0.5d0*ei + aep(kk) = aep(kk) - 0.5d0*ei +c +c increment the total intermolecular energy +c + if (molcule(ii) .ne. molcule(kk)) then + einter = einter - e - ei + end if +c +c print a message if the energy of this interaction is large +c + huge = (max(abs(e),abs(ei)) .gt. 100.0d0) + if (debug .or. (verbose.and.huge)) then + if (muse .or. puse) then + if (header) then + header = .false. + write (iout,10) + 10 format (/,' Removing Multipole and', + & ' Polarization Interactions :', + & //,' Type',14x,'Atom Names', + & 15x,'Distance',6x,'Energies', + & ' (MPol,Polar)',/) + end if + write (iout,20) ii,name(ii),kk,name(kk),r,e,ei + 20 format (' M-Pole',4x,2(i7,'-',a3),9x, + & f10.4,2x,2f12.4) + end if + end if + end if + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = 1, n + mscale(j) = 1.0d0 + pscale(j) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (.not. use_replica) return +c +c calculate interaction energy with other unit cells +c + do i = 1, npole + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(k) + pdi = pdamp(i) + pti = thole(i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) + ci = rpole(1,i) + dix = rpole(2,i) + diy = rpole(3,i) + diz = rpole(4,i) + qixx = rpole(5,i) + qixy = rpole(6,i) + qixz = rpole(7,i) + qiyy = rpole(9,i) + qiyz = rpole(10,i) + qizz = rpole(13,i) + uix = uind(1,i) + uiy = uind(2,i) + uiz = uind(3,i) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + if (iqmmm .eq. 0) goto 99 + do j = 1, n + jqmmm = mod(qmmm(j),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(j) = 1.0d0 + pscale(j) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(j) = mscale(j) * qmmmscale + pscale(j) = pscale(j) * qmmmscale + end if + end do +c +c decide whether to compute the current interaction +c + do k = i, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + proceed = .true. + if (proceed) proceed = (usei .or. usek) +c +c compute the energy contribution for this interaction +c + if (proceed) then + do j = 1, ncell + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + call imager (xr,yr,zr,j) + r2 = xr*xr + yr* yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dkx = rpole(2,k) + dky = rpole(3,k) + dkz = rpole(4,k) + qkxx = rpole(5,k) + qkxy = rpole(6,k) + qkxz = rpole(7,k) + qkyy = rpole(9,k) + qkyz = rpole(10,k) + qkzz = rpole(13,k) + ukx = uind(1,k) + uky = uind(2,k) + ukz = uind(3,k) +c +c construct some intermediate quadrupole values +c + qix = qixx*xr + qixy*yr + qixz*zr + qiy = qixy*xr + qiyy*yr + qiyz*zr + qiz = qixz*xr + qiyz*yr + qizz*zr + qkx = qkxx*xr + qkxy*yr + qkxz*zr + qky = qkxy*xr + qkyy*yr + qkyz*zr + qkz = qkxz*xr + qkyz*yr + qkzz*zr +c +c calculate the scalar products for permanent multipoles +c + sc(2) = dix*dkx + diy*dky + diz*dkz + sc(3) = dix*xr + diy*yr + diz*zr + sc(4) = dkx*xr + dky*yr + dkz*zr + sc(5) = qix*xr + qiy*yr + qiz*zr + sc(6) = qkx*xr + qky*yr + qkz*zr + sc(7) = qix*dkx + qiy*dky + qiz*dkz + sc(8) = qkx*dix + qky*diy + qkz*diz + sc(9) = qix*qkx + qiy*qky + qiz*qkz + sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz) + & + qixx*qkxx + qiyy*qkyy + qizz*qkzz +c +c calculate the scalar products for polarization components +c + sci(2) = uix*dkx + dix*ukx + uiy*dky + & + diy*uky + uiz*dkz + diz*ukz + sci(3) = uix*xr + uiy*yr + uiz*zr + sci(4) = ukx*xr + uky*yr + ukz*zr + sci(7) = qix*ukx + qiy*uky + qiz*ukz + sci(8) = qkx*uix + qky*uiy + qkz*uiz +c +c calculate the gl functions for permanent multipoles +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + sc(2) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + & + 2.0d0*(sc(7)-sc(8)+sc(10)) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9) + gl(4) = sc(5)*sc(6) +c +c calculate the gl functions for polarization components +c + gli(1) = ck*sci(3) - ci*sci(4) + sci(2) + gli(2) = 2.0d0*(sci(7)-sci(8)) - sci(3)*sc(4) + & - sc(3)*sci(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) +c +c compute the energy contributions for this interaction +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + end if + end if + e = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5 + & + gl(3)*rr7 + gl(4)*rr9 + ei = gli(1)*rr3*scale3 + gli(2)*rr5*scale5 + & + gli(3)*rr7*scale7 +c +c apply the energy adjustments for scaled interactions +c + fm = f + fp = f + if (use_polymer) then + if (r2 .le. polycut2) then + fm = fm * mscale(kk) + fp = fp * pscale(kk) + end if + end if + e = fm * e + ei = 0.5d0 * fp * ei +c +c scale the interaction based on its group membership; +c polarization cannot be group scaled as it is not pairwise +c + if (use_group) then + e = e * fgrp +c ei = ei * fgrp + end if +c +c increment the overall multipole and polarization energies +c + if (ii .eq. kk) then + e = 0.5d0 * e + ei = 0.5d0 * ei + end if + nem = nem - 1 + nep = nep - 1 + em = em - e + ep = ep - ei + aem(ii) = aem(ii) - 0.5d0*e + aem(kk) = aem(kk) - 0.5d0*e + aep(ii) = aep(ii) - 0.5d0*ei + aep(kk) = aep(kk) - 0.5d0*ei +c +c increment the total intermolecular energy +c + einter = einter - e - ei +c +c print a message if the energy of this interaction is large +c + huge = (max(abs(e),abs(ei)) .gt. 100.0d0) + if (debug .or. (verbose.and.huge)) then + if (header) then + header = .false. + write (iout,30) + 30 format (/,' Removing Multipole and', + & ' Polarization Interactions :', + & //,' Type',14x,'Atom Names', + & 15x,'Distance',6x,'Energies', + & ' (MPol,Polar)',/) + end if + write (iout,40) ii,name(ii),kk,name(kk),r,e,ei + 40 format (' M-Pole',4x,2(i7,'-',a3),1x, + & '(X)',5x,f10.4,2x,2f12.4) + end if + end if + end do + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = 1, n + mscale(j) = 1.0d0 + pscale(j) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do +cqmmm + 99 continue + end do +c +c perform deallocation of some local arrays +c + deallocate (mscale) + deallocate (pscale) + return + end + diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/empole.f 6.2.06/source/empole.f --- 6.2.06/source_orig/empole.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/empole.f 2013-10-21 18:20:56.629885298 +0200 @@ -21,6 +21,9 @@ include 'cutoff.i' include 'energi.i' include 'potent.i' +cqmmm + include 'sizes.i' + include 'qmmm.i' c c c choose the method for summing over multipole interactions @@ -38,6 +41,8 @@ call empole0a end if end if +cqmmm + if (nbinqm .ne. 0 .and. e4qmmm .eq. 0) call empole0qmmm c c zero out potential energies which are not in use c @@ -106,6 +111,9 @@ real*8, allocatable :: pscale(:) logical proceed,usei,usek character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the multipole and polarization energies @@ -190,6 +198,22 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do c c decide whether to compute the current interaction c @@ -327,6 +351,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -392,6 +421,22 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do c c decide whether to compute the current interaction c @@ -540,6 +585,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -625,6 +675,9 @@ real*8, allocatable :: pscale(:) logical proceed,usei,usek character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the multipole and polarization energies @@ -709,6 +762,24 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, nelst(i) + jqmmm = mod(qmmm(ipole(elst(j,i))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = mscale(ipole(elst(j,i))) + & * qmmmscale + pscale(ipole(elst(j,i))) = pscale(ipole(elst(j,i))) + & * qmmmscale + end if + end do c c decide whether to compute the current interaction c @@ -847,6 +918,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(i) + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -1064,6 +1140,9 @@ real*8, allocatable :: pscale(:) character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c perform dynamic allocation of some local arrays @@ -1127,6 +1206,22 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do do k = i+1, npole kk = ipole(k) xr = x(kk) - x(ii) @@ -1262,6 +1357,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -1323,6 +1423,22 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do do k = i, npole kk = ipole(k) do j = 1, ncell @@ -1470,6 +1586,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -1688,6 +1809,9 @@ real*8, allocatable :: pscale(:) character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c perform dynamic allocation of some local arrays @@ -1769,6 +1893,24 @@ mscale(i15(j,ii)) = m5scale pscale(i15(j,ii)) = p5scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, nelst(i) + jqmmm = mod(qmmm(ipole(elst(j,i))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(elst(j,i))) = mscale(ipole(elst(j,i))) + & * qmmmscale + pscale(ipole(elst(j,i))) = pscale(ipole(elst(j,i))) + & * qmmmscale + end if + end do do kkk = 1, nelst(i) k = elst(kkk,i) kk = ipole(k) @@ -1905,6 +2047,11 @@ c c reset interaction scaling coefficients for connected atoms c +cqmmm + do j = 1, nelst(i) + mscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + end do do j = 1, n12(ii) mscale(i12(j,ii)) = 1.0d0 pscale(i12(j,ii)) = 1.0d0 @@ -2147,3 +2294,572 @@ deallocate (fphi) return end +c +c +c ##################################################### +c ## ## +c ## subroutine empole0qmmm -- QM/MM corrections ## +c ## ## +c ##################################################### +c +c +c "empole0qmmm" corrects the atomic multipole and dipole +c polarizability interaction energy using a double loop +c only MM-MM, MM-Y and Y-Y interactions must be retained +c +c + subroutine empole0qmmm + implicit none + include 'sizes.i' + include 'atoms.i' + include 'bound.i' + include 'boxes.i' + include 'cell.i' + include 'chgpot.i' + include 'couple.i' + include 'energi.i' + include 'group.i' + include 'math.i' + include 'mplpot.i' + include 'mpole.i' + include 'polar.i' + include 'polgrp.i' + include 'polpot.i' + include 'shunt.i' + include 'usage.i' + integer i,j,k + integer ii,kk + integer ix,iy,iz + integer kx,ky,kz + real*8 e,ei,fgrp + real*8 f,fm,fp + real*8 r,r2,xr,yr,zr + real*8 damp,expdamp + real*8 pdi,pti,pgamma + real*8 rr1,rr3,rr5 + real*8 rr7,rr9 + real*8 ci,dix,diy,diz + real*8 uix,uiy,uiz + real*8 qixx,qixy,qixz + real*8 qiyy,qiyz,qizz + real*8 ck,dkx,dky,dkz + real*8 ukx,uky,ukz + real*8 qkxx,qkxy,qkxz + real*8 qkyy,qkyz,qkzz + real*8 qix,qiy,qiz + real*8 qkx,qky,qkz + real*8 scale3,scale5 + real*8 scale7 + real*8 sc(10),sci(8) + real*8 gl(0:4),gli(3) + real*8, allocatable :: mscale(:) + real*8, allocatable :: pscale(:) + logical proceed,usei,usek + character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm,kqmmm,ikqmmm +c +c +c check the sign of multipole components at chiral sites +c + call chkpole +c +c rotate the multipole components into the global frame +c + call rotpole +c +c compute the induced dipoles at each polarizable atom +c + call induce +c +c perform dynamic allocation of some local arrays +c + allocate (mscale(n)) + allocate (pscale(n)) +c +c set arrays needed to scale connected atom interactions +c + if (npole .eq. 0) return + do i = 1, n + mscale(i) = 1.0d0 + pscale(i) = 1.0d0 + end do +c +c set conversion factor, cutoff and switching coefficients +c + f = electric / dielec + mode = 'MPOLE' + call switch (mode) +c +c calculate the multipole interaction energy term +c + do i = 1, npole-1 + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + dix = rpole(2,i) + diy = rpole(3,i) + diz = rpole(4,i) + qixx = rpole(5,i) + qixy = rpole(6,i) + qixz = rpole(7,i) + qiyy = rpole(9,i) + qiyz = rpole(10,i) + qizz = rpole(13,i) + uix = uind(1,i) + uiy = uind(2,i) + uiz = uind(3,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + do k = 1, np11(ii) + if (i14(j,ii) .eq. ip11(k,ii)) + & pscale(i14(j,ii)) = p4scale * p41scale + end do + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do +c +c decide whether to compute the current interaction +c + do k = i+1, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) +cqmmm + kqmmm = mod(qmmm(kk),3) + ikqmmm = iqmmm + kqmmm + proceed = .true. + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + if (.not. use_intra) proceed = .true. + if (proceed) proceed = (usei .or. usek) +cqmmm + if (proceed) proceed = (ikqmmm .ne. 0) +c +c compute the energy contribution for this interaction +c + if (proceed) then + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + if (use_bounds) call image (xr,yr,zr) + r2 = xr*xr + yr* yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dkx = rpole(2,k) + dky = rpole(3,k) + dkz = rpole(4,k) + qkxx = rpole(5,k) + qkxy = rpole(6,k) + qkxz = rpole(7,k) + qkyy = rpole(9,k) + qkyz = rpole(10,k) + qkzz = rpole(13,k) + ukx = uind(1,k) + uky = uind(2,k) + ukz = uind(3,k) +c +c construct some intermediate quadrupole values +c + qix = qixx*xr + qixy*yr + qixz*zr + qiy = qixy*xr + qiyy*yr + qiyz*zr + qiz = qixz*xr + qiyz*yr + qizz*zr + qkx = qkxx*xr + qkxy*yr + qkxz*zr + qky = qkxy*xr + qkyy*yr + qkyz*zr + qkz = qkxz*xr + qkyz*yr + qkzz*zr +c +c calculate the scalar products for permanent multipoles +c + sc(2) = dix*dkx + diy*dky + diz*dkz + sc(3) = dix*xr + diy*yr + diz*zr + sc(4) = dkx*xr + dky*yr + dkz*zr + sc(5) = qix*xr + qiy*yr + qiz*zr + sc(6) = qkx*xr + qky*yr + qkz*zr + sc(7) = qix*dkx + qiy*dky + qiz*dkz + sc(8) = qkx*dix + qky*diy + qkz*diz + sc(9) = qix*qkx + qiy*qky + qiz*qkz + sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz) + & + qixx*qkxx + qiyy*qkyy + qizz*qkzz +c +c calculate the scalar products for polarization components +c + sci(2) = uix*dkx + dix*ukx + uiy*dky + & + diy*uky + uiz*dkz + diz*ukz + sci(3) = uix*xr + uiy*yr + uiz*zr + sci(4) = ukx*xr + uky*yr + ukz*zr + sci(7) = qix*ukx + qiy*uky + qiz*ukz + sci(8) = qkx*uix + qky*uiy + qkz*uiz +c +c calculate the gl functions for permanent multipoles +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + sc(2) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + & + 2.0d0*(sc(7)-sc(8)+sc(10)) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9) + gl(4) = sc(5)*sc(6) +c +c calculate the gl functions for polarization components +c + gli(1) = ck*sci(3) - ci*sci(4) + sci(2) + gli(2) = 2.0d0*(sci(7)-sci(8)) - sci(3)*sc(4) + & - sc(3)*sci(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) +c +c compute the energy contributions for this interaction +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + end if + end if + e = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5 + & + gl(3)*rr7 + gl(4)*rr9 + ei = gli(1)*rr3*scale3 + gli(2)*rr5*scale5 + & + gli(3)*rr7*scale7 +c +c apply the energy adjustments for scaled interactions +c + fm = f * mscale(kk) + fp = f * pscale(kk) + e = fm * e + ei = 0.5d0 * fp * ei +c +c scale the interaction based on its group membership; +c polarization cannot be group scaled as it is not pairwise +c + if (use_group) then + e = e * fgrp +c ei = ei * fgrp + end if +c +c increment the overall multipole and polarization energies +c + em = em - e + ep = ep - ei + end if + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i+1, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do + end do +c +c for periodic boundary conditions with large cutoffs +c neighbors must be found by the replicates method +c + if (.not. use_replica) return +c +c calculate interaction energy with other unit cells +c + do i = 1, npole + ii = ipole(i) + iz = zaxis(i) + ix = xaxis(i) + iy = yaxis(i) + pdi = pdamp(i) + pti = thole(i) + ci = rpole(1,i) + dix = rpole(2,i) + diy = rpole(3,i) + diz = rpole(4,i) + qixx = rpole(5,i) + qixy = rpole(6,i) + qixz = rpole(7,i) + qiyy = rpole(9,i) + qiyz = rpole(10,i) + qizz = rpole(13,i) + uix = uind(1,i) + uiy = uind(2,i) + uiz = uind(3,i) + usei = (use(ii) .or. use(iz) .or. use(ix) .or. use(iy)) +c +c set interaction scaling coefficients for connected atoms +c + do j = 1, n12(ii) + mscale(i12(j,ii)) = m2scale + pscale(i12(j,ii)) = p2scale + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = m3scale + pscale(i13(j,ii)) = p3scale + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = m4scale + pscale(i14(j,ii)) = p4scale + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = m5scale + pscale(i15(j,ii)) = p5scale + end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + if (iqmmm .eq. 0) goto 99 + do j = i, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + mscale(ipole(j)) = mscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do +c +c decide whether to compute the current interaction +c + do k = i, npole + kk = ipole(k) + kz = zaxis(k) + kx = xaxis(k) + ky = yaxis(k) + usek = (use(kk) .or. use(kz) .or. use(kx) .or. use(ky)) + if (use_group) call groups (proceed,fgrp,ii,kk,0,0,0,0) + proceed = .true. + if (proceed) proceed = (usei .or. usek) +c +c compute the energy contribution for this interaction +c + if (proceed) then + do j = 1, ncell + xr = x(kk) - x(ii) + yr = y(kk) - y(ii) + zr = z(kk) - z(ii) + call imager (xr,yr,zr,j) + r2 = xr*xr + yr* yr + zr*zr + if (r2 .le. off2) then + r = sqrt(r2) + ck = rpole(1,k) + dkx = rpole(2,k) + dky = rpole(3,k) + dkz = rpole(4,k) + qkxx = rpole(5,k) + qkxy = rpole(6,k) + qkxz = rpole(7,k) + qkyy = rpole(9,k) + qkyz = rpole(10,k) + qkzz = rpole(13,k) + ukx = uind(1,k) + uky = uind(2,k) + ukz = uind(3,k) +c +c construct some intermediate quadrupole values +c + qix = qixx*xr + qixy*yr + qixz*zr + qiy = qixy*xr + qiyy*yr + qiyz*zr + qiz = qixz*xr + qiyz*yr + qizz*zr + qkx = qkxx*xr + qkxy*yr + qkxz*zr + qky = qkxy*xr + qkyy*yr + qkyz*zr + qkz = qkxz*xr + qkyz*yr + qkzz*zr +c +c calculate the scalar products for permanent multipoles +c + sc(2) = dix*dkx + diy*dky + diz*dkz + sc(3) = dix*xr + diy*yr + diz*zr + sc(4) = dkx*xr + dky*yr + dkz*zr + sc(5) = qix*xr + qiy*yr + qiz*zr + sc(6) = qkx*xr + qky*yr + qkz*zr + sc(7) = qix*dkx + qiy*dky + qiz*dkz + sc(8) = qkx*dix + qky*diy + qkz*diz + sc(9) = qix*qkx + qiy*qky + qiz*qkz + sc(10) = 2.0d0*(qixy*qkxy+qixz*qkxz+qiyz*qkyz) + & + qixx*qkxx + qiyy*qkyy + qizz*qkzz +c +c calculate the scalar products for polarization components +c + sci(2) = uix*dkx + dix*ukx + uiy*dky + & + diy*uky + uiz*dkz + diz*ukz + sci(3) = uix*xr + uiy*yr + uiz*zr + sci(4) = ukx*xr + uky*yr + ukz*zr + sci(7) = qix*ukx + qiy*uky + qiz*ukz + sci(8) = qkx*uix + qky*uiy + qkz*uiz +c +c calculate the gl functions for permanent multipoles +c + gl(0) = ci*ck + gl(1) = ck*sc(3) - ci*sc(4) + sc(2) + gl(2) = ci*sc(6) + ck*sc(5) - sc(3)*sc(4) + & + 2.0d0*(sc(7)-sc(8)+sc(10)) + gl(3) = sc(3)*sc(6) - sc(4)*sc(5) - 4.0d0*sc(9) + gl(4) = sc(5)*sc(6) +c +c calculate the gl functions for polarization components +c + gli(1) = ck*sci(3) - ci*sci(4) + sci(2) + gli(2) = 2.0d0*(sci(7)-sci(8)) - sci(3)*sc(4) + & - sc(3)*sci(4) + gli(3) = sci(3)*sc(6) - sci(4)*sc(5) +c +c compute the energy contributions for this interaction +c + rr1 = 1.0d0 / r + rr3 = rr1 / r2 + rr5 = 3.0d0 * rr3 / r2 + rr7 = 5.0d0 * rr5 / r2 + rr9 = 7.0d0 * rr7 / r2 + scale3 = 1.0d0 + scale5 = 1.0d0 + scale7 = 1.0d0 + damp = pdi * pdamp(k) + if (damp .ne. 0.0d0) then + pgamma = min(pti,thole(k)) + damp = -pgamma * (r/damp)**3 + if (damp .gt. -50.0d0) then + expdamp = exp(damp) + scale3 = 1.0d0 - expdamp + scale5 = 1.0d0 - (1.0d0-damp)*expdamp + scale7 = 1.0d0 - (1.0d0-damp+0.6d0*damp**2) + & *expdamp + end if + end if + e = gl(0)*rr1 + gl(1)*rr3 + gl(2)*rr5 + & + gl(3)*rr7 + gl(4)*rr9 + ei = gli(1)*rr3*scale3 + gli(2)*rr5*scale5 + & + gli(3)*rr7*scale7 +c +c apply the energy adjustments for scaled interactions +c + fm = f + fp = f + if (use_polymer) then + if (r2 .le. polycut2) then + fm = fm * mscale(kk) + fp = fp * pscale(kk) + end if + end if + e = fm * e + ei = 0.5d0 * fp * ei +c +c scale the interaction based on its group membership; +c polarization cannot be group scaled as it is not pairwise +c + if (use_group) then + e = e * fgrp +c ei = ei * fgrp + end if +c +c increment the overall multipole and polarization energies +c + if (ii .eq. kk) then + e = 0.5d0 * e + ei = 0.5d0 * ei + end if + em = em - e + ep = ep - ei + end if + end do + end if + end do +c +c reset interaction scaling coefficients for connected atoms +c +cqmmm + do j = i, npole + mscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end do + do j = 1, n12(ii) + mscale(i12(j,ii)) = 1.0d0 + pscale(i12(j,ii)) = 1.0d0 + end do + do j = 1, n13(ii) + mscale(i13(j,ii)) = 1.0d0 + pscale(i13(j,ii)) = 1.0d0 + end do + do j = 1, n14(ii) + mscale(i14(j,ii)) = 1.0d0 + pscale(i14(j,ii)) = 1.0d0 + end do + do j = 1, n15(ii) + mscale(i15(j,ii)) = 1.0d0 + pscale(i15(j,ii)) = 1.0d0 + end do +cqmmm + 99 continue + end do +c +c perform deallocation of some local arrays +c + deallocate (mscale) + deallocate (pscale) + return + end + diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/erxnfld3.f 6.2.06/source/erxnfld3.f --- 6.2.06/source_orig/erxnfld3.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/erxnfld3.f 2013-10-21 18:20:56.529885302 +0200 @@ -47,6 +47,9 @@ logical usei,usek logical header,huge character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the reaction field energy and partitioning @@ -83,6 +86,8 @@ ix = xaxis(ii) iy = yaxis(ii) usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy)) +cqmmm + iqmmm = mod(qmmm(i),3) do j = 1, polsiz(ii) rpi(j) = rpole(j,ii) end do @@ -92,7 +97,11 @@ kx = xaxis(kk) ky = yaxis(kk) usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky)) - if (usei .or. usek) then +cqmmm + kqmmm = mod(qmmm(k),3) + ikqmmm = iqmmm + kqmmm +cqmmm if (usei .or. usek) then + if ((usei .or. usek) .and. ikqmmm .le. e4qmmm) then xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/erxnfld.f 6.2.06/source/erxnfld.f --- 6.2.06/source_orig/erxnfld.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/erxnfld.f 2013-10-21 18:20:56.577885300 +0200 @@ -40,6 +40,9 @@ real*8 rpk(13) logical usei,usek character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,kqmmm,ikqmmm c c c zero out the macroscopic reaction field energy @@ -71,6 +74,8 @@ ix = xaxis(ii) iy = yaxis(ii) usei = (use(i) .or. use(iz) .or. use(ix) .or. use(iy)) +cqmmm + iqmmm = mod(qmmm(i),3) do j = 1, polsiz(ii) rpi(j) = rpole(j,ii) end do @@ -80,7 +85,11 @@ kx = xaxis(kk) ky = yaxis(kk) usek = (use(k) .or. use(kz) .or. use(kx) .or. use(ky)) - if (usei .or. usek) then +cqmmm + kqmmm = mod(qmmm(k),3) + ikqmmm = iqmmm + kqmmm +cqmmm if (usei .or. usek) then + if ((usei .or. usek) .and. ikqmmm .le. e4qmmm) then xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/extpot.f 6.2.06/source/extpot.f --- 6.2.06/source_orig/extpot.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/extpot.f 2014-02-18 10:13:27.596108542 +0100 @@ -0,0 +1,87 @@ +cqmmm +c +c Determine the external potential generated by *ALL* the MM electrostatic sources +c - either by computing the electrostatic potential (and derivatives) generated by +c charges (elecpot) or permanent + induced multipoles (elecpol) +c - either by collecting their point charges +c + subroutine extpot(nComp,nCenter,QMMM_EP) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'charge.i' + include 'inform.i' + include 'iounit.i' + include 'potent.i' + include 'qmmm.i' + integer nComp,nCenter,i,ii,j,k + real*8 QMMM_EP(nComp,nCenter) +c +c initialization +c + do i = 1, nComp + do j = 1, nCenter + QMMM_EP(i,j) = 0.0d0 + end do + end do +c +c compute the electrostatic potential generated by MM +c only if espf is used +c + if (doespf) then + write(iout,9) + & ' Tinker is computing the MM electrostatic potential' + 9 format(/,a) + do i = 1, n + j = atinqm(i) + if (j.ne.0 .and. qmmm(i).ne.0) then + if (dorunmd) then + QMMM_EP(1,j) = epavg(i) * qmmmscale + do k = 1, 3 + QMMM_EP(k+1,j) = epgavg(k,i) + QMMM_EP(k+4,j) = ephavg(k,i) + end do + if (nComp .eq. 10) then + do k = 4, 6 + QMMM_EP(k+4,j) = ephavg(k,i) + end do + end if + else if (use_charge) then + call elecpot(i,nComp,QMMM_EP(1,j)) + else if (use_chgdpl .or. use_dipole) then +c call elecpotd(i,nComp,QMMM_EP(1,j)) + else if (use_mpole .or. use_polar) then +c call elecpol(i,nComp,QMMM_EP(1,j)) + end if + if (verbose) then + write(iout,10) ' External potential on atom ',i + write(iout,11) ' V=',QMMM_EP(1,j) + write(iout,12) ' dV/dx=',QMMM_EP(2,j), + & ' dV/dy=',QMMM_EP(3,j), + & ' dV/dz=',QMMM_EP(4,j) + 10 format(/,a,i5) + 11 format(a10,f10.5) + 12 format(3(a10,f10.5)) + if (nComp .eq. 10) then + write(iout,12) ' d2V/dxdx=',QMMM_EP(5,j), + & ' d2V/dydy=',QMMM_EP(6,j), + & ' d2V/dzdz=',QMMM_EP(7,j) + write(iout,12) ' d2V/dxdy=',QMMM_EP(8,j), + & ' d2V/dxdz=',QMMM_EP(9,j), + & ' d2V/dydz=',QMMM_EP(10,j) + end if + end if + end if + end do + else + do ii = 1, nion + i = iion(ii) + QMMM_EP(1,ii) = x(i) + QMMM_EP(2,ii) = y(i) + QMMM_EP(3,ii) = z(i) + QMMM_EP(4,ii) = pchg(ii) * qmmmscale + if (mod(qmmm(i),3) .ne. 0) QMMM_EP(4,ii) = 0.0d0 + end do + end if + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/flatten.f 6.2.06/source/flatten.f --- 6.2.06/source_orig/flatten.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/flatten.f 2013-10-23 11:36:27.051130195 +0200 @@ -47,7 +47,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:10) .eq. 'SMOOTHING ') then use_smooth = .true. @@ -56,7 +56,7 @@ use_tophat = .false. use_stophat = .false. call getword (record,stype,next) - call upcase (stype) + call tk_upcase (stype) if (stype .eq. 'DEM') use_dem = .true. if (stype .eq. 'GDA') use_gda = .true. if (stype .eq. 'TOPHAT') use_tophat = .true. diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/gda.f 6.2.06/source/gda.f --- 6.2.06/source_orig/gda.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/gda.f 2013-10-23 11:36:27.051130195 +0200 @@ -89,7 +89,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') randomize = .true. end if if (randomize) boxsize = 10.0d0 * (dble(n))**(1.0d0/3.0d0) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/getkey.f 6.2.06/source/getkey.f --- 6.2.06/source_orig/getkey.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/getkey.f 2013-10-23 11:36:27.051130195 +0200 @@ -41,7 +41,7 @@ exist = .false. do i = 1, narg-1 string = arg(i) - call upcase (string) + call tk_upcase (string) if (string(1:2) .eq. '-K') then keyfile = arg(i+1) call suffix (keyfile,'key','old') @@ -105,7 +105,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:5) .eq. 'ECHO ') then comment = record(next:120) length = trimtext (comment) @@ -129,7 +129,7 @@ do i = 1, nkey next = 1 record = keyline(i) - call upcase (record) + call tk_upcase (record) call gettext (record,keyword,next) string = record(next:120) if (keyword(1:15) .eq. 'OPENMP-THREADS ') then diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/getprm.f 6.2.06/source/getprm.f --- 6.2.06/source_orig/getprm.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/getprm.f 2013-10-23 11:36:27.051130195 +0200 @@ -44,7 +44,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:11) .eq. 'PARAMETERS ') then string = record(next:120) next = 1 @@ -62,7 +62,7 @@ c if (.not. exist) then none = prmfile(1:4) - call upcase (none) + call tk_upcase (none) if (none .eq. 'NONE') then exist = .true. useprm = .false. @@ -88,7 +88,7 @@ 20 format (a120) next = 1 call getword (prmfile,none,next) - call upcase (none) + call tk_upcase (none) if (none.eq.'NONE' .and. next.eq.5) then exist = .true. useprm = .false. diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ghmcstep.f 6.2.06/source/ghmcstep.f --- 6.2.06/source_orig/ghmcstep.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ghmcstep.f 2013-10-23 11:36:27.051130195 +0200 @@ -242,7 +242,7 @@ include 'usage.i' integer i,j,istep real*8 dt,dt_2,dt_4 - real*8 normal,gamma,sigma + real*8 tk_normal,gamma,sigma real*8 alpha(3,*) real*8 beta(3,*) c @@ -269,7 +269,7 @@ sigma = sqrt(2.0d0*boltzmann*kelvin*fgamma(i)) do j = 1, 3 alpha(j,i) = (1.0d0-gamma) / (1.0d0+gamma) - beta(j,i) = normal() * sqrt(dt_2) * sigma + beta(j,i) = tk_normal () * sqrt(dt_2) * sigma & / ((1.0d0+gamma)*mass(i)) end do end if diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/gradient.f 6.2.06/source/gradient.f --- 6.2.06/source_orig/gradient.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/gradient.f 2013-11-08 11:55:40.870715698 +0100 @@ -33,6 +33,38 @@ integer i,j real*8 energy,cutoff real*8 derivs(3,*) +cqmmm + include 'qmmm.i' + include 'couple.i' + include 'inform.i' + integer imm,iqm,ilah + real*8 OMG,r1,r2 +c +cqmmm define the new position of the link atoms +c + if (doqmmmdyn) then + ilah = 0 + do i = 1, n + if (qmmm(i) .eq. 1) then + ilah = ilah + 1 + imm = i12(1,i) + iqm = i12(2,i) + if (lahg(ilah) .gt. 0.0d0) then + x(i) = x(iqm) + lahg(ilah) * (x(imm)-x(iqm)) + y(i) = y(iqm) + lahg(ilah) * (y(imm)-y(iqm)) + z(i) = z(iqm) + lahg(ilah) * (z(imm)-z(iqm)) + else + r1 = sqrt((x(i)-x(iqm))**2 + (y(i)-y(iqm))**2 + & + (z(i)-z(iqm))**2) + r2 = sqrt((x(imm)-x(iqm))**2 + (y(imm)-y(iqm))**2 + & + (z(imm)-z(iqm))**2) + lahg(ilah) = r1 / r2 + write(iout,20) i,lahg(ilah) +20 format(' GRADIENT -- LAH ',i5,' scaling factor:',F7.3) + end if + end if + end do + end if c c c zero out each of the potential energy components @@ -123,6 +155,13 @@ c if (use_orbit) call picalc c +cqmmm In case of a QM/MM job drived by Tinker, run the QM code +cqmmm and retrieve the energy and forces in ex/dex. +cqmmm Also retrieve the ESPF multipoles used to compute the +cqmmm electrostatic components of the MM gradient +c + if (doqmmmdyn) call runqm +c c call the local geometry energy and gradient routines c if (use_bond) call ebond1 @@ -162,7 +201,8 @@ if (use_solv) call esolv1 if (use_metal) call emetal1 if (use_geom) call egeom1 - if (use_extra) call extra1 +cqmmm if (use_extra) call extra1 + if (use_extra .and. .not.doqmmmdyn) call extra1 c c sum up to get the total energy and first derivatives c @@ -184,6 +224,29 @@ end do end do c +cqmmm +c apply the Jacobian to project out the forces +c acting on the link atoms +cqmmm +c + if (doqmmmdyn) then + ilah = 0 + do i = 1, n +c if (debug) write (iout,'(i5,3f12.5)') i,(derivs(j,i),j=1,3) + if (qmmm(i) .eq. 1) then + ilah = ilah + 1 + imm = i12(1,i) + iqm = i12(2,i) + OMG = (1.0d0-lahg(ilah)) + do j = 1, 3 + derivs(j,iqm) = derivs(j,iqm) + desum(j,i) * OMG + derivs(j,imm) = derivs(j,imm) + desum(j,i) * lahg(ilah) + derivs(j,i) = 0.0d0 + end do + end if + end do + end if +c c check for an illegal value for the total energy c if (isnan(esum)) then diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/induce.f 6.2.06/source/induce.f --- 6.2.06/source_orig/induce.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/induce.f 2013-10-21 18:20:56.693885295 +0200 @@ -514,6 +514,9 @@ real*8 fieldp(3,*) logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the value of the field at each site @@ -583,6 +586,22 @@ do j = 1, np14(ii) dscale(ip14(j,ii)) = d4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + dscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do do k = i+1, npole kk = ipole(k) proceed = .true. @@ -701,6 +720,22 @@ do j = 1, np14(ii) dscale(ip14(j,ii)) = d4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + dscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do do k = i, npole kk = ipole(k) ck = rpole(1,k) @@ -1107,6 +1142,9 @@ real*8 fieldp(3,*) logical proceed character*6 mode +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c zero out the value of the field at each site @@ -1176,6 +1214,24 @@ do j = 1, np14(ii) dscale(ip14(j,ii)) = d4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, nelst(i) + jqmmm = mod(qmmm(ipole(elst(j,i))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + dscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + dscale(ipole(elst(j,i))) = dscale(ipole(elst(j,i))) + & * qmmmscale + pscale(ipole(elst(j,i))) = pscale(ipole(elst(j,i))) + & * qmmmscale + end if + end do do kkk = 1, nelst(i) k = elst(kkk,i) kk = ipole(k) @@ -1816,6 +1872,9 @@ real*8 fieldp(3,*) character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c check for multipoles and set cutoff coefficients @@ -1880,6 +1939,22 @@ do j = 1, np14(ii) dscale(ip14(j,ii)) = d4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = i+1, npole + jqmmm = mod(qmmm(ipole(j)),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + dscale(ipole(j)) = 1.0d0 + pscale(ipole(j)) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + dscale(ipole(j)) = dscale(ipole(j)) * qmmmscale + pscale(ipole(j)) = pscale(ipole(j)) * qmmmscale + end if + end do do k = i+1, npole kk = ipole(k) xr = x(kk) - x(ii) @@ -2028,6 +2103,11 @@ do j = 1, np14(ii) dscale(ip14(j,ii)) = 1.0d0 end do +cqmmm + do j = 1, n + pscale(j) = 1.0d0 + dscale(j) = 1.0d0 + end do end do c c periodic boundary for large cutoffs via replicates method @@ -2071,6 +2151,22 @@ do j = 1, np14(ii) dscale(ip14(j,ii)) = d4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, npole + jqmmm = mod(qmmm(j),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + dscale(j) = 1.0d0 + pscale(j) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + dscale(j) = dscale(j) * qmmmscale + pscale(j) = pscale(j) * qmmmscale + end if + end do do k = i, npole kk = ipole(k) ck = rpole(1,k) @@ -2233,6 +2329,11 @@ do j = 1, np14(ii) dscale(ip14(j,ii)) = 1.0d0 end do +cqmmm + do j = 1, n + pscale(j) = 1.0d0 + dscale(j) = 1.0d0 + end do end do end if c @@ -2306,6 +2407,9 @@ real*8, allocatable :: fieldtp(:,:) character*6 mode external erfc +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c perform dynamic allocation of some local arrays @@ -2392,6 +2496,24 @@ do j = 1, np14(ii) dscale(ip14(j,ii)) = d4scale end do +cqmmm +c modify the interaction scaling coefficients for QM/MM +c + iqmmm = mod(qmmm(ii),3) + do j = 1, nelst(i) + jqmmm = mod(qmmm(ipole(elst(j,i))),3) + ijqmmm = iqmmm + jqmmm + if (.not. doespf .and. ijqmmm .ne. 0) then + dscale(ipole(elst(j,i))) = 1.0d0 + pscale(ipole(elst(j,i))) = 1.0d0 + end if + if (ijqmmm .ne. 0) then + dscale(ipole(elst(j,i))) = dscale(ipole(elst(j,i))) + & * qmmmscale + pscale(ipole(elst(j,i))) = pscale(ipole(elst(j,i))) + & * qmmmscale + end if + end do do kkk = 1, nelst(i) k = elst(kkk,i) kk = ipole(k) @@ -2541,6 +2663,11 @@ do j = 1, np14(ii) dscale(ip14(j,ii)) = 1.0d0 end do +cqmmm + do j = 1, nelst(i) + pscale(ipole(elst(j,i))) = 1.0d0 + dscale(ipole(elst(j,i))) = 1.0d0 + end do end do !$OMP END DO c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/intedit.f 6.2.06/source/intedit.f --- 6.2.06/source_orig/intedit.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/intedit.f 2013-10-23 11:36:27.051130195 +0200 @@ -65,7 +65,7 @@ c space = 1 call getword (record,word,space) - call upcase (word) + call tk_upcase (word) if (word .eq. 'EXIT') then if (changed) then izmt = freeunit () diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kangang.f 6.2.06/source/kangang.f --- 6.2.06/source_orig/kangang.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kangang.f 2013-10-28 17:44:02.952040265 +0100 @@ -47,7 +47,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'ANGANG ') then it = 0 do j = 1, 3 @@ -77,7 +77,12 @@ c nangang = 0 do i = 1, n - nang = n12(i) * (n12(i)-1) / 2 +cqmmm nang = n12(i) * (n12(i)-1) / 2 +cqmmm + nang = 0 + do while (anglist(nang+1,i) .ne. 0) + nang = nang + 1 + end do it = class(i) do j = 1, nang-1 jang = anglist(j,i) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kangle.f 6.2.06/source/kangle.f --- 6.2.06/source_orig/kangle.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kangle.f 2013-10-23 11:36:27.051130195 +0200 @@ -59,7 +59,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) iring = -1 if (keyword(1:6) .eq. 'ANGLE ') iring = 0 if (keyword(1:7) .eq. 'ANGLE5 ') iring = 5 @@ -203,7 +203,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) iring = -1 if (keyword(1:7) .eq. 'ANGLEF ') then ia = 0 diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/katom.f 6.2.06/source/katom.f --- 6.2.06/source_orig/katom.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/katom.f 2013-10-23 11:36:27.051130195 +0200 @@ -44,7 +44,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:5) .eq. 'ATOM ') then k = 0 cls = 0 @@ -115,7 +115,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:5) .eq. 'ATOM ') then k = 0 symb = ' ' diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kbond.f 6.2.06/source/kbond.f --- 6.2.06/source_orig/kbond.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kbond.f 2013-10-23 11:36:27.051130195 +0200 @@ -55,7 +55,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) iring = -1 if (keyword(1:5) .eq. 'BOND ') iring = 0 if (keyword(1:6) .eq. 'BOND5 ') iring = 5 @@ -346,7 +346,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:9) .eq. 'ELECTNEG ') then ia = 0 ib = 0 @@ -535,7 +535,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:12) .eq. 'MMFF-PIBOND ') then do j = 1, 20 list(j) = 0 diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kcharge.f 6.2.06/source/kcharge.f --- 6.2.06/source_orig/kcharge.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kcharge.f 2013-11-26 18:25:31.894467289 +0100 @@ -38,6 +38,8 @@ character*20 keyword character*120 record character*120 string +cqmmm + include 'qmmm.i' c c c process keywords containing partial charge parameters @@ -47,7 +49,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'CHARGE ') then ia = 0 cg = 0.0d0 @@ -95,7 +97,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'CHARGE ') then ia = 0 cg = 0.0d0 @@ -122,14 +124,23 @@ c c remove zero partial charges from the list of charges c +cqmmm +c not true if QM/HLA/Y atoms +c nion = 0 do i = 1, n chglist(i) = 0 - if (pchg(i) .ne. 0.0d0) then +cqmmm if (pchg(i) .ne. 0.0d0) then + if (pchg(i) .ne. 0.0d0 .or. qmmm(i) .ne. 0) then nion = nion + 1 iion(nion) = i jion(nion) = i kion(nion) = i +cqmmm + if (qmmm(i) .eq. 1) then + jion(nion) = i12(1,i) + kion(nion) = i12(1,i) + end if pchg(nion) = pchg(i) chglist(i) = nion end if diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kdipole.f 6.2.06/source/kdipole.f --- 6.2.06/source_orig/kdipole.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kdipole.f 2013-10-28 17:44:02.952040265 +0100 @@ -42,6 +42,9 @@ character*20 keyword character*120 record character*120 string +cqmmm + include 'qmmm.i' + integer i12qmmm c c c process keywords containing bond dipole parameters @@ -52,7 +55,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) iring = -1 if (keyword(1:7) .eq. 'DIPOLE ') iring = 0 if (keyword(1:8) .eq. 'DIPOLE5 ') iring = 5 @@ -295,7 +298,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'DIPOLE ') then ia = 0 ib = 0 @@ -343,11 +346,15 @@ ndipole = 0 do i = 1, nbond if (bdpl(i) .ne. 0.0d0) then +cqmmm + i12qmmm = mod(qmmm(idpl(1,i)),3) + mod(qmmm(idpl(2,i)),3) + if (i12qmmm .ne. 0) goto 150 ndipole = ndipole + 1 idpl(1,ndipole) = idpl(1,i) idpl(2,ndipole) = idpl(2,i) bdpl(ndipole) = bdpl(i) sdpl(ndipole) = sdpl(i) + 150 continue end if end do c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kewald.f 6.2.06/source/kewald.f --- 6.2.06/source_orig/kewald.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kewald.f 2013-10-23 11:36:27.051130195 +0200 @@ -91,7 +91,7 @@ do i = 1, nkey record = keyline(i) next = 1 - call upcase (record) + call tk_upcase (record) call gettext (record,keyword,next) string = record(next:120) if (keyword(1:12) .eq. 'FFT-PACKAGE ') then diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kgeom.f 6.2.06/source/kgeom.f --- 6.2.06/source_orig/kgeom.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kgeom.f 2013-10-23 11:36:27.055130195 +0200 @@ -72,7 +72,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) c c get atom restrained to a specified position range @@ -100,7 +100,7 @@ pfix(1,npfix) = p4 pfix(2,npfix) = p5 else - call upcase (letter) + call tk_upcase (letter) read (string,*,err=20,end=20) ip string = string(next:120) read (string,*,err=20,end=20) p1,p2,p3 diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kimprop.f 6.2.06/source/kimprop.f --- 6.2.06/source_orig/kimprop.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kimprop.f 2013-10-23 11:36:27.055130195 +0200 @@ -43,6 +43,9 @@ character*20 keyword character*120 record character*120 string +cqmmm + include 'qmmm.i' + integer iaqmmm c c c process keywords containing improper dihedral parameters @@ -54,7 +57,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:9) .eq. 'IMPROPER ') then ia = 0 ib = 0 @@ -114,6 +117,9 @@ do i = 1, n if (n12(i) .eq. 3) then ia = i +cqmmm + iaqmmm = mod(qmmm(ia),3) + if (iaqmmm .ne. 0) goto 99 ib = i12(1,i) ic = i12(2,i) id = i12(3,i) @@ -275,6 +281,7 @@ end if end do end if +99 continue end if end do end if diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kimptor.f 6.2.06/source/kimptor.f --- 6.2.06/source_orig/kimptor.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kimptor.f 2013-10-23 11:36:27.055130195 +0200 @@ -46,6 +46,9 @@ character*20 keyword character*120 record character*120 string +cqmmm + include 'qmmm.i' + integer icqmmm c c c process keywords containing improper torsion parameters @@ -57,7 +60,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:8) .eq. 'IMPTORS ') then ia = 0 ib = 0 @@ -127,6 +130,9 @@ ia = i12(1,i) ib = i12(2,i) ic = i +cqmmm + icqmmm = mod(qmmm(ic),3) + if (icqmmm .ne. 0) goto 99 id = i12(3,i) ita = class(ia) itb = class(ib) @@ -306,6 +312,7 @@ end if end do end if + 99 continue end if end do end if diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kmpole.f 6.2.06/source/kmpole.f --- 6.2.06/source_orig/kmpole.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kmpole.f 2013-10-23 11:36:27.055130195 +0200 @@ -67,7 +67,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:10) .eq. 'MULTIPOLE ') then k = 0 string = record(next:120) @@ -128,7 +128,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:10) .eq. 'MULTIPOLE ') then k = 0 kz = 0 @@ -397,7 +397,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:10) .eq. 'MULTIPOLE ') then k = 0 kz = 0 diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kopbend.f 6.2.06/source/kopbend.f --- 6.2.06/source_orig/kopbend.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kopbend.f 2013-10-23 11:36:27.055130195 +0200 @@ -49,6 +49,9 @@ character*20 keyword character*120 record character*120 string +cqmmm + include 'qmmm.i' + integer abqmmm,bcqmmm c c c process keywords containing out-of-plane bend parameters @@ -61,7 +64,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'OPBEND ') then ia = 0 ib = 0 @@ -153,6 +156,11 @@ itc = class(ic) id = iang(4,i) itd = class(id) +cqmmm + abqmmm = qmmm(ia) + qmmm(ib) + bcqmmm = qmmm(ib) + qmmm(ic) + if (abqmmm .ge. 4 .and. abqmmm.le. 5 + & .and. bcqmmm .ge. 4 .and. bcqmmm .le. 5) goto 70 size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) @@ -262,6 +270,9 @@ integer ittc,ittd character*4 pa,pb,pc,pd character*16 blank,pt +cqmmm + include 'qmmm.i' + integer abqmmm,bcqmmm c c c determine the total number of forcefield parameters @@ -281,6 +292,11 @@ ib = iang(2,i) ic = iang(3,i) id = iang(4,i) +cqmmm + abqmmm = qmmm(ia) + qmmm(ib) + bcqmmm = qmmm(ib) + qmmm(ic) + if (abqmmm .ge. 4 .and. abqmmm.le. 5 + & .and. bcqmmm .ge. 4 .and. bcqmmm .le. 5) goto 30 itta = type(ia) ittb = type(ib) ittc = type(ic) @@ -365,6 +381,8 @@ 20 continue end if end if +cqmmm + 30 continue end do end if c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kopdist.f 6.2.06/source/kopdist.f --- 6.2.06/source_orig/kopdist.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kopdist.f 2013-10-23 11:36:27.055130195 +0200 @@ -46,6 +46,9 @@ character*20 keyword character*120 record character*120 string +cqmmm + include 'qmmm.i' + integer abqmmm,bcqmmm c c c process keywords containing out-of-plane distance parameters @@ -57,7 +60,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'OPDIST ') then ia = 0 ib = 0 @@ -135,6 +138,11 @@ ib = i12(1,i) ic = i12(2,i) id = i12(3,i) +cqmmm + abqmmm = qmmm(ia) + qmmm(ib) + bcqmmm = qmmm(ib) + qmmm(ic) + if (abqmmm .ge. 4 .and. abqmmm.le. 5 + & .and. bcqmmm .ge. 4 .and. bcqmmm .le. 5) goto 70 ita = class(ia) itb = class(ib) itc = class(ic) @@ -189,6 +197,8 @@ end do 60 continue end if +cqmmm + 70 continue end do end if c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/korbit.f 6.2.06/source/korbit.f --- 6.2.06/source_orig/korbit.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/korbit.f 2013-10-23 11:36:27.055130195 +0200 @@ -56,7 +56,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'PIATOM ') then ia = 0 elect = 0.0d0 @@ -95,7 +95,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) iring = -1 if (keyword(1:7) .eq. 'PIBOND ') iring = 0 if (keyword(1:8) .eq. 'PIBOND5 ') iring = 5 diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kpitors.f 6.2.06/source/kpitors.f --- 6.2.06/source_orig/kpitors.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kpitors.f 2013-10-23 11:36:27.055130195 +0200 @@ -50,7 +50,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'PITORS ') then ia = 0 ib = 0 diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kpolar.f 6.2.06/source/kpolar.f --- 6.2.06/source_orig/kpolar.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kpolar.f 2013-10-23 11:36:27.055130195 +0200 @@ -38,6 +38,9 @@ character*20 keyword character*120 record character*120 string +cqmmm + include 'qmmm.i' + integer iqmmm c c c process keywords containing polarizability parameters @@ -47,7 +50,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:9) .eq. 'POLARIZE ') then k = 0 pol = 0.0d0 @@ -96,8 +99,16 @@ c find and store the atomic dipole polarizability parameters c do i = 1, n - polarity(i) = polr(type(i)) - thole(i) = athl(type(i)) +cqmmm +c polarity(i) = polr(type(i)) +c thole(i) = athl(type(i)) + if (qmmm(i).ne.0) then + polarity(i) = 0.0d0 + thole(i) = 0.0d0 + else + polarity(i) = polr(type(i)) + thole(i) = athl(type(i)) + end if end do c c process keywords containing atom specific polarizabilities @@ -107,7 +118,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:9) .eq. 'POLARIZE ') then k = 0 pol = 0.0d0 @@ -175,6 +186,17 @@ c test multipoles at chiral sites and invert if necessary c call chkpole +cqmm +c zero out the values if it's not a MM or a Y atom +c + do i = 1, npole + iqmmm = mod(qmmm(ipole(i)),3) + if(iqmmm .ne. 0) then + do j = 1, maxpole + pole(j,i) = 0.0d0 + end do + end if + end do c c turn off polarizable multipole potential if it is not used c @@ -311,7 +333,7 @@ stop = np11(i) end if end do - call sort (np11(i),ip11(1,i)) + call tk_sort (np11(i),ip11(1,i)) end do 50 continue c @@ -345,7 +367,7 @@ list(nlist) = kk end do end do - call sort8 (nlist,list) + call tk_sort8 (nlist,list) if (nlist .le. maxp12) then np12(i) = nlist do j = 1, nlist @@ -386,7 +408,7 @@ end if end do end do - call sort8 (nlist,list) + call tk_sort8 (nlist,list) if (nlist .le. maxp13) then np13(i) = nlist do j = 1, nlist @@ -431,7 +453,7 @@ end if end do end do - call sort8 (nlist,list) + call tk_sort8 (nlist,list) if (nlist .le. maxp14) then np14(i) = nlist do j = 1, nlist diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ksolv.f 6.2.06/source/ksolv.f --- 6.2.06/source_orig/ksolv.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ksolv.f 2013-10-23 11:36:27.055130195 +0200 @@ -50,14 +50,14 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:8) .eq. 'SOLVATE ') then use_solv = .true. use_born = .false. solvtyp = 'ASP' call getword (record,value,next) - call upcase (value) + call tk_upcase (value) if (value(1:3) .eq. 'ASP') then solvtyp = 'ASP' else if (value(1:4) .eq. 'SASA') then @@ -96,7 +96,7 @@ end if else if (keyword(1:12) .eq. 'BORN-RADIUS ') then call getword (record,value,next) - call upcase (value) + call tk_upcase (value) if (value(1:5) .eq. 'ONION') then borntyp = 'ONION' else if (value(1:5) .eq. 'STILL') then @@ -812,13 +812,13 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:4) .eq. 'GKC ') then read (string,*,err=10,end=10) gkc else if (keyword(1:10) .eq. 'GK-RADIUS ') then call getword (record,value,next) - call upcase (value) + call tk_upcase (value) if (value(1:3) .eq. 'VDW') then radtyp = 'VDW' else if (value(1:10) .eq. 'MACROMODEL') then @@ -1216,7 +1216,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:8) .eq. 'MG-AUTO ') then pbsoln = 'MG-AUTO' @@ -1233,7 +1233,7 @@ if (nz .ge. 33) dime(3) = nz else if (keyword(1:10) .eq. 'PB-RADIUS ') then call getword (record,value,next) - call upcase (value) + call tk_upcase (value) if (value(1:3) .eq. 'VDW') then radtyp = 'VDW' else if (value(1:10) .eq. 'MACROMODEL') then @@ -1263,7 +1263,7 @@ 70 continue else if (keyword(1:5) .eq. 'SRFM ') then call getword (record,value,next) - call upcase (value) + call tk_upcase (value) if (value(1:3) .eq. 'MOL') then srfm = 'MOL' else if (value(1:4) .eq. 'SMOL') then @@ -1273,7 +1273,7 @@ end if else if (keyword(1:5) .eq. 'BCFL ') then call getword (record,value,next) - call upcase (value) + call tk_upcase (value) if (value(1:3) .eq. 'ZERO') then bcfl = 'ZERO' else if (value(1:3) .eq. 'MDH') then @@ -1365,7 +1365,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:5) .eq. 'DIME ') then read (string,*,err=90,end=90) nx,ny,nz @@ -1683,7 +1683,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:17) .eq. 'SOLVENT-PRESSURE ') then read (string,*,err=10,end=10) solvprs diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kstrbnd.f 6.2.06/source/kstrbnd.f --- 6.2.06/source_orig/kstrbnd.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kstrbnd.f 2013-10-23 11:36:27.055130195 +0200 @@ -44,6 +44,9 @@ character*20 keyword character*120 record character*120 string +cqmmm + include 'qmmm.i' + integer abqmmm,bcqmmm c c c process keywords containing stretch-bend parameters @@ -54,7 +57,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'STRBND ') then ia = 0 ib = 0 @@ -125,6 +128,11 @@ ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) +cqmmm + abqmmm = qmmm(ia) + qmmm(ib) + bcqmmm = qmmm(ib) + qmmm(ic) + if ((abqmmm .ge. 4 .and. abqmmm.le. 5) + & .or. (bcqmmm .ge. 4 .and. bcqmmm .le. 5)) goto 60 ita = class(ia) itb = class(ib) itc = class(ic) @@ -225,6 +233,9 @@ integer nb1,nb2 integer stbnt,ab,bc logical ring3,ring4 +cqmmm + include 'qmmm.i' + integer abqmmm,bcqmmm c c c assign stretch-bend parameters for each angle @@ -234,6 +245,11 @@ ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) +cqmmm + abqmmm = qmmm(ia) + qmmm(ib) + bcqmmm = qmmm(ib) + qmmm(ic) + if ((abqmmm .ge. 4 .and. abqmmm.le. 5) + & .or. (bcqmmm .ge. 4 .and. bcqmmm .le. 5)) goto 99 c c stretch-bend interactions are omitted for linear angles c @@ -615,6 +631,8 @@ end if end if end if +cqmmm + 99 continue end do c c turn off the stretch-bend potential if it is not used diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kstrtor.f 6.2.06/source/kstrtor.f --- 6.2.06/source_orig/kstrtor.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kstrtor.f 2013-10-23 11:36:27.055130195 +0200 @@ -54,7 +54,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:8) .eq. 'STRTORS ') then ia = 0 ib = 0 diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ktors.f 6.2.06/source/ktors.f --- 6.2.06/source_orig/ktors.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ktors.f 2013-10-23 11:36:27.055130195 +0200 @@ -65,7 +65,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) iring = -1 if (keyword(1:8) .eq. 'TORSION ') iring = 0 if (keyword(1:9) .eq. 'TORSION5 ') iring = 5 diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ktortor.f 6.2.06/source/ktortor.f --- 6.2.06/source_orig/ktortor.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ktortor.f 2013-10-23 11:36:27.055130195 +0200 @@ -64,7 +64,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:8) .eq. 'TORTORS ') then ia = 0 ib = 0 @@ -109,9 +109,9 @@ if (ktt(j).eq.blank .or. ktt(j).eq.pt) then ktt(j) = pt nx = nxy - call sort9 (nx,tx) + call tk_sort9 (nx,tx) ny = nxy - call sort9 (ny,ty) + call tk_sort9 (ny,ty) tnx(j) = nx tny(j) = ny do k = 1, nx diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kurey.f 6.2.06/source/kurey.f --- 6.2.06/source_orig/kurey.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kurey.f 2013-10-23 11:36:27.055130195 +0200 @@ -40,6 +40,9 @@ character*20 keyword character*120 record character*120 string +cqmmm + include 'qmmm.i' + integer iacqmmm c c c process keywords containing Urey-Bradley parameters @@ -50,7 +53,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:9) .eq. 'UREYBRAD ') then ia = 0 ib = 0 @@ -111,6 +114,10 @@ ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) +cqmmm + iacqmmm = qmmm(ia) + qmmm(ic) + if (iacqmmm .ne. 4 .and. iacqmmm .ne. 5) goto 60 + ita = class(ia) itb = class(ib) itc = class(ic) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/kvdw.f 6.2.06/source/kvdw.f --- 6.2.06/source_orig/kvdw.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/kvdw.f 2013-10-23 11:36:27.055130195 +0200 @@ -49,6 +49,8 @@ character*20 keyword character*120 record character*120 string +cqmmm + include 'qmmm.i' c c c process keywords containing van der Waals parameters @@ -59,7 +61,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:4) .eq. 'VDW ') then call getnumb (record,k,next) if (k.ge.1 .and. k.le.maxclass) then @@ -106,7 +108,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:6) .eq. 'VDW14 ') then call getnumb (record,k,next) if (k.ge.1 .and. k.le.maxclass) then @@ -153,7 +155,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:6) .eq. 'VDWPR ') then ia = 0 ib = 0 @@ -212,7 +214,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:6) .eq. 'HBOND ') then ia = 0 ib = 0 @@ -569,7 +571,8 @@ c nvdw = 0 do i = 1, n - if (rad(jvdw(i)) .ne. 0.0d0) then +cqmmm if (rad(jvdw(i)) .ne. 0.0d0) then + if (rad(jvdw(i)) .ne. 0.0d0 .and. qmmm(i) .ne. 1) then nvdw = nvdw + 1 ivdw(nvdw) = i end if diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/lbfgs.f 6.2.06/source/lbfgs.f --- 6.2.06/source_orig/lbfgs.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/lbfgs.f 2013-10-23 11:36:27.055130195 +0200 @@ -139,7 +139,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:14) .eq. 'LBFGS-VECTORS ') then read (string,*,err=20,end=20) msav Les fichiers binaires 6.2.06/source_orig/libtinker.a et 6.2.06/source/libtinker.a sont différents diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/lights.f 6.2.06/source/lights.f --- 6.2.06/source_orig/lights.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/lights.f 2013-10-23 11:36:27.055130195 +0200 @@ -169,9 +169,9 @@ c sort the coordinate components into ascending order c nlight = (ncell+1) * nsite - call sort2 (nlight,xsort,locx) - call sort2 (nlight,ysort,locy) - call sort2 (nlight,zsort,locz) + call tk_sort2 (nlight,xsort,locx) + call tk_sort2 (nlight,ysort,locy) + call tk_sort2 (nlight,zsort,locz) c c use of replicates requires secondary sorting along x-axis c @@ -179,11 +179,11 @@ j = 1 do i = 1, nlight-1 if (xsort(i+1) .ne. xsort(i)) then - call sort5 (i-j+1,locx(j),nsite) + call tk_sort5 (i-j+1,locx(j),nsite) j = i + 1 end if end do - call sort5 (nlight-j+1,locx(j),nsite) + call tk_sort5 (nlight-j+1,locx(j),nsite) end if c c index the position of each atom in the sorted coordinates diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/Makefile 6.2.06/source/Makefile --- 6.2.06/source_orig/Makefile 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/Makefile 2013-12-18 10:28:26.163518643 +0100 @@ -0,0 +1,1521 @@ +## +################################################################### +## ## +## Makefile for Building the Tinker Molecular Modeling Package ## +## ## +################################################################### +## +## Invocation Options: +## +## 1. make all Build all the TINKER executables +## 2. make rename Move the executables to BINDIR +## 3. make create_links Create soft links in LINKDIR +## 4. make remove_links Remove soft links from LINKDIR +## 6. make listing Concatenate source to tinker.txt +## 5. make clean Delete objects and executables +## +## Original version of this file is due to Peter Happersberger +## and Jochen Buehler of the University of Konstanz, Jan. 1998, +## Modifications by Reece Hart & Jay Ponder, Washington University +## +################################################################### + +################################################################### +## Master Directory Locations; Change as Needed for Local Site ## +################################################################### + +## +## TINKERDIR TINKER Distribution Directory +## BINDIR Hard Copies of TINKER Executables +## LINKDIR Linked Copies of TINKER Executables +## + +TINKERDIR = /home/ferre/tinker/6.2.06 +BINDIR = $(TINKERDIR)/bin +LINKDIR = /home/ferre/bin + +#################################################################### +## Known Machine Types; Uncomment One of the Following Sections ## +## May Need Editing to Match Your Desired OS & Compiler Version ## +#################################################################### + +## +## Machine: Generic Linux +## CPU Type: Intel x86 Compatible +## Oper Sys: Fedora Core +## Compiler: GNU gfortran +## + +F77 = /usr/bin/gfortran +LIBS = +F77FLAGS = -c -fdefault-integer-8 -mcmodel=large -fbounds-check +OPTFLAGS = -O2 +LIBFLAGS = -crusv +LINKFLAGS = + +## +## Machine: Generic Linux +## CPU Type: Intel x86 Compatible (also AMD) +## Oper Sys: Fedora Core +## Compiler: Intel Fortran for Linux 12.0 +## + +#F77 = /opt/intel/bin/ifort +# after source /opt/intel/composerxe/bin/compilervars.sh intel64 +#F77 = ifort -g +#LIBS = +#F77FLAGS = -c -xHost -vec-report0 +#OPTFLAGS = -no-ipo -no-prec-div +#LIBFLAGS = -crusv +#LINKFLAGS = -static-intel + +## +## Machine: Generic Linux +## CPU Type: Intel x86 Compatible (also AMD) +## Oper Sys: Fedora Core +## Compiler: Intel Fortran for Linux 12.0 +## Parallel: OpenMP +## + +#F77 = /opt/intel/bin/ifort +# after source /opt/intel/composerxe/bin/compilervars.sh intel64 +#F77 = ifort -g +#LIBS = -L$(TINKERDIR)/fftw/lib -lfftw3_omp -lfftw3 +#F77FLAGS = -c -xHost -assume cc_omp +#OPTFLAGS = -O3 -no-ipo -no-prec-div -openmp +#LIBFLAGS = -crusv +#LINKFLAGS = $(OPTFLAGS) -static-intel + +## +## Machine: Macintosh +## CPU Type: Intel Xeon +## Oper Sys: OS X 10.6 (Snow Leopard) +## Compiler: Intel Fortran for Mac 12.0 +## + +#F77 = /opt/intel/bin/ifort +#LIBS = +#F77FLAGS = -c -axSSSE3 -vec-report0 +#OPTFLAGS = -O3 -no-ipo -no-prec-div +#LIBFLAGS = -crusv +#LINKFLAGS = -static-intel -mmacosx-version-min=10.4 + +## +## Machine: Macintosh +## CPU Type: Intel Xeon +## Oper Sys: OS X 10.6 (Snow Leopard) +## Compiler: Intel Fortran for Mac 12.0 +## Parallel: OpenMP +## + +#F77 = /opt/intel/bin/ifort +#LIBS = -L$(TINKERDIR)/fftw/lib -lfftw3_omp -lfftw3 +#F77FLAGS = -c -axSSSE3 -assume cc_omp +#OPTFLAGS = -O3 -no-ipo -no-prec-div -openmp +#LIBFLAGS = -crusv +#LINKFLAGS = $(OPTFLAGS) -static-intel -mmacosx-version-min=10.4 + +## +## Machine: Macintosh +## CPU Type: PowerPC G4/G5 +## Oper Sys: OS X 10.4 (Tiger) +## Compiler: IBM XLF 8.1 +## + +#F77 = /opt/ibmcmp/xlf/8.1/bin/xlf +#F77FLAGS = -c -qextname +#OPTFLAGS = -O2 -qmaxmem=-1 +#LIBFLAGS = -r +#LINKFLAGS = + +## +## Machine: HP Alpha +## CPU Type: Alpha 21264 +## Oper Sys: HP Tru64 Unix +## Compiler: HP Fortran +## + +#F77 = /usr/bin/f77 +#LIBS = +#F77FLAGS = -c +#OPTFLAGS = -fast -arch host -tune host +#LIBFLAGS = -rclvs +#LINKFLAGS = -fast -non_shared -om -WL,-om_no_inst_sched + +## +## Machine: Silicon Graphics +## CPU Type: MIPS R10000 +## Oper Sys: SGI Irix 6.5 +## Compiler: MIPSPro Fortran +## + +#F77 = /bin/f77 +#LIBS = +#F77FLAGS = -c +#OPTFLAGS = -O -mips4 +#LIBFLAGS = -rclvs +#LINKFLAGS = -O -mips4 + +## +## Machine: SUN Workstation +## CPU Type: UltraSPARC +## Oper Sys: Solaris 4.0 +## Compiler: SUN Fortran +## + +#F77 = /bin/f77 +#LIBS = +#F77FLAGS = -c +#OPTFLAGS = -fast -temp=. +#LIBFLAGS = rcv +#LINKFLAGS = -fast + +################################################################# +## Should not be Necessary to Change Things Below this Point ## +################################################################# + +OBJS = active.o \ + alchemy.o \ + analysis.o \ + analyze.o \ + angles.o \ + anneal.o \ + archive.o \ + attach.o \ + bar.o \ + basefile.o \ + beeman.o \ + bicubic.o \ + bitors.o \ + bonds.o \ + born.o \ + bounds.o \ + bussi.o \ + calendar.o \ + center.o \ + chkpole.o \ + chkring.o \ + chkxyz.o \ + cholesky.o \ + clock.o \ + cluster.o \ + column.o \ + command.o \ + connect.o \ + connolly.o \ + control.o \ + correlate.o \ + crystal.o \ + cspline.o \ + cutoffs.o \ + deflate.o \ + delete.o \ + diagq.o \ + diffeq.o \ + diffuse.o \ + distgeom.o \ + document.o \ + dynamic.o \ + eangang.o \ + eangang1.o \ + eangang2.o \ + eangang3.o \ + eangle.o \ + eangle1.o \ + eangle2.o \ + eangle3.o \ + ebond.o \ + ebond1.o \ + ebond2.o \ + ebond3.o \ + ebuck.o \ + ebuck1.o \ + ebuck2.o \ + ebuck3.o \ + echarge.o \ + echarge1.o \ + echarge2.o \ + echarge3.o \ + echgdpl.o \ + echgdpl1.o \ + echgdpl2.o \ + echgdpl3.o \ + edipole.o \ + edipole1.o \ + edipole2.o \ + edipole3.o \ + egauss.o \ + egauss1.o \ + egauss2.o \ + egauss3.o \ + egeom.o \ + egeom1.o \ + egeom2.o \ + egeom3.o \ + ehal.o \ + ehal1.o \ + ehal2.o \ + ehal3.o \ + eimprop.o \ + eimprop1.o \ + eimprop2.o \ + eimprop3.o \ + eimptor.o \ + eimptor1.o \ + eimptor2.o \ + eimptor3.o \ + elj.o \ + elj1.o \ + elj2.o \ + elj3.o \ + embed.o \ + emetal.o \ + emetal1.o \ + emetal2.o \ + emetal3.o \ + emm3hb.o \ + emm3hb1.o \ + emm3hb2.o \ + emm3hb3.o \ + empole.o \ + empole1.o \ + empole2.o \ + empole3.o \ + energy.o \ + eopbend.o \ + eopbend1.o \ + eopbend2.o \ + eopbend3.o \ + eopdist.o \ + eopdist1.o \ + eopdist2.o \ + eopdist3.o \ + epitors.o \ + epitors1.o \ + epitors2.o \ + epitors3.o \ + erf.o \ + erxnfld.o \ + erxnfld1.o \ + erxnfld2.o \ + erxnfld3.o \ + esolv.o \ + esolv1.o \ + esolv2.o \ + esolv3.o \ + estrbnd.o \ + estrbnd1.o \ + estrbnd2.o \ + estrbnd3.o \ + estrtor.o \ + estrtor1.o \ + estrtor2.o \ + estrtor3.o \ + etors.o \ + etors1.o \ + etors2.o \ + etors3.o \ + etortor.o \ + etortor1.o \ + etortor2.o \ + etortor3.o \ + eurey.o \ + eurey1.o \ + eurey2.o \ + eurey3.o \ + evcorr.o \ + extra.o \ + extra1.o \ + extra2.o \ + extra3.o \ + fatal.o \ + fft3d.o \ + fftpack.o \ + field.o \ + final.o \ + flatten.o \ + freeunit.o \ + gda.o \ + geometry.o \ + getint.o \ + getkey.o \ + getmol.o \ + getmol2.o \ + getnumb.o \ + getpdb.o \ + getprm.o \ + getref.o \ + getstring.o \ + gettext.o \ + getword.o \ + getxyz.o \ + ghmcstep.o \ + gradient.o \ + gradrgd.o \ + gradrot.o \ + groups.o \ + grpline.o \ + gyrate.o \ + hessian.o \ + hessrgd.o \ + hessrot.o \ + hybrid.o \ + image.o \ + impose.o \ + induce.o \ + inertia.o \ + initatom.o \ + initial.o \ + initprm.o \ + initres.o \ + initrot.o \ + insert.o \ + intedit.o \ + intxyz.o \ + invbeta.o \ + invert.o \ + jacobi.o \ + kangang.o \ + kangle.o \ + katom.o \ + kbond.o \ + kcharge.o \ + kdipole.o \ + kewald.o \ + kextra.o \ + kgeom.o \ + kimprop.o \ + kimptor.o \ + kinetic.o \ + kmetal.o \ + kmpole.o \ + kopbend.o \ + kopdist.o \ + korbit.o \ + kpitors.o \ + kpolar.o \ + ksolv.o \ + kstrbnd.o \ + kstrtor.o \ + ktors.o \ + ktortor.o \ + kurey.o \ + kvdw.o \ + lattice.o \ + lbfgs.o \ + lights.o \ + makeint.o \ + makeref.o \ + makexyz.o \ + maxwell.o \ + mdinit.o \ + mdrest.o \ + mdsave.o \ + mdstat.o \ + mechanic.o \ + merge.o \ + minimize.o \ + minirot.o \ + minrigid.o \ + molecule.o \ + molxyz.o \ + moments.o \ + monte.o \ + mutate.o \ + nblist.o \ + newton.o \ + newtrot.o \ + nextarg.o \ + nexttext.o \ + nose.o \ + nspline.o \ + nucleic.o \ + number.o \ + numeral.o \ + numgrad.o \ + ocvm.o \ + openend.o \ + optimize.o \ + optirot.o \ + optrigid.o \ + optsave.o \ + orbital.o \ + orient.o \ + orthog.o \ + overlap.o \ + path.o \ + pdbxyz.o \ + picalc.o \ + pmestuff.o \ + pmpb.o \ + polarize.o \ + poledit.o \ + polymer.o \ + potential.o \ + precise.o \ + pressure.o \ + prmedit.o \ + prmkey.o \ + promo.o \ + protein.o \ + prtdyn.o \ + prterr.o \ + prtint.o \ + prtmol2.o \ + prtpdb.o \ + prtprm.o \ + prtseq.o \ + prtxyz.o \ + pss.o \ + pssrigid.o \ + pssrot.o \ + quatfit.o \ + radial.o \ + random.o \ + rattle.o \ + readdyn.o \ + readgau.o \ + readint.o \ + readmol.o \ + readmol2.o \ + readpdb.o \ + readprm.o \ + readseq.o \ + readxyz.o \ + replica.o \ + respa.o \ + rgdstep.o \ + rings.o \ + rmsfit.o \ + rotlist.o \ + rotpole.o \ + saddle.o \ + scan.o \ + sdstep.o \ + search.o \ + server.o \ + shakeup.o \ + sigmoid.o \ + sktstuff.o \ + sniffer.o \ + sort.o \ + spacefill.o \ + spectrum.o \ + square.o \ + suffix.o \ + superpose.o \ + surface.o \ + surfatom.o \ + switch.o \ + sybylxyz.o \ + temper.o \ + testgrad.o \ + testhess.o \ + testpair.o \ + testpol.o \ + testrot.o \ + timer.o \ + timerot.o \ + tncg.o \ + torphase.o \ + torque.o \ + torsfit.o \ + torsions.o \ + trimtext.o \ + unitcell.o \ + valence.o \ + verlet.o \ + version.o \ + vibbig.o \ + vibrate.o \ + vibrot.o \ + volume.o \ + xtalfit.o \ + xtalmin.o \ + xyzatm.o \ + xyzedit.o \ + xyzint.o \ + xyzpdb.o \ + xyzsybyl.o \ + zatom.o + +OBJQMMM = elecpot.o \ + extpot.o \ + minimizemm.o \ + qmmm_eg.o \ + qmmm_post.o \ + qmmm_todo.o \ + qmmmsetup.o \ + runqm.o \ + update_qmmm.o \ + tkr2qm.o \ + tkr2qm_s.o + +EXEFILES = alchemy.x \ + analyze.x \ + anneal.x \ + archive.x \ + bar.x \ + correlate.x \ + crystal.x \ + diffuse.x \ + distgeom.x \ + document.x \ + dynamic.x \ + gda.x \ + intedit.x \ + intxyz.x \ + minimize.x \ + minirot.x \ + minrigid.x \ + molxyz.x \ + monte.x \ + newton.x \ + newtrot.x \ + nucleic.x \ + optimize.x \ + optirot.x \ + optrigid.x \ + path.x \ + pdbxyz.x \ + polarize.x \ + poledit.x \ + potential.x \ + prmedit.x \ + protein.x \ + pss.x \ + pssrigid.x \ + pssrot.x \ + radial.x \ + saddle.x \ + scan.x \ + sniffer.x \ + spacefill.x \ + spectrum.x \ + superpose.x \ + sybylxyz.x \ + testgrad.x \ + testhess.x \ + testpair.x \ + testpol.x \ + testrot.x \ + timer.x \ + timerot.x \ + torsfit.x \ + valence.x \ + vibbig.x \ + vibrate.x \ + vibrot.x \ + xtalfit.x \ + xtalmin.x \ + xyzedit.x \ + xyzint.x \ + xyzpdb.x \ + xyzsybyl.x + +%.o: %.f + ${F77} ${F77FLAGS} ${OPTFLAGS} $< -o $@ + +%.o: %.c + ${CC} ${CFLAGS} ${INCLUDEDIR} ${OPTFLAGS} $< + +%.x: %.o libtinker.a + ${F77} ${LINKFLAGS} -o $@ $^ ${LIBS}; strip $@ + +all: ${EXEFILES} tkr2qm_s.x + +clean: + rm -f *.o *.a *.x + +listing: + cat *.i *.f *.c > tinker.txt + +rename: + mv alchemy.x $(BINDIR)/alchemy + mv analyze.x $(BINDIR)/analyze + mv anneal.x $(BINDIR)/anneal + mv archive.x $(BINDIR)/archive + mv bar.x $(BINDIR)/bar + mv correlate.x $(BINDIR)/correlate + mv crystal.x $(BINDIR)/crystal + mv diffuse.x $(BINDIR)/diffuse + mv distgeom.x $(BINDIR)/distgeom + mv document.x $(BINDIR)/document + mv dynamic.x $(BINDIR)/dynamic + mv gda.x $(BINDIR)/gda + mv intedit.x $(BINDIR)/intedit + mv intxyz.x $(BINDIR)/intxyz + mv minimize.x $(BINDIR)/minimize + mv minirot.x $(BINDIR)/minirot + mv minrigid.x $(BINDIR)/minrigid + mv molxyz.x $(BINDIR)/molxyz + mv monte.x $(BINDIR)/monte + mv newton.x $(BINDIR)/newton + mv newtrot.x $(BINDIR)/newtrot + mv nucleic.x $(BINDIR)/nucleic + mv optimize.x $(BINDIR)/optimize + mv optirot.x $(BINDIR)/optirot + mv optrigid.x $(BINDIR)/optrigid + mv path.x $(BINDIR)/path + mv pdbxyz.x $(BINDIR)/pdbxyz + mv polarize.x $(BINDIR)/polarize + mv poledit.x $(BINDIR)/poledit + mv potential.x $(BINDIR)/potential + mv prmedit.x $(BINDIR)/prmedit + mv protein.x $(BINDIR)/protein + mv pss.x $(BINDIR)/pss + mv pssrigid.x $(BINDIR)/pssrigid + mv pssrot.x $(BINDIR)/pssrot + mv radial.x $(BINDIR)/radial + mv saddle.x $(BINDIR)/saddle + mv scan.x $(BINDIR)/scan + mv sniffer.x $(BINDIR)/sniffer + mv spacefill.x $(BINDIR)/spacefill + mv spectrum.x $(BINDIR)/spectrum + mv superpose.x $(BINDIR)/superpose + mv sybylxyz.x $(BINDIR)/sybylxyz + mv testgrad.x $(BINDIR)/testgrad + mv testhess.x $(BINDIR)/testhess + mv testpair.x $(BINDIR)/testpair + mv testpol.x $(BINDIR)/testpol + mv testrot.x $(BINDIR)/testrot + mv timer.x $(BINDIR)/timer + mv timerot.x $(BINDIR)/timerot + mv torsfit.x $(BINDIR)/torsfit + mv valence.x $(BINDIR)/valence + mv vibbig.x $(BINDIR)/vibbig + mv vibrate.x $(BINDIR)/vibrate + mv vibrot.x $(BINDIR)/vibrot + mv xtalfit.x $(BINDIR)/xtalfit + mv xtalmin.x $(BINDIR)/xtalmin + mv xyzedit.x $(BINDIR)/xyzedit + mv xyzint.x $(BINDIR)/xyzint + mv xyzpdb.x $(BINDIR)/xyzpdb + mv xyzsybyl.x $(BINDIR)/xyzsybyl + mv tkr2qm_s.x $(BINDIR)/tkr2qm_s + +remove_links: + rm -f $(LINKDIR)/alchemy + rm -f $(LINKDIR)/analyze + rm -f $(LINKDIR)/anneal + rm -f $(LINKDIR)/archive + rm -f $(LINKDIR)/bar + rm -f $(LINKDIR)/correlate + rm -f $(LINKDIR)/crystal + rm -f $(LINKDIR)/diffuse + rm -f $(LINKDIR)/distgeom + rm -f $(LINKDIR)/document + rm -f $(LINKDIR)/dynamic + rm -f $(LINKDIR)/gda + rm -f $(LINKDIR)/intedit + rm -f $(LINKDIR)/intxyz + rm -f $(LINKDIR)/minimize + rm -f $(LINKDIR)/minirot + rm -f $(LINKDIR)/minrigid + rm -f $(LINKDIR)/molxyz + rm -f $(LINKDIR)/monte + rm -f $(LINKDIR)/newton + rm -f $(LINKDIR)/newtrot + rm -f $(LINKDIR)/nucleic + rm -f $(LINKDIR)/optimize + rm -f $(LINKDIR)/optirot + rm -f $(LINKDIR)/optrigid + rm -f $(LINKDIR)/path + rm -f $(LINKDIR)/pdbxyz + rm -f $(LINKDIR)/polarize + rm -f $(LINKDIR)/poledit + rm -f $(LINKDIR)/potential + rm -f $(LINKDIR)/prmedit + rm -f $(LINKDIR)/protein + rm -f $(LINKDIR)/pss + rm -f $(LINKDIR)/pssrigid + rm -f $(LINKDIR)/pssrot + rm -f $(LINKDIR)/radial + rm -f $(LINKDIR)/saddle + rm -f $(LINKDIR)/scan + rm -f $(LINKDIR)/sniffer + rm -f $(LINKDIR)/spacefill + rm -f $(LINKDIR)/spectrum + rm -f $(LINKDIR)/superpose + rm -f $(LINKDIR)/sybylxyz + rm -f $(LINKDIR)/testgrad + rm -f $(LINKDIR)/testhess + rm -f $(LINKDIR)/testpair + rm -f $(LINKDIR)/testpol + rm -f $(LINKDIR)/testrot + rm -f $(LINKDIR)/timer + rm -f $(LINKDIR)/timerot + rm -f $(LINKDIR)/torsfit + rm -f $(LINKDIR)/valence + rm -f $(LINKDIR)/vibbig + rm -f $(LINKDIR)/vibrate + rm -f $(LINKDIR)/vibrot + rm -f $(LINKDIR)/xtalfit + rm -f $(LINKDIR)/xtalmin + rm -f $(LINKDIR)/xyzedit + rm -f $(LINKDIR)/xyzint + rm -f $(LINKDIR)/xyzpdb + rm -f $(LINKDIR)/xyzsybyl + rm -f $(LINKDIR)/tkr2qm_s + +create_links: + ln -fs $(BINDIR)/alchemy $(LINKDIR)/alchemy + ln -fs $(BINDIR)/analyze $(LINKDIR)/analyze + ln -fs $(BINDIR)/anneal $(LINKDIR)/anneal + ln -fs $(BINDIR)/archive $(LINKDIR)/archive + ln -fs $(BINDIR)/bar $(LINKDIR)/bar + ln -fs $(BINDIR)/correlate $(LINKDIR)/correlate + ln -fs $(BINDIR)/crystal $(LINKDIR)/crystal + ln -fs $(BINDIR)/diffuse $(LINKDIR)/diffuse + ln -fs $(BINDIR)/distgeom $(LINKDIR)/distgeom + ln -fs $(BINDIR)/document $(LINKDIR)/document + ln -fs $(BINDIR)/dynamic $(LINKDIR)/dynamic + ln -fs $(BINDIR)/gda $(LINKDIR)/gda + ln -fs $(BINDIR)/intedit $(LINKDIR)/intedit + ln -fs $(BINDIR)/intxyz $(LINKDIR)/intxyz + ln -fs $(BINDIR)/minimize $(LINKDIR)/minimize + ln -fs $(BINDIR)/minirot $(LINKDIR)/minirot + ln -fs $(BINDIR)/minrigid $(LINKDIR)/minrigid + ln -fs $(BINDIR)/molxyz $(LINKDIR)/molxyz + ln -fs $(BINDIR)/monte $(LINKDIR)/monte + ln -fs $(BINDIR)/newton $(LINKDIR)/newton + ln -fs $(BINDIR)/newtrot $(LINKDIR)/newtrot + ln -fs $(BINDIR)/nucleic $(LINKDIR)/nucleic + ln -fs $(BINDIR)/optimize $(LINKDIR)/optimize + ln -fs $(BINDIR)/optirot $(LINKDIR)/optirot + ln -fs $(BINDIR)/optrigid $(LINKDIR)/optrigid + ln -fs $(BINDIR)/path $(LINKDIR)/path + ln -fs $(BINDIR)/pdbxyz $(LINKDIR)/pdbxyz + ln -fs $(BINDIR)/polarize $(LINKDIR)/polarize + ln -fs $(BINDIR)/poledit $(LINKDIR)/poledit + ln -fs $(BINDIR)/potential $(LINKDIR)/potential + ln -fs $(BINDIR)/prmedit $(LINKDIR)/prmedit + ln -fs $(BINDIR)/protein $(LINKDIR)/protein + ln -fs $(BINDIR)/pss $(LINKDIR)/pss + ln -fs $(BINDIR)/pssrigid $(LINKDIR)/pssrigid + ln -fs $(BINDIR)/pssrot $(LINKDIR)/pssrot + ln -fs $(BINDIR)/radial $(LINKDIR)/radial + ln -fs $(BINDIR)/saddle $(LINKDIR)/saddle + ln -fs $(BINDIR)/scan $(LINKDIR)/scan + ln -fs $(BINDIR)/sniffer $(LINKDIR)/sniffer + ln -fs $(BINDIR)/spacefill $(LINKDIR)/spacefill + ln -fs $(BINDIR)/spectrum $(LINKDIR)/spectrum + ln -fs $(BINDIR)/superpose $(LINKDIR)/superpose + ln -fs $(BINDIR)/sybylxyz $(LINKDIR)/sybylxyz + ln -fs $(BINDIR)/testgrad $(LINKDIR)/testgrad + ln -fs $(BINDIR)/testhess $(LINKDIR)/testhess + ln -fs $(BINDIR)/testpair $(LINKDIR)/testpair + ln -fs $(BINDIR)/testpol $(LINKDIR)/testpol + ln -fs $(BINDIR)/testrot $(LINKDIR)/testrot + ln -fs $(BINDIR)/timer $(LINKDIR)/timer + ln -fs $(BINDIR)/timerot $(LINKDIR)/timerot + ln -fs $(BINDIR)/torsfit $(LINKDIR)/torsfit + ln -fs $(BINDIR)/valence $(LINKDIR)/valence + ln -fs $(BINDIR)/vibbig $(LINKDIR)/vibbig + ln -fs $(BINDIR)/vibrate $(LINKDIR)/vibrate + ln -fs $(BINDIR)/vibrot $(LINKDIR)/vibrot + ln -fs $(BINDIR)/xtalfit $(LINKDIR)/xtalfit + ln -fs $(BINDIR)/xtalmin $(LINKDIR)/xtalmin + ln -fs $(BINDIR)/xyzedit $(LINKDIR)/xyzedit + ln -fs $(BINDIR)/xyzint $(LINKDIR)/xyzint + ln -fs $(BINDIR)/xyzpdb $(LINKDIR)/xyzpdb + ln -fs $(BINDIR)/xyzsybyl $(LINKDIR)/xyzsybyl + ln -fs $(BINDIR)/tkr2qm_s $(LINKDIR)/tkr2qm_s + +libtinker.a: ${OBJS} ${OBJQMMM} + ar ${LIBFLAGS} libtinker.a \ + active.o \ + analysis.o \ + angles.o \ + attach.o \ + basefile.o \ + beeman.o \ + bicubic.o \ + bitors.o \ + bonds.o \ + born.o \ + bounds.o \ + bussi.o \ + calendar.o \ + center.o \ + chkpole.o \ + chkring.o \ + chkxyz.o \ + cholesky.o \ + clock.o \ + cluster.o \ + column.o \ + command.o \ + connect.o \ + connolly.o \ + control.o \ + cspline.o \ + cutoffs.o \ + deflate.o \ + delete.o \ + diagq.o \ + diffeq.o \ + eangang.o \ + eangang1.o \ + eangang2.o \ + eangang3.o \ + eangle.o \ + eangle1.o \ + eangle2.o \ + eangle3.o \ + ebond.o \ + ebond1.o \ + ebond2.o \ + ebond3.o \ + ebuck.o \ + ebuck1.o \ + ebuck2.o \ + ebuck3.o \ + echarge.o \ + echarge1.o \ + echarge2.o \ + echarge3.o \ + echgdpl.o \ + echgdpl1.o \ + echgdpl2.o \ + echgdpl3.o \ + edipole.o \ + edipole1.o \ + edipole2.o \ + edipole3.o \ + egauss.o \ + egauss1.o \ + egauss2.o \ + egauss3.o \ + egeom.o \ + egeom1.o \ + egeom2.o \ + egeom3.o \ + ehal.o \ + ehal1.o \ + ehal2.o \ + ehal3.o \ + eimprop.o \ + eimprop1.o \ + eimprop2.o \ + eimprop3.o \ + eimptor.o \ + eimptor1.o \ + eimptor2.o \ + eimptor3.o \ + elj.o \ + elj1.o \ + elj2.o \ + elj3.o \ + embed.o \ + emetal.o \ + emetal1.o \ + emetal2.o \ + emetal3.o \ + emm3hb.o \ + emm3hb1.o \ + emm3hb2.o \ + emm3hb3.o \ + empole.o \ + empole1.o \ + empole2.o \ + empole3.o \ + energy.o \ + eopbend.o \ + eopbend1.o \ + eopbend2.o \ + eopbend3.o \ + eopdist.o \ + eopdist1.o \ + eopdist2.o \ + eopdist3.o \ + epitors.o \ + epitors1.o \ + epitors2.o \ + epitors3.o \ + erf.o \ + erxnfld.o \ + erxnfld1.o \ + erxnfld2.o \ + erxnfld3.o \ + esolv.o \ + esolv1.o \ + esolv2.o \ + esolv3.o \ + estrbnd.o \ + estrbnd1.o \ + estrbnd2.o \ + estrbnd3.o \ + estrtor.o \ + estrtor1.o \ + estrtor2.o \ + estrtor3.o \ + etors.o \ + etors1.o \ + etors2.o \ + etors3.o \ + etortor.o \ + etortor1.o \ + etortor2.o \ + etortor3.o \ + eurey.o \ + eurey1.o \ + eurey2.o \ + eurey3.o \ + evcorr.o \ + extra.o \ + extra1.o \ + extra2.o \ + extra3.o \ + fatal.o \ + fft3d.o \ + fftpack.o \ + field.o \ + final.o \ + flatten.o \ + freeunit.o \ + geometry.o \ + getint.o \ + getkey.o \ + getmol.o \ + getmol2.o \ + getnumb.o \ + getpdb.o \ + getprm.o \ + getref.o \ + getstring.o \ + gettext.o \ + getword.o \ + getxyz.o \ + ghmcstep.o \ + gradient.o \ + gradrgd.o \ + gradrot.o \ + groups.o \ + grpline.o \ + gyrate.o \ + hessian.o \ + hessrgd.o \ + hessrot.o \ + hybrid.o \ + image.o \ + impose.o \ + induce.o \ + inertia.o \ + initatom.o \ + initial.o \ + initprm.o \ + initres.o \ + initrot.o \ + insert.o \ + invbeta.o \ + invert.o \ + jacobi.o \ + kangang.o \ + kangle.o \ + katom.o \ + kbond.o \ + kcharge.o \ + kdipole.o \ + kewald.o \ + kextra.o \ + kgeom.o \ + kimprop.o \ + kimptor.o \ + kinetic.o \ + kmetal.o \ + kmpole.o \ + kopbend.o \ + kopdist.o \ + korbit.o \ + kpitors.o \ + kpolar.o \ + ksolv.o \ + kstrbnd.o \ + kstrtor.o \ + ktors.o \ + ktortor.o \ + kurey.o \ + kvdw.o \ + lattice.o \ + lbfgs.o \ + lights.o \ + makeint.o \ + makeref.o \ + makexyz.o \ + maxwell.o \ + mdinit.o \ + mdrest.o \ + mdsave.o \ + mdstat.o \ + mechanic.o \ + merge.o \ + molecule.o \ + moments.o \ + mutate.o \ + nblist.o \ + nextarg.o \ + nexttext.o \ + nose.o \ + nspline.o \ + number.o \ + numeral.o \ + numgrad.o \ + ocvm.o \ + openend.o \ + optsave.o \ + orbital.o \ + orient.o \ + orthog.o \ + overlap.o \ + picalc.o \ + pmestuff.o \ + pmpb.o \ + polymer.o \ + precise.o \ + pressure.o \ + prmkey.o \ + promo.o \ + prtdyn.o \ + prterr.o \ + prtint.o \ + prtmol2.o \ + prtpdb.o \ + prtprm.o \ + prtseq.o \ + prtxyz.o \ + quatfit.o \ + random.o \ + rattle.o \ + readdyn.o \ + readgau.o \ + readint.o \ + readmol.o \ + readmol2.o \ + readpdb.o \ + readprm.o \ + readseq.o \ + readxyz.o \ + replica.o \ + respa.o \ + rgdstep.o \ + rings.o \ + rmsfit.o \ + rotlist.o \ + rotpole.o \ + sdstep.o \ + search.o \ + server.o \ + shakeup.o \ + sigmoid.o \ + sktstuff.o \ + sort.o \ + square.o \ + suffix.o \ + surface.o \ + surfatom.o \ + switch.o \ + temper.o \ + tncg.o \ + torphase.o \ + torque.o \ + torsions.o \ + trimtext.o \ + unitcell.o \ + verlet.o \ + version.o \ + volume.o \ + xyzatm.o \ + zatom.o + ar ${LIBFLAGS} libtinker.a \ + elecpot.o \ + extpot.o \ + minimizemm.o \ + qmmm_eg.o \ + qmmm_post.o \ + qmmm_todo.o \ + qmmmsetup.o \ + runqm.o \ + update_qmmm.o \ + tkr2qm.o + +############################################################### +## Next Section has Explicit Dependencies on Include Files ## +############################################################### + +active.o: atoms.i inform.i iounit.i keys.i sizes.i usage.i +alchemy.o: analyz.i atoms.i energi.i files.i inform.i iounit.i katoms.i mutant.i potent.i sizes.i units.i usage.i +analysis.o: analyz.i atoms.i bound.i cutoff.i energi.i group.i inter.i iounit.i potent.i sizes.i vdwpot.i +analyze.o: action.i analyz.i angang.i angle.i angpot.i atmtyp.i atoms.i bitor.i bond.i bound.i boxes.i charge.i chgpot.i couple.i cutoff.i dipole.i energi.i ewald.i fields.i files.i improp.i imptor.i inform.i inter.i iounit.i korbs.i ktrtor.i kvdws.i math.i molcul.i moment.i mpole.i opbend.i opdist.i piorbs.i pistuf.i pitors.i pme.i polar.i polgrp.i potent.i sizes.i solute.i strbnd.i strtor.i tors.i tortor.i units.i urey.i vdw.i vdwpot.i virial.i +angles.o: angle.i atmlst.i atoms.i couple.i iounit.i qmmm.i sizes.i +anneal.o: atmtyp.i atoms.i bath.i bond.i bound.i inform.i iounit.i mdstuf.i potent.i sizes.i solute.i usage.i warp.i +archive.o: atmtyp.i atoms.i boxes.i couple.i files.i inform.i iounit.i sizes.i titles.i usage.i +attach.o: atoms.i couple.i iounit.i sizes.i +bar.o: atoms.i energi.i files.i inform.i iounit.i keys.i sizes.i units.i +basefile.o: ascii.i files.i +beeman.o: atmtyp.i atoms.i freeze.i mdstuf.i moldyn.i sizes.i units.i usage.i +bicubic.o: +bitors.o: angle.i bitor.i couple.i iounit.i sizes.i +bonds.o: atmlst.i atoms.i bond.i couple.i iounit.i qmmm.i sizes.i +born.o: atmtyp.i atoms.i bath.i chgpot.i couple.i deriv.i inform.i iounit.i math.i pbstuf.i potent.i sizes.i solute.i virial.i +bounds.o: atmtyp.i atoms.i boxes.i molcul.i sizes.i +bussi.o: atmtyp.i atoms.i bath.i boxes.i freeze.i mdstuf.i moldyn.i sizes.i units.i usage.i +calendar.o: +center.o: align.i sizes.i +chkpole.o: atoms.i mpole.i sizes.i +chkring.o: couple.i sizes.i +chkxyz.o: atoms.i iounit.i sizes.i +cholesky.o: +clock.o: chrono.i +cluster.o: atmtyp.i atoms.i bound.i cutoff.i group.i inform.i iounit.i keys.i molcul.i sizes.i +column.o: sizes.i +command.o: argue.i +connect.o: atoms.i couple.i sizes.i zclose.i zcoord.i +connolly.o: atoms.i faces.i inform.i iounit.i math.i sizes.i +control.o: argue.i inform.i keys.i output.i sizes.i +correlate.o: ascii.i atmtyp.i atoms.i files.i inform.i iounit.i sizes.i +crystal.o: atmtyp.i atoms.i bound.i boxes.i couple.i files.i iounit.i math.i molcul.i sizes.i +cspline.o: iounit.i +cutoffs.o: atoms.i bound.i cutoff.i hescut.i keys.i neigh.i polpot.i sizes.i +deflate.o: iounit.i +delete.o: atmtyp.i atoms.i couple.i inform.i iounit.i sizes.i +diagq.o: +diffeq.o: atoms.i iounit.i math.i sizes.i warp.i +diffuse.o: atmtyp.i atoms.i boxes.i iounit.i molcul.i sizes.i usage.i +distgeom.o: angle.i atmtyp.i atoms.i bond.i couple.i disgeo.i files.i inform.i iounit.i kgeoms.i kvdws.i math.i refer.i sizes.i tors.i +document.o: iounit.i +dynamic.o: atoms.i bath.i bond.i bound.i inform.i iounit.i keys.i mdstuf.i potent.i sizes.i solute.i stodyn.i usage.i +eangang1.o: angang.i angle.i angpot.i atoms.i bound.i deriv.i energi.i group.i math.i sizes.i usage.i virial.i +eangang2.o: angang.i angle.i angpot.i atoms.i bound.i deriv.i group.i hessn.i math.i sizes.i +eangang3.o: action.i analyz.i angang.i angle.i angpot.i atmtyp.i atoms.i bound.i energi.i group.i inform.i iounit.i math.i sizes.i usage.i +eangang.o: angang.i angle.i angpot.i atoms.i bound.i energi.i group.i math.i sizes.i usage.i +eangle1.o: angle.i angpot.i atoms.i bound.i deriv.i energi.i group.i math.i sizes.i usage.i virial.i +eangle2.o: angle.i angpot.i atoms.i bound.i deriv.i group.i hessn.i math.i qmmm.i sizes.i +eangle3.o: action.i analyz.i angle.i angpot.i atmtyp.i atoms.i bound.i energi.i group.i inform.i iounit.i math.i sizes.i usage.i +eangle.o: angle.i angpot.i atoms.i bound.i energi.i group.i math.i sizes.i usage.i +ebond1.o: atoms.i bndpot.i bond.i bound.i deriv.i energi.i group.i sizes.i usage.i virial.i +ebond2.o: atmlst.i atoms.i bndpot.i bond.i bound.i couple.i group.i hessn.i sizes.i +ebond3.o: action.i analyz.i atmtyp.i atoms.i bndpot.i bond.i bound.i energi.i group.i inform.i iounit.i sizes.i usage.i +ebond.o: atoms.i bndpot.i bond.i bound.i energi.i group.i sizes.i usage.i +ebuck1.o: atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i deriv.i energi.i group.i inter.i iounit.i light.i math.i molcul.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i virial.i warp.i +ebuck2.o: atmtyp.i atoms.i bound.i cell.i couple.i group.i hessn.i iounit.i math.i qmmm.i shunt.i sizes.i vdw.i vdwpot.i warp.i +ebuck3.o: action.i analyz.i atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i energi.i group.i inform.i inter.i iounit.i light.i math.i molcul.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i warp.i +ebuck.o: atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i energi.i group.i iounit.i light.i math.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i warp.i +echarge1.o: atoms.i bound.i boxes.i cell.i charge.i chgpot.i couple.i cutoff.i deriv.i energi.i ewald.i group.i inter.i light.i math.i molcul.i neigh.i pme.i qmmm.i shunt.i sizes.i usage.i virial.i warp.i +echarge2.o: atoms.i bound.i cell.i charge.i chgpot.i couple.i cutoff.i ewald.i group.i hessn.i math.i qmmm.i shunt.i sizes.i warp.i +echarge3.o: action.i analyz.i atmtyp.i atoms.i bound.i boxes.i cell.i charge.i chgpot.i couple.i cutoff.i energi.i ewald.i group.i inform.i inter.i iounit.i light.i math.i molcul.i neigh.i qmmm.i shunt.i sizes.i usage.i warp.i +echarge.o: atoms.i bound.i boxes.i cell.i charge.i chgpot.i couple.i cutoff.i energi.i ewald.i group.i iounit.i light.i math.i neigh.i pme.i qmmm.i shunt.i sizes.i usage.i warp.i +echgdpl1.o: atoms.i bound.i cell.i charge.i chgpot.i couple.i deriv.i dipole.i energi.i group.i inter.i molcul.i qmmm.i shunt.i sizes.i units.i usage.i virial.i +echgdpl2.o: atoms.i bound.i cell.i charge.i chgpot.i couple.i dipole.i group.i hessn.i qmmm.i shunt.i sizes.i units.i +echgdpl3.o: action.i analyz.i atmtyp.i atoms.i bound.i cell.i charge.i chgpot.i couple.i dipole.i energi.i group.i inform.i inter.i iounit.i molcul.i qmmm.i shunt.i sizes.i units.i usage.i +echgdpl.o: atoms.i bound.i cell.i charge.i chgpot.i couple.i dipole.i energi.i group.i qmmm.i shunt.i sizes.i units.i usage.i +edipole1.o: atoms.i bound.i cell.i chgpot.i deriv.i dipole.i energi.i group.i inter.i molcul.i shunt.i sizes.i units.i usage.i virial.i +edipole2.o: atoms.i bound.i cell.i chgpot.i dipole.i group.i hessn.i shunt.i sizes.i units.i +edipole3.o: action.i analyz.i atmtyp.i atoms.i bound.i cell.i chgpot.i dipole.i energi.i group.i inform.i inter.i iounit.i molcul.i shunt.i sizes.i units.i usage.i +edipole.o: atoms.i bound.i cell.i chgpot.i dipole.i energi.i group.i shunt.i sizes.i units.i usage.i +egauss1.o: atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i deriv.i energi.i group.i inter.i iounit.i light.i math.i molcul.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i virial.i warp.i +egauss2.o: atmtyp.i atoms.i bound.i cell.i couple.i group.i hessn.i qmmm.i shunt.i sizes.i vdw.i vdwpot.i warp.i +egauss3.o: action.i analyz.i atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i energi.i group.i inform.i inter.i iounit.i light.i math.i molcul.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i warp.i +egauss.o: atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i energi.i group.i light.i math.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i warp.i +egeom1.o: atmtyp.i atoms.i bound.i deriv.i energi.i group.i inter.i kgeoms.i math.i molcul.i sizes.i usage.i virial.i +egeom2.o: atmtyp.i atoms.i bound.i deriv.i group.i hessn.i kgeoms.i math.i molcul.i sizes.i +egeom3.o: action.i analyz.i atmtyp.i atoms.i bound.i energi.i group.i inform.i inter.i iounit.i kgeoms.i math.i molcul.i sizes.i usage.i +egeom.o: atmtyp.i atoms.i bound.i energi.i group.i kgeoms.i math.i molcul.i sizes.i usage.i +ehal1.o: atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i deriv.i energi.i group.i inter.i iounit.i light.i molcul.i mutant.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i virial.i +ehal2.o: atmtyp.i atoms.i bound.i cell.i couple.i group.i hessn.i qmmm.i shunt.i sizes.i vdw.i vdwpot.i +ehal3.o: action.i analyz.i atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i energi.i group.i inform.i inter.i iounit.i light.i molcul.i mutant.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i +ehal.o: atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i energi.i group.i light.i mutant.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i +eimprop1.o: atoms.i bound.i deriv.i energi.i group.i improp.i math.i sizes.i torpot.i usage.i virial.i +eimprop2.o: atoms.i bound.i group.i hessn.i improp.i math.i sizes.i torpot.i +eimprop3.o: action.i analyz.i atmtyp.i atoms.i bound.i energi.i group.i improp.i inform.i iounit.i math.i sizes.i torpot.i usage.i +eimprop.o: atoms.i bound.i energi.i group.i improp.i math.i sizes.i torpot.i usage.i +eimptor1.o: atoms.i bound.i deriv.i energi.i group.i imptor.i sizes.i torpot.i usage.i virial.i +eimptor2.o: atoms.i bound.i group.i hessn.i imptor.i sizes.i torpot.i +eimptor3.o: action.i analyz.i atmtyp.i atoms.i bound.i energi.i group.i imptor.i inform.i iounit.i math.i sizes.i torpot.i usage.i +eimptor.o: atoms.i bound.i energi.i group.i imptor.i sizes.i torpot.i usage.i +elecpol0.o: atoms.i bound.i boxes.i cell.i chgpot.i couple.i cutoff.i deriv.i energi.i ewald.i group.i inter.i math.i molcul.i mplpot.i mpole.i neigh.i pme.i polar.i polgrp.i polpot.i potent.i qmmm.i shunt.i sizes.i usage.i virial.i +elecpol1.o: atoms.i bound.i boxes.i chgpot.i couple.i cutoff.i deriv.i group.i hessn.i molcul.i mplpot.i mpole.i polar.i polgrp.i polpot.i potent.i qmmm.i shunt.i sizes.i usage.i +elecpot.o: atoms.i bound.i cell.i charge.i chgpot.i couple.i cutoff.i ewald.i group.i hessn.i math.i qmmm.i shunt.i sizes.i warp.i +elj1.o: atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i deriv.i energi.i group.i inter.i light.i math.i molcul.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i virial.i warp.i +elj2.o: atmtyp.i atoms.i bound.i cell.i couple.i group.i hessn.i math.i qmmm.i shunt.i sizes.i vdw.i vdwpot.i warp.i +elj3.o: action.i analyz.i atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i energi.i group.i inform.i inter.i iounit.i light.i math.i molcul.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i warp.i +elj.o: atmtyp.i atoms.i bound.i boxes.i cell.i couple.i cutoff.i energi.i group.i light.i math.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i warp.i +embed.o: angle.i atoms.i bond.i couple.i disgeo.i files.i inform.i iounit.i keys.i kgeoms.i light.i math.i minima.i output.i refer.i sizes.i tors.i units.i +emetal1.o: atmtyp.i atoms.i couple.i deriv.i energi.i kchrge.i sizes.i +emetal2.o: +emetal3.o: action.i analyz.i atmtyp.i atoms.i energi.i kchrge.i sizes.i +emetal.o: atmtyp.i atoms.i couple.i energi.i kchrge.i sizes.i +emm3hb1.o: atmlst.i atmtyp.i atoms.i bond.i bound.i boxes.i cell.i chgpot.i couple.i cutoff.i deriv.i energi.i group.i inter.i iounit.i light.i molcul.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i virial.i +emm3hb2.o: atmlst.i atmtyp.i atoms.i bond.i bound.i cell.i chgpot.i couple.i group.i hessn.i qmmm.i shunt.i sizes.i vdw.i vdwpot.i +emm3hb3.o: action.i analyz.i atmlst.i atmtyp.i atoms.i bond.i bound.i boxes.i cell.i chgpot.i couple.i cutoff.i energi.i group.i inform.i inter.i iounit.i light.i molcul.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i +emm3hb.o: atmlst.i atmtyp.i atoms.i bond.i bound.i boxes.i cell.i chgpot.i couple.i cutoff.i energi.i group.i light.i neigh.i qmmm.i shunt.i sizes.i usage.i vdw.i vdwpot.i +empole1.o: atoms.i bound.i boxes.i cell.i chgpot.i couple.i cutoff.i deriv.i energi.i ewald.i group.i inter.i math.i molcul.i mplpot.i mpole.i neigh.i pme.i polar.i polgrp.i polpot.i potent.i qmmm.i shunt.i sizes.i usage.i virial.i +empole2.o: atoms.i bound.i boxes.i chgpot.i couple.i cutoff.i deriv.i group.i hessn.i molcul.i mplpot.i mpole.i polar.i polgrp.i polpot.i potent.i qmmm.i shunt.i sizes.i usage.i +empole3.o: action.i analyz.i atmtyp.i atoms.i bound.i boxes.i cell.i chgpot.i couple.i cutoff.i energi.i ewald.i group.i inform.i inter.i iounit.i math.i molcul.i mplpot.i mpole.i neigh.i polar.i polgrp.i polpot.i potent.i qmmm.i shunt.i sizes.i usage.i +empole.o: atoms.i bound.i boxes.i cell.i chgpot.i couple.i cutoff.i energi.i ewald.i group.i math.i mplpot.i mpole.i neigh.i pme.i polar.i polgrp.i polpot.i potent.i qmmm.i shunt.i sizes.i usage.i +energy.o: bound.i cutoff.i energi.i iounit.i potent.i rigid.i sizes.i vdwpot.i +eopbend1.o: angle.i angpot.i atoms.i bound.i deriv.i energi.i group.i math.i opbend.i sizes.i usage.i virial.i +eopbend2.o: angle.i angpot.i atoms.i bound.i deriv.i group.i hessn.i math.i opbend.i sizes.i +eopbend3.o: action.i analyz.i angle.i angpot.i atmtyp.i atoms.i bound.i energi.i group.i inform.i iounit.i math.i opbend.i sizes.i usage.i +eopbend.o: angle.i angpot.i atoms.i bound.i energi.i fields.i group.i math.i opbend.i sizes.i usage.i +eopdist1.o: angpot.i atoms.i bound.i deriv.i energi.i group.i opdist.i sizes.i usage.i virial.i +eopdist2.o: angpot.i atoms.i bound.i group.i hessn.i opdist.i sizes.i usage.i +eopdist3.o: action.i analyz.i angpot.i atmtyp.i atoms.i bound.i energi.i group.i inform.i iounit.i opdist.i sizes.i usage.i +eopdist.o: angpot.i atoms.i bound.i energi.i group.i opdist.i sizes.i usage.i +epitors1.o: atoms.i bound.i deriv.i energi.i group.i pitors.i sizes.i torpot.i usage.i virial.i +epitors2.o: angle.i atoms.i bound.i deriv.i group.i hessn.i pitors.i sizes.i torpot.i usage.i +epitors3.o: action.i analyz.i atmtyp.i atoms.i bound.i energi.i group.i inform.i iounit.i math.i pitors.i sizes.i torpot.i usage.i +epitors.o: atoms.i bound.i energi.i group.i pitors.i sizes.i torpot.i usage.i +erf.o: iounit.i math.i +erxnfld1.o: atoms.i deriv.i energi.i sizes.i +erxnfld2.o: +erxnfld3.o: action.i analyz.i atmtyp.i atoms.i chgpot.i energi.i inform.i iounit.i mpole.i qmmm.i shunt.i sizes.i usage.i +erxnfld.o: atoms.i chgpot.i energi.i mpole.i qmmm.i rxnfld.i rxnpot.i shunt.i sizes.i usage.i +esolv1.o: atmtyp.i atoms.i bound.i boxes.i charge.i chgpot.i couple.i cutoff.i deriv.i energi.i gkstuf.i group.i hpmf.i inter.i iounit.i kvdws.i math.i molcul.i mplpot.i mpole.i npolar.i pbstuf.i polar.i polgrp.i polpot.i potent.i shunt.i sizes.i solute.i usage.i vdw.i virial.i warp.i +esolv2.o: atoms.i charge.i chgpot.i hessn.i math.i potent.i shunt.i sizes.i solute.i warp.i +esolv3.o: action.i analyz.i atmtyp.i atoms.i bound.i charge.i chgpot.i couple.i deriv.i energi.i gkstuf.i group.i hpmf.i inform.i inter.i iounit.i kvdws.i math.i molcul.i mpole.i npolar.i pbstuf.i polar.i polgrp.i polpot.i potent.i shunt.i sizes.i solute.i usage.i vdw.i warp.i +esolv.o: atmtyp.i atoms.i bound.i charge.i chgpot.i couple.i deriv.i energi.i gkstuf.i group.i hpmf.i kvdws.i math.i mpole.i npolar.i pbstuf.i polar.i polgrp.i polpot.i potent.i shunt.i sizes.i solute.i usage.i vdw.i warp.i +estrbnd1.o: angle.i angpot.i atoms.i bond.i bound.i deriv.i energi.i group.i math.i sizes.i strbnd.i usage.i virial.i +estrbnd2.o: angle.i angpot.i atoms.i bond.i bound.i group.i hessn.i math.i sizes.i strbnd.i +estrbnd3.o: action.i analyz.i angle.i angpot.i atmtyp.i atoms.i bond.i bound.i energi.i group.i inform.i iounit.i math.i sizes.i strbnd.i usage.i +estrbnd.o: angle.i angpot.i atoms.i bond.i bound.i energi.i group.i math.i sizes.i strbnd.i usage.i +estrtor1.o: atoms.i bond.i bound.i deriv.i energi.i group.i sizes.i strtor.i torpot.i tors.i usage.i virial.i +estrtor2.o: atoms.i bond.i bound.i group.i hessn.i sizes.i strtor.i torpot.i tors.i +estrtor3.o: action.i analyz.i atmtyp.i atoms.i bond.i bound.i energi.i group.i inform.i iounit.i math.i sizes.i strtor.i torpot.i tors.i usage.i +estrtor.o: atoms.i bond.i bound.i energi.i group.i sizes.i strtor.i torpot.i tors.i usage.i +etors1.o: atoms.i bound.i deriv.i energi.i group.i math.i sizes.i torpot.i tors.i usage.i virial.i warp.i +etors2.o: atoms.i bound.i group.i hessn.i math.i sizes.i torpot.i tors.i warp.i +etors3.o: action.i analyz.i atmtyp.i atoms.i bound.i energi.i group.i inform.i iounit.i math.i sizes.i torpot.i tors.i usage.i warp.i +etors.o: atoms.i bound.i energi.i group.i math.i sizes.i torpot.i tors.i usage.i warp.i +etortor1.o: atoms.i bitor.i bound.i deriv.i energi.i group.i ktrtor.i math.i sizes.i torpot.i tortor.i usage.i virial.i +etortor2.o: atoms.i bitor.i bound.i group.i hessn.i ktrtor.i math.i sizes.i torpot.i tortor.i units.i +etortor3.o: action.i analyz.i atoms.i bitor.i bound.i energi.i group.i inform.i iounit.i ktrtor.i math.i sizes.i torpot.i tortor.i usage.i +etortor.o: atmtyp.i atoms.i bitor.i bound.i couple.i energi.i group.i ktrtor.i math.i sizes.i torpot.i tortor.i usage.i +eurey1.o: atoms.i bound.i deriv.i energi.i group.i sizes.i urey.i urypot.i usage.i virial.i +eurey2.o: atoms.i bound.i couple.i group.i hessn.i sizes.i urey.i urypot.i +eurey3.o: action.i analyz.i atmtyp.i atoms.i bound.i energi.i group.i inform.i iounit.i sizes.i urey.i urypot.i usage.i +eurey.o: atoms.i bound.i energi.i group.i sizes.i urey.i urypot.i usage.i +evcorr.o: bound.i boxes.i cutoff.i math.i shunt.i sizes.i vdw.i vdwpot.i +extpot.o: atoms.i charge.i files.i inform.i iounit.i potent.i qmmm.i sizes.i +extra1.o: atoms.i deriv.i energi.i sizes.i +extra2.o: atoms.i hessn.i sizes.i +extra3.o: action.i analyz.i atoms.i energi.i sizes.i +extra.o: energi.i +fatal.o: iounit.i +fft3d.o: fft.i openmp.i pme.i sizes.i +fftpack.o: math.i +field.o: keys.i potent.i sizes.i +final.o: chunks.i disgeo.i inform.i iounit.i neigh.i paths.i pme.i sizes.i socket.i solute.i uprior.i usage.i usolve.i vibs.i +flatten.o: atoms.i fields.i inform.i iounit.i keys.i sizes.i warp.i +freeunit.o: iounit.i +gda.o: atoms.i files.i iounit.i minima.i potent.i sizes.i vdwpot.i warp.i +geometry.o: atoms.i math.i sizes.i +getint.o: atoms.i inform.i iounit.i output.i sizes.i +getkey.o: argue.i files.i iounit.i keys.i openmp.i sizes.i +getmol2.o: files.i iounit.i +getmol.o: files.i iounit.i +getnumb.o: ascii.i +getpdb.o: iounit.i +getprm.o: files.i iounit.i keys.i params.i sizes.i +getref.o: atmtyp.i atoms.i couple.i files.i refer.i sizes.i titles.i +getstring.o: ascii.i +gettext.o: ascii.i +getword.o: ascii.i +getxyz.o: inform.i iounit.i output.i +ghmcstep.o: atmtyp.i atoms.i bath.i freeze.i iounit.i mdstuf.i moldyn.i sizes.i stodyn.i units.i usage.i virial.i +gradient.o: atoms.i bound.i couple.i cutoff.i deriv.i energi.i inform.i inter.i iounit.i potent.i qmmm.i rigid.i sizes.i vdwpot.i virial.i +gradrgd.o: atoms.i group.i rigid.i sizes.i +gradrot.o: atoms.i deriv.i domega.i omega.i potent.i rotate.i sizes.i +groups.o: group.i sizes.i +grpline.o: atmtyp.i atoms.i group.i rgddyn.i sizes.i +gyrate.o: atoms.i sizes.i usage.i +hessian.o: atoms.i bound.i couple.i cutoff.i hescut.i hessn.i inform.i iounit.i mpole.i potent.i rigid.i sizes.i usage.i vdw.i vdwpot.i +hessrgd.o: atoms.i group.i rigid.i sizes.i +hessrot.o: math.i omega.i sizes.i zcoord.i +hybrid.o: angle.i atmlst.i atmtyp.i atoms.i bond.i charge.i couple.i dipole.i imptor.i inform.i iounit.i kangs.i katoms.i kbonds.i kchrge.i kdipol.i kitors.i kstbnd.i ksttor.i ktorsn.i kvdws.i math.i mutant.i sizes.i strbnd.i strtor.i tors.i vdw.i vdwpot.i +image.o: boxes.i cell.i sizes.i +impose.o: align.i inform.i iounit.i sizes.i +induce.o: atoms.i bound.i boxes.i cell.i couple.i cutoff.i ewald.i gkstuf.i group.i inform.i iounit.i math.i mpole.i neigh.i pbstuf.i pme.i polar.i polgrp.i polpot.i potent.i qmmm.i shunt.i sizes.i solute.i units.i uprior.i usolve.i +inertia.o: atmtyp.i atoms.i iounit.i math.i sizes.i +initatom.o: ptable.i sizes.i +initial.o: align.i atoms.i bath.i bound.i cell.i files.i group.i inform.i iounit.i keys.i linmin.i minima.i molcul.i mutant.i neigh.i openmp.i output.i params.i pdb.i precis.i rigid.i scales.i sequen.i sizes.i socket.i warp.i zclose.i +initprm.o: angpot.i bndpot.i chgpot.i fields.i kanang.i kangs.i katoms.i kbonds.i kchrge.i kdipol.i khbond.i kiprop.i kitors.i kmulti.i kopbnd.i kopdst.i korbs.i kpitor.i kpolr.i kstbnd.i ksttor.i ktorsn.i ktrtor.i kurybr.i kvdwpr.i kvdws.i math.i merck.i mplpot.i polpot.i rxnpot.i sizes.i solute.i torpot.i units.i urypot.i vdwpot.i +initres.o: resdue.i sizes.i +initrot.o: atoms.i couple.i group.i inform.i iounit.i kgeoms.i math.i omega.i rotate.i sizes.i usage.i zcoord.i +insert.o: atmtyp.i atoms.i couple.i inform.i iounit.i sizes.i +intedit.o: atmtyp.i atoms.i files.i iounit.i katoms.i sizes.i zcoord.i +intxyz.o: files.i iounit.i titles.i +invbeta.o: +invert.o: iounit.i +jacobi.o: iounit.i +kangang.o: angang.i angle.i atmlst.i atmtyp.i atoms.i couple.i inform.i iounit.i kanang.i keys.i potent.i sizes.i +kangle.o: angle.i angpot.i atmtyp.i atoms.i bond.i couple.i fields.i inform.i iounit.i kangs.i keys.i merck.i potent.i ring.i sizes.i usage.i +katom.o: atmtyp.i atoms.i couple.i inform.i iounit.i katoms.i keys.i sizes.i +kbond.o: angle.i atmlst.i atmtyp.i atoms.i bond.i couple.i fields.i inform.i iounit.i kbonds.i keys.i merck.i potent.i sizes.i tors.i usage.i +kcharge.o: atmtyp.i atoms.i charge.i chgpot.i couple.i fields.i inform.i iounit.i kchrge.i keys.i merck.i potent.i qmmm.i sizes.i +kdipole.o: atmlst.i atoms.i bond.i couple.i dipole.i inform.i iounit.i kdipol.i keys.i potent.i qmmm.i sizes.i +kewald.o: atoms.i bound.i boxes.i chunks.i cutoff.i ewald.i fft.i inform.i iounit.i keys.i math.i openmp.i pme.i sizes.i +kextra.o: +kgeom.o: atmtyp.i atoms.i bound.i couple.i group.i iounit.i keys.i kgeoms.i molcul.i potent.i sizes.i +kimprop.o: atmtyp.i atoms.i couple.i improp.i inform.i iounit.i keys.i kiprop.i potent.i qmmm.i sizes.i +kimptor.o: atmtyp.i atoms.i couple.i imptor.i inform.i iounit.i keys.i kitors.i math.i potent.i qmmm.i sizes.i +kinetic.o: atmtyp.i atoms.i bath.i group.i mdstuf.i moldyn.i rgddyn.i sizes.i units.i usage.i +kmetal.o: +kmpole.o: atoms.i couple.i inform.i iounit.i keys.i kmulti.i mpole.i polar.i polgrp.i potent.i sizes.i units.i +kopbend.o: angle.i angpot.i atmtyp.i atoms.i couple.i fields.i inform.i iounit.i keys.i kopbnd.i merck.i opbend.i potent.i qmmm.i sizes.i usage.i +kopdist.o: angle.i angpot.i atmlst.i atmtyp.i atoms.i couple.i inform.i iounit.i keys.i kopdst.i opdist.i potent.i qmmm.i sizes.i +korbit.o: atmtyp.i atoms.i bond.i inform.i iounit.i keys.i korbs.i orbits.i piorbs.i pistuf.i sizes.i tors.i units.i +kpitors.o: atmtyp.i atoms.i bond.i couple.i inform.i iounit.i keys.i kpitor.i pitors.i potent.i sizes.i +kpolar.o: atoms.i couple.i inform.i iounit.i keys.i kpolr.i mpole.i polar.i polgrp.i polpot.i potent.i qmmm.i sizes.i usolve.i +ksolv.o: angle.i atmlst.i atmtyp.i atoms.i bath.i bond.i chgpot.i couple.i gkstuf.i hpmf.i inform.i iounit.i keys.i kvdws.i math.i npolar.i pbstuf.i potent.i sizes.i solute.i +kstrbnd.o: angle.i angpot.i atmlst.i atmtyp.i atoms.i couple.i fields.i inform.i iounit.i keys.i kstbnd.i merck.i potent.i qmmm.i ring.i sizes.i strbnd.i +kstrtor.o: atmlst.i atmtyp.i atoms.i couple.i inform.i iounit.i keys.i ksttor.i potent.i sizes.i strtor.i tors.i +ktors.o: atmtyp.i atoms.i couple.i fields.i inform.i iounit.i keys.i ktorsn.i math.i merck.i potent.i ring.i sizes.i tors.i usage.i +ktortor.o: atmtyp.i atoms.i bitor.i inform.i iounit.i keys.i ktrtor.i potent.i sizes.i tortor.i +kurey.o: angle.i atmtyp.i atoms.i inform.i iounit.i keys.i kurybr.i potent.i qmmm.i sizes.i urey.i +kvdw.o: atmtyp.i atoms.i couple.i fields.i inform.i iounit.i keys.i khbond.i kvdwpr.i kvdws.i math.i merck.i potent.i qmmm.i sizes.i vdw.i vdwpot.i +lattice.o: boxes.i cell.i inform.i iounit.i math.i sizes.i +lbfgs.o: inform.i iounit.i keys.i linmin.i math.i minima.i output.i scales.i sizes.i +lights.o: bound.i boxes.i cell.i iounit.i light.i sizes.i +makeint.o: atoms.i couple.i inform.i iounit.i math.i sizes.i zclose.i zcoord.i +makeref.o: atmtyp.i atoms.i couple.i files.i refer.i sizes.i titles.i +makexyz.o: atoms.i sizes.i zcoord.i +maxwell.o: units.i +mdinit.o: atmtyp.i atoms.i bath.i bound.i files.i freeze.i group.i inform.i iounit.i keys.i mdstuf.i molcul.i moldyn.i mpole.i rgddyn.i rigid.i sizes.i stodyn.i units.i uprior.i usage.i +mdrest.o: atmtyp.i atoms.i bound.i group.i inform.i iounit.i mdstuf.i moldyn.i rgddyn.i sizes.i units.i +mdsave.o: atmtyp.i atoms.i bound.i boxes.i files.i group.i inform.i iounit.i mdstuf.i moldyn.i mpole.i output.i polar.i potent.i rgddyn.i sizes.i socket.i titles.i units.i +mdstat.o: atoms.i bath.i bound.i boxes.i cutoff.i inform.i inter.i iounit.i mdstuf.i molcul.i sizes.i units.i usage.i warp.i +mechanic.o: cutoff.i inform.i iounit.i potent.i vdwpot.i +merge.o: atmtyp.i atoms.i couple.i iounit.i refer.i sizes.i +minimize.o: atoms.i files.i inform.i iounit.i keys.i scales.i sizes.i usage.i +minimizemm.o: atoms.i inform.i iounit.i qmmm.i scales.i sizes.i usage.i +minirot.o: files.i inform.i iounit.i keys.i math.i omega.i scales.i sizes.i zcoord.i +minrigid.o: files.i group.i inform.i iounit.i keys.i math.i output.i rigid.i sizes.i +molecule.o: atmtyp.i atoms.i couple.i molcul.i sizes.i +molxyz.o: files.i iounit.i titles.i +moments.o: atmtyp.i atoms.i charge.i dipole.i moment.i mpole.i polar.i potent.i sizes.i solute.i units.i usage.i +monte.o: atoms.i files.i inform.i iounit.i omega.i output.i sizes.i units.i usage.i zcoord.i +mutate.o: atmtyp.i atoms.i charge.i inform.i iounit.i katoms.i keys.i mpole.i mutant.i polar.i potent.i sizes.i +nblist.o: atoms.i bound.i boxes.i cell.i charge.i cutoff.i iounit.i light.i mpole.i neigh.i potent.i sizes.i vdw.i +newton.o: atoms.i files.i inform.i iounit.i keys.i sizes.i usage.i +newtrot.o: files.i hescut.i inform.i iounit.i keys.i math.i omega.i sizes.i zcoord.i +nextarg.o: argue.i +nexttext.o: +nose.o: atmtyp.i atoms.i bath.i boxes.i freeze.i mdstuf.i moldyn.i sizes.i units.i usage.i virial.i +nspline.o: +nucleic.o: atoms.i couple.i files.i group.i inform.i iounit.i katoms.i kgeoms.i math.i molcul.i nucleo.i output.i potent.i resdue.i rigid.i sequen.i sizes.i titles.i usage.i +number.o: inform.i iounit.i +numeral.o: +numgrad.o: atoms.i sizes.i +ocvm.o: inform.i iounit.i keys.i linmin.i math.i minima.i output.i potent.i scales.i sizes.i +openend.o: +optimize.o: atoms.i files.i inform.i iounit.i keys.i scales.i sizes.i usage.i +optirot.o: files.i inform.i iounit.i keys.i math.i omega.i scales.i sizes.i zcoord.i +optrigid.o: files.i group.i inform.i iounit.i keys.i math.i output.i rigid.i sizes.i +optsave.o: atoms.i files.i iounit.i math.i omega.i output.i scales.i sizes.i socket.i usage.i zcoord.i +orbital.o: atmtyp.i atoms.i bond.i couple.i iounit.i keys.i piorbs.i potent.i sizes.i tors.i +orient.o: atmtyp.i atoms.i group.i math.i rigid.i sizes.i +orthog.o: +overlap.o: units.i +path.o: align.i atmtyp.i atoms.i files.i inform.i iounit.i linmin.i minima.i output.i paths.i sizes.i +pdbxyz.o: atmtyp.i atoms.i couple.i fields.i files.i inform.i iounit.i katoms.i pdb.i resdue.i sequen.i sizes.i +picalc.o: atmtyp.i atoms.i bond.i border.i couple.i inform.i iounit.i orbits.i piorbs.i pistuf.i qmmm.i sizes.i tors.i units.i +pmestuff.o: atoms.i boxes.i charge.i chunks.i mpole.i pme.i potent.i sizes.i +pmpb.o: iounit.i +polarize.o: atoms.i inform.i iounit.i molcul.i mpole.i polar.i polgrp.i polpot.i potent.i sizes.i units.i +poledit.o: atmtyp.i atoms.i couple.i dma.i files.i iounit.i keys.i kpolr.i mpole.i polar.i polgrp.i polpot.i potent.i sizes.i units.i +polymer.o: atoms.i bond.i bound.i boxes.i iounit.i keys.i sizes.i +potential.o: atmtyp.i atoms.i bond.i charge.i chgpot.i couple.i dipole.i files.i inform.i iounit.i katoms.i kchrge.i kdipol.i keys.i kmulti.i kpolr.i math.i minima.i moment.i mpole.i neigh.i output.i polar.i potent.i potfit.i refer.i sizes.i titles.i units.i +precise.o: +pressure.o: atmtyp.i atoms.i bath.i bound.i boxes.i group.i iounit.i math.i mdstuf.i molcul.i sizes.i units.i usage.i virial.i +prmedit.o: angpot.i bndpot.i iounit.i math.i params.i sizes.i urypot.i vdwpot.i +prmkey.o: angpot.i bndpot.i chgpot.i fields.i mplpot.i polpot.i potent.i rxnpot.i sizes.i torpot.i urypot.i vdwpot.i +promo.o: iounit.i +protein.o: atmtyp.i atoms.i couple.i files.i group.i inform.i iounit.i katoms.i kgeoms.i math.i molcul.i output.i phipsi.i potent.i resdue.i rigid.i sequen.i sizes.i titles.i usage.i +prtdyn.o: atoms.i boxes.i files.i group.i mdstuf.i moldyn.i rgddyn.i sizes.i titles.i +prterr.o: files.i output.i +prtint.o: atmtyp.i atoms.i files.i inform.i sizes.i titles.i zclose.i zcoord.i +prtmol2.o: atmtyp.i atoms.i bond.i couple.i files.i iounit.i sizes.i titles.i +prtpdb.o: files.i pdb.i sequen.i sizes.i titles.i +prtprm.o: angpot.i bndpot.i chgpot.i fields.i kanang.i kangs.i katoms.i kbonds.i kchrge.i kdipol.i khbond.i kiprop.i kitors.i kmulti.i kopbnd.i kopdst.i korbs.i kpitor.i kpolr.i kstbnd.i ksttor.i ktorsn.i ktrtor.i kurybr.i kvdwpr.i kvdws.i mplpot.i polpot.i sizes.i urypot.i vdwpot.i +prtseq.o: files.i sequen.i sizes.i +prtxyz.o: atmtyp.i atoms.i couple.i files.i inform.i qmmm.i sizes.i titles.i +pss.o: atoms.i files.i hescut.i inform.i iounit.i math.i omega.i refer.i sizes.i tree.i warp.i zcoord.i +pssrigid.o: atoms.i files.i group.i inform.i iounit.i math.i minima.i molcul.i refer.i rigid.i sizes.i warp.i +pssrot.o: atoms.i files.i inform.i iounit.i math.i minima.i omega.i refer.i sizes.i warp.i zcoord.i +qmmm_eg.o: atoms.i energi.i inform.i iounit.i qmmm.i sizes.i units.i +qmmmsetup.o: atoms.i bath.i charge.i files.i inform.i iounit.i keys.i mdstuf.i qmmm.i sizes.i +qmmm_todo.o: iounit.i potent.i qmmm.i sizes.i +quatfit.o: align.i sizes.i +radial.o: argue.i atmtyp.i atoms.i bound.i boxes.i cutoff.i files.i inform.i iounit.i math.i molcul.i potent.i sizes.i +random.o: inform.i iounit.i keys.i math.i sizes.i +rattle.o: atmtyp.i atoms.i freeze.i group.i inform.i iounit.i moldyn.i sizes.i units.i usage.i virial.i +readdyn.o: atoms.i boxes.i files.i group.i iounit.i mdstuf.i moldyn.i rgddyn.i sizes.i +readgau.o: ascii.i iounit.i qmstuf.i sizes.i units.i +readint.o: atmtyp.i atoms.i files.i inform.i iounit.i sizes.i titles.i zclose.i zcoord.i +readmol2.o: atmtyp.i atoms.i couple.i files.i iounit.i sizes.i titles.i +readmol.o: atmtyp.i atoms.i couple.i files.i iounit.i ptable.i sizes.i titles.i +readpdb.o: files.i inform.i iounit.i pdb.i resdue.i sequen.i sizes.i titles.i +readprm.o: fields.i iounit.i kanang.i kangs.i katoms.i kbonds.i kchrge.i kdipol.i khbond.i kiprop.i kitors.i kmulti.i kopbnd.i kopdst.i korbs.i kpitor.i kpolr.i kstbnd.i ksttor.i ktorsn.i ktrtor.i kurybr.i kvdwpr.i kvdws.i merck.i params.i sizes.i +readseq.o: files.i iounit.i resdue.i sequen.i sizes.i +readxyz.o: atmtyp.i atoms.i couple.i files.i inform.i iounit.i qmmm.i sizes.i titles.i +replica.o: bound.i boxes.i cell.i inform.i iounit.i sizes.i +respa.o: atmtyp.i atoms.i cutoff.i freeze.i moldyn.i potent.i sizes.i units.i usage.i virial.i +rgdstep.o: atmtyp.i atoms.i bound.i group.i iounit.i rgddyn.i sizes.i units.i virial.i +rings.o: angle.i atoms.i bitor.i bond.i couple.i inform.i iounit.i ring.i sizes.i tors.i +rmsfit.o: align.i sizes.i +rotlist.o: atoms.i couple.i iounit.i molcul.i rotate.i sizes.i zclose.i +rotpole.o: atoms.i mpole.i sizes.i +runqm.o: argue.i atmtyp.i atoms.i charge.i deriv.i energi.i files.i group.i inform.i iounit.i potent.i qmmm.i sizes.i units.i usage.i +saddle.o: atoms.i inform.i iounit.i keys.i linmin.i minima.i sizes.i syntrn.i titles.i zcoord.i +scan.o: atoms.i files.i inform.i iounit.i math.i minima.i omega.i output.i sizes.i zcoord.i +sdstep.o: atmtyp.i atoms.i bath.i couple.i freeze.i kvdws.i math.i mdstuf.i moldyn.i sizes.i stodyn.i units.i usage.i virial.i +search.o: linmin.i math.i sizes.i +server.o: +shakeup.o: angle.i atmlst.i atmtyp.i atoms.i bond.i bound.i couple.i freeze.i keys.i math.i molcul.i ring.i sizes.i usage.i +sigmoid.o: +sktstuff.o: atmtyp.i atoms.i charge.i couple.i deriv.i fields.i files.i inform.i iounit.i keys.i moldyn.i mpole.i polar.i potent.i sizes.i socket.i +sniffer.o: atoms.i files.i inform.i iounit.i linmin.i math.i minima.i output.i scales.i sizes.i usage.i +sort.o: +spacefill.o: atmtyp.i atoms.i files.i inform.i iounit.i kvdws.i math.i sizes.i usage.i +spectrum.o: files.i iounit.i math.i units.i +square.o: inform.i iounit.i keys.i minima.i sizes.i +suffix.o: ascii.i +superpose.o: align.i atmtyp.i atoms.i bound.i files.i inform.i iounit.i sizes.i titles.i +surface.o: atoms.i inform.i iounit.i math.i sizes.i usage.i +surfatom.o: atoms.i iounit.i math.i sizes.i +switch.o: cutoff.i npolar.i shunt.i sizes.i +sybylxyz.o: files.i iounit.i titles.i +temper.o: atmtyp.i atoms.i bath.i group.i mdstuf.i molcul.i moldyn.i rgddyn.i sizes.i units.i usage.i +testgrad.o: atoms.i deriv.i energi.i inform.i inter.i iounit.i sizes.i solute.i usage.i +testhess.o: atoms.i files.i hescut.i inform.i iounit.i sizes.i usage.i +testpair.o: atoms.i cutoff.i deriv.i energi.i inform.i iounit.i light.i neigh.i potent.i sizes.i vdwpot.i +testpol.o: atoms.i bound.i cutoff.i inform.i iounit.i polar.i polpot.i potent.i rigid.i sizes.i units.i +testrot.o: domega.i energi.i inform.i iounit.i math.i omega.i sizes.i zcoord.i +timer.o: atoms.i cutoff.i hescut.i inform.i iounit.i sizes.i +timerot.o: cutoff.i iounit.i omega.i sizes.i +tkr2qm.o: argue.i atmtyp.i atoms.i bound.i charge.i couple.i cutoff.i energi.i files.i group.i inform.i iounit.i moldyn.i mpole.i polar.i potent.i qmmm.i scales.i sizes.i units.i usage.i +tkr2qm_s.o: argue.i atmtyp.i atoms.i couple.i files.i inform.i iounit.i qmmm.i sizes.i +tncg.o: atoms.i hescut.i inform.i iounit.i keys.i linmin.i math.i minima.i output.i piorbs.i potent.i sizes.i +torphase.o: +torque.o: atoms.i deriv.i mpole.i sizes.i +torsfit.o: atmtyp.i atoms.i files.i inform.i iounit.i keys.i kgeoms.i ktorsn.i math.i output.i potent.i qmstuf.i scales.i sizes.i tors.i usage.i +torsions.o: angle.i bond.i couple.i iounit.i qmmm.i sizes.i tors.i +trimtext.o: +unitcell.o: bound.i boxes.i iounit.i keys.i sizes.i +update_qmmm.o: atoms.i charge.i inform.i iounit.i mpole.i polar.i potent.i qmmm.i sizes.i usage.i +valence.o: angle.i angpot.i atmtyp.i atoms.i bndpot.i bond.i couple.i files.i hescut.i inform.i iounit.i kangs.i kbonds.i keys.i kopbnd.i kstbnd.i ktorsn.i kurybr.i kvdws.i linmin.i math.i minima.i opbend.i output.i potent.i qmstuf.i scales.i sizes.i strbnd.i torpot.i tors.i units.i urey.i urypot.i usage.i valfit.i vdwpot.i +verlet.o: atmtyp.i atoms.i freeze.i moldyn.i sizes.i units.i usage.i +version.o: iounit.i output.i +vibbig.o: atmtyp.i atoms.i bound.i couple.i cutoff.i files.i hescut.i hessn.i inform.i iounit.i keys.i mpole.i potent.i rigid.i sizes.i units.i usage.i vdw.i vdwpot.i vibs.i +vibrate.o: atmtyp.i atoms.i files.i hescut.i iounit.i math.i sizes.i units.i usage.i +vibrot.o: iounit.i omega.i sizes.i +volume.o: atoms.i iounit.i math.i sizes.i +xtalfit.o: atmtyp.i atoms.i bound.i boxes.i charge.i couple.i dipole.i files.i fracs.i iounit.i kvdws.i math.i molcul.i potent.i sizes.i vdw.i xtals.i +xtalmin.o: atoms.i boxes.i files.i inform.i iounit.i keys.i math.i scales.i sizes.i +xyzatm.o: atoms.i inform.i iounit.i math.i sizes.i +xyzedit.o: atmtyp.i atoms.i bond.i bound.i boxes.i charge.i couple.i cutoff.i fields.i files.i iounit.i math.i molcul.i potent.i qmmm.i refer.i sizes.i titles.i units.i usage.i +xyzint.o: files.i iounit.i titles.i +xyzpdb.o: atmtyp.i atoms.i couple.i fields.i files.i inform.i molcul.i pdb.i resdue.i sequen.i sizes.i +xyzsybyl.o: files.i iounit.i sizes.i titles.i +zatom.o: angle.i atmtyp.i atoms.i bond.i fields.i iounit.i kangs.i katoms.i kbonds.i sizes.i zclose.i zcoord.i diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/makeint.f 6.2.06/source/makeint.f --- 6.2.06/source_orig/makeint.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/makeint.f 2013-10-23 11:36:27.055130195 +0200 @@ -161,7 +161,7 @@ 80 format (a120) next = 1 call gettext (record,answer,next) - call upcase (answer) + call tk_upcase (answer) if (answer.ne.'B' .and. answer.ne.'D') answer = default else if (mode .eq. 0) then if (more) then diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/make.log 6.2.06/source/make.log --- 6.2.06/source_orig/make.log 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/make.log 2013-10-28 17:39:26.128052607 +0100 @@ -0,0 +1,58 @@ +/usr/bin/gfortran -o bar.x bar.o libtinker.a ; strip bar.x +/usr/bin/gfortran -o correlate.x correlate.o libtinker.a ; strip correlate.x +/usr/bin/gfortran -o crystal.x crystal.o libtinker.a ; strip crystal.x +/usr/bin/gfortran -o diffuse.x diffuse.o libtinker.a ; strip diffuse.x +/usr/bin/gfortran -o distgeom.x distgeom.o libtinker.a ; strip distgeom.x +/usr/bin/gfortran -o document.x document.o libtinker.a ; strip document.x +/usr/bin/gfortran -o dynamic.x dynamic.o libtinker.a ; strip dynamic.x +/usr/bin/gfortran -o gda.x gda.o libtinker.a ; strip gda.x +/usr/bin/gfortran -o intedit.x intedit.o libtinker.a ; strip intedit.x +/usr/bin/gfortran -o intxyz.x intxyz.o libtinker.a ; strip intxyz.x +/usr/bin/gfortran -o minimize.x minimize.o libtinker.a ; strip minimize.x +/usr/bin/gfortran -o minirot.x minirot.o libtinker.a ; strip minirot.x +/usr/bin/gfortran -o minrigid.x minrigid.o libtinker.a ; strip minrigid.x +/usr/bin/gfortran -o molxyz.x molxyz.o libtinker.a ; strip molxyz.x +/usr/bin/gfortran -o monte.x monte.o libtinker.a ; strip monte.x +/usr/bin/gfortran -o newton.x newton.o libtinker.a ; strip newton.x +/usr/bin/gfortran -o newtrot.x newtrot.o libtinker.a ; strip newtrot.x +/usr/bin/gfortran -o nucleic.x nucleic.o libtinker.a ; strip nucleic.x +/usr/bin/gfortran -o optimize.x optimize.o libtinker.a ; strip optimize.x +/usr/bin/gfortran -o optirot.x optirot.o libtinker.a ; strip optirot.x +/usr/bin/gfortran -o optrigid.x optrigid.o libtinker.a ; strip optrigid.x +/usr/bin/gfortran -o path.x path.o libtinker.a ; strip path.x +/usr/bin/gfortran -o pdbxyz.x pdbxyz.o libtinker.a ; strip pdbxyz.x +/usr/bin/gfortran -o polarize.x polarize.o libtinker.a ; strip polarize.x +/usr/bin/gfortran -o poledit.x poledit.o libtinker.a ; strip poledit.x +/usr/bin/gfortran -o potential.x potential.o libtinker.a ; strip potential.x +/usr/bin/gfortran -o prmedit.x prmedit.o libtinker.a ; strip prmedit.x +/usr/bin/gfortran -o protein.x protein.o libtinker.a ; strip protein.x +/usr/bin/gfortran -o pss.x pss.o libtinker.a ; strip pss.x +/usr/bin/gfortran -o pssrigid.x pssrigid.o libtinker.a ; strip pssrigid.x +/usr/bin/gfortran -o pssrot.x pssrot.o libtinker.a ; strip pssrot.x +/usr/bin/gfortran -o radial.x radial.o libtinker.a ; strip radial.x +/usr/bin/gfortran -o saddle.x saddle.o libtinker.a ; strip saddle.x +/usr/bin/gfortran -o scan.x scan.o libtinker.a ; strip scan.x +/usr/bin/gfortran -o sniffer.x sniffer.o libtinker.a ; strip sniffer.x +/usr/bin/gfortran -o spacefill.x spacefill.o libtinker.a ; strip spacefill.x +/usr/bin/gfortran -o spectrum.x spectrum.o libtinker.a ; strip spectrum.x +/usr/bin/gfortran -o superpose.x superpose.o libtinker.a ; strip superpose.x +/usr/bin/gfortran -o sybylxyz.x sybylxyz.o libtinker.a ; strip sybylxyz.x +/usr/bin/gfortran -o testgrad.x testgrad.o libtinker.a ; strip testgrad.x +/usr/bin/gfortran -o testhess.x testhess.o libtinker.a ; strip testhess.x +/usr/bin/gfortran -o testpair.x testpair.o libtinker.a ; strip testpair.x +/usr/bin/gfortran -o testpol.x testpol.o libtinker.a ; strip testpol.x +/usr/bin/gfortran -o testrot.x testrot.o libtinker.a ; strip testrot.x +/usr/bin/gfortran -o timer.x timer.o libtinker.a ; strip timer.x +/usr/bin/gfortran -o timerot.x timerot.o libtinker.a ; strip timerot.x +/usr/bin/gfortran -o torsfit.x torsfit.o libtinker.a ; strip torsfit.x +/usr/bin/gfortran -o valence.x valence.o libtinker.a ; strip valence.x +/usr/bin/gfortran -o vibbig.x vibbig.o libtinker.a ; strip vibbig.x +/usr/bin/gfortran -o vibrate.x vibrate.o libtinker.a ; strip vibrate.x +/usr/bin/gfortran -o vibrot.x vibrot.o libtinker.a ; strip vibrot.x +/usr/bin/gfortran -o xtalfit.x xtalfit.o libtinker.a ; strip xtalfit.x +/usr/bin/gfortran -o xtalmin.x xtalmin.o libtinker.a ; strip xtalmin.x +/usr/bin/gfortran -o xyzedit.x xyzedit.o libtinker.a ; strip xyzedit.x +/usr/bin/gfortran -o xyzint.x xyzint.o libtinker.a ; strip xyzint.x +/usr/bin/gfortran -o xyzpdb.x xyzpdb.o libtinker.a ; strip xyzpdb.x +/usr/bin/gfortran -o xyzsybyl.x xyzsybyl.o libtinker.a ; strip xyzsybyl.x +/usr/bin/gfortran -o tkr2qm_s.x tkr2qm_s.o libtinker.a ; strip tkr2qm_s.x diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/mdinit.f 6.2.06/source/mdinit.f --- 6.2.06/source_orig/mdinit.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/mdinit.f 2013-10-23 11:36:27.055130195 +0200 @@ -97,11 +97,11 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:11) .eq. 'INTEGRATOR ') then call getword (record,integrate,next) - call upcase (integrate) + call tk_upcase (integrate) else if (keyword(1:14) .eq. 'BEEMAN-MIXING ') then read (string,*,err=10,end=10) bmnmix else if (keyword(1:16) .eq. 'DEGREES-FREEDOM ') then @@ -121,17 +121,17 @@ else if (keyword(1:14) .eq. 'POLAR-PREDICT ') then use_pred = .true. call getword (record,polpred,next) - call upcase (polpred) + call tk_upcase (polpred) else if (keyword(1:11) .eq. 'THERMOSTAT ') then call getword (record,thermostat,next) - call upcase (thermostat) + call tk_upcase (thermostat) else if (keyword(1:16) .eq. 'TAU-TEMPERATURE ') then read (string,*,err=10,end=10) tautemp else if (keyword(1:10) .eq. 'COLLISION ') then read (string,*,err=10,end=10) collide else if (keyword(1:9) .eq. 'BAROSTAT ') then call getword (record,barostat,next) - call upcase (barostat) + call tk_upcase (barostat) else if (keyword(1:15) .eq. 'ANISO-PRESSURE ') then anisotrop = .true. else if (keyword(1:13) .eq. 'TAU-PRESSURE ') then @@ -144,7 +144,7 @@ read (string,*,err=10,end=10) volmove else if (keyword(1:13) .eq. 'VOLUME-SCALE ') then call getword (record,volscale,next) - call upcase (volscale) + call tk_upcase (volscale) else if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=10,end=10) iprint end if diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/minimize.f 6.2.06/source/minimize.f --- 6.2.06/source_orig/minimize.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/minimize.f 2013-10-23 11:36:27.055130195 +0200 @@ -60,7 +60,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=10,end=10) iprint diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/minimizemm.f 6.2.06/source/minimizemm.f --- 6.2.06/source_orig/minimizemm.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/minimizemm.f 2013-11-30 10:24:44.206831059 +0100 @@ -0,0 +1,217 @@ + subroutine minimizeMM + implicit none + include 'sizes.i' + include 'atoms.i' + include 'inform.i' + include 'iounit.i' + include 'qmmm.i' + include 'scales.i' + include 'usage.i' + logical reject,doespf_save + integer i,j,nvar + real*8 grdmin,energy,minimiz1,gnorm,grms + real*8, allocatable :: xx(:) + real*8, allocatable :: derivs(:,:) + external minimiz1 + external optsave +c +c If requested, perform the MM minimization. +c At least 1 MM atom must be active (see the ACTIVE keyword) +c + reject = .true. + i = 1 + do while (reject .and. i .le. n) + if (atinqm(i).eq. 0 . and. use(i)) reject = .false. + i = i + 1 + end do + if (reject) then + write(iout,*) 'minimizeMM -- All MM atoms are frozen.' + goto 999 + end if +c +c Initialization +c + doespf_save = doespf + doespf = .false. + grdmin = 0.01d0 + iwrite = 0 + write (iout,10) grdmin + 10 format(/,' Convergence criterion = ',f7.4, + & ' kcal/mol/angstrom.') + if (debug) then + write (iout,11) + 11 format (/,' Analysis before MM microiterations') + call analysis(energy) + end if +c +c set scaling parameter for function and derivative values; +c use square root of median eigenvalue of typical Hessian +c + set_scale = .true. + nvar = 0 + do i = 1, n + if (use(i)) then + do j = 1, 3 + nvar = nvar + 1 + scale(nvar) = 12.0d0 + end do + end if + end do +c +c perform dynamic allocation of some local arrays +c + allocate (xx(nvar)) + allocate (derivs(3,n)) +c +c scale the coordinates of each active atom +c + nvar = 0 + do i = 1, n + if (use(i)) then + nvar = nvar + 1 + xx(nvar) = x(i) * scale(nvar) + nvar = nvar + 1 + xx(nvar) = y(i) * scale(nvar) + nvar = nvar + 1 + xx(nvar) = z(i) * scale(nvar) + end if + end do +c +c make the call to the optimization routine +c + call lbfgs (nvar,xx,energy,grdmin,minimiz1,optsave) +c +c unscale the final coordinates for active atoms +c + nvar = 0 + do i = 1, n + if (use(i)) then + nvar = nvar + 1 + x(i) = xx(nvar) / scale(nvar) + nvar = nvar + 1 + y(i) = xx(nvar) / scale(nvar) + nvar = nvar + 1 + z(i) = xx(nvar) / scale(nvar) + end if + end do +c +c compute the final function and RMS gradient values +c + call gradient (energy,derivs) + gnorm = 0.0d0 + do i = 1, n + if (use(i)) then + do j = 1, 3 + gnorm = gnorm + derivs(j,i)**2 + end do + end if + end do + gnorm = sqrt(gnorm) + grms = gnorm / sqrt(dble(nvar/3)) +c +c perform deallocation of some local arrays +c + deallocate (xx) + deallocate (derivs) +c +c write out the final function and gradient values +c + if (grms .gt. 1.0d-6) then + write (iout,98) energy,grms,gnorm + 98 format (/,' Final Function Value :',2x,f18.6, + & /,' Final RMS Gradient :',4x,f18.6, + & /,' Final Gradient Norm :',3x,f18.6) + else + write (iout,99) energy,grms,gnorm + 99 format (/,' Final Function Value :',2x,f18.6, + & /,' Final RMS Gradient :',4x,d18.6, + & /,' Final Gradient Norm :',3x,d18.6) + end if +c +c The end +c + doespf = doespf_save + 999 return + end +c +c +c ############################################################### +c ## ## +c ## function minimiz1 -- energy and gradient for minimize ## +c ## ## +c ############################################################### +c +c +c "minimiz1" is a service routine that computes the energy and +c gradient for a low storage BFGS optimization in Cartesian +c coordinate space +c +c + function minimiz1 (xx,g) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'scales.i' + include 'usage.i' + integer i,nvar + real*8 minimiz1,e + real*8 energy,eps + real*8 xx(*) + real*8 g(*) + real*8, allocatable :: derivs(:,:) + logical analytic + external energy +c +c +c use either analytical or numerical gradients +c + analytic = .true. + eps = 0.00001d0 +c +c translate optimization parameters to atomic coordinates +c + nvar = 0 + do i = 1, n + if (use(i)) then + nvar = nvar + 1 + x(i) = xx(nvar) / scale(nvar) + nvar = nvar + 1 + y(i) = xx(nvar) / scale(nvar) + nvar = nvar + 1 + z(i) = xx(nvar) / scale(nvar) + end if + end do +c +c perform dynamic allocation of some local arrays +c + allocate (derivs(3,n)) +c +c compute and store the energy and gradient +c + if (analytic) then + call gradient (e,derivs) + else + e = energy () + call numgrad (energy,derivs,eps) + end if + minimiz1 = e +c +c store Cartesian gradient as optimization gradient +c + nvar = 0 + do i = 1, n + if (use(i)) then + nvar = nvar + 1 + g(nvar) = derivs(1,i) / scale(nvar) + nvar = nvar + 1 + g(nvar) = derivs(2,i) / scale(nvar) + nvar = nvar + 1 + g(nvar) = derivs(3,i) / scale(nvar) + end if + end do +c +c perform deallocation of some local arrays +c + deallocate (derivs) + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/minirot.f 6.2.06/source/minirot.f --- 6.2.06/source_orig/minirot.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/minirot.f 2013-10-23 11:36:27.055130195 +0200 @@ -55,7 +55,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=10,end=10) iprint diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/minrigid.f 6.2.06/source/minrigid.f --- 6.2.06/source_orig/minrigid.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/minrigid.f 2013-10-23 11:36:27.055130195 +0200 @@ -58,7 +58,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=10,end=10) iprint diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/molecule.f 6.2.06/source/molecule.f --- 6.2.06/source_orig/molecule.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/molecule.f 2013-10-23 11:36:27.055130195 +0200 @@ -82,7 +82,7 @@ do i = 1, n list(i) = molcule(i) end do - call sort3 (n,list,kmol) + call tk_sort3 (n,list,kmol) c c find the first and last atom in each molecule c @@ -106,7 +106,7 @@ c do i = 1, nmol k = imol(2,i) - imol(1,i) + 1 - call sort (k,kmol(imol(1,i))) + call tk_sort (k,kmol(imol(1,i))) end do c c if all atomic masses are zero, set them all to unity diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/monte.f 6.2.06/source/monte.f --- 6.2.06/source_orig/monte.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/monte.f 2013-10-23 11:36:27.059130195 +0200 @@ -114,7 +114,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'T') torsmove = .true. c c perform dynamic allocation of some local arrays diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/mutate.f 6.2.06/source/mutate.f --- 6.2.06/source_orig/mutate.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/mutate.f 2013-10-23 11:36:27.059130195 +0200 @@ -58,7 +58,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:7) .eq. 'LAMBDA ') then string = record(next:120) read (string,*,err=20) lambda diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/newton.f 6.2.06/source/newton.f --- 6.2.06/source_orig/newton.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/newton.f 2013-10-23 11:36:27.059130195 +0200 @@ -55,7 +55,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=10,end=10) iprint @@ -79,7 +79,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'A') mode = 'AUTO' if (answer .eq. 'N') mode = 'NEWTON' if (answer .eq. 'T') mode = 'TNCG' @@ -99,7 +99,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'A') method = 'AUTO' if (answer .eq. 'N') method = 'NONE' if (answer .eq. 'D') method = 'DIAG' diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/newtrot.f 6.2.06/source/newtrot.f --- 6.2.06/source_orig/newtrot.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/newtrot.f 2013-10-23 11:36:27.059130195 +0200 @@ -57,7 +57,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=10,end=10) iprint @@ -81,7 +81,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'A') mode = 'AUTO' if (answer .eq. 'N') mode = 'NEWTON' if (answer .eq. 'T') mode = 'TNCG' @@ -101,7 +101,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'A') method = 'AUTO' if (answer .eq. 'N') method = 'NONE' if (answer .eq. 'D') method = 'DIAG' diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/nucleic.f 6.2.06/source/nucleic.f --- 6.2.06/source_orig/nucleic.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/nucleic.f 2013-10-23 11:36:27.059130195 +0200 @@ -159,7 +159,7 @@ & ' [B] : ',$) read (input,20) record 20 format (a120) - call upcase (record) + call tk_upcase (record) next = 1 call getword (record,answer,next) hlxform = 'B' @@ -197,7 +197,7 @@ 40 format (/,' Enter Residue',i4,' : ',$) read (input,50) record 50 format (a120) - call upcase (record) + call tk_upcase (record) next = 1 call gettext (record,name,next) length = trimtext (name) @@ -256,7 +256,7 @@ 90 format (a120) next = 1 call gettext (record,answer,next) - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') dblhlx = .true. else if (nchain .eq. 2) then write (iout,100) @@ -266,7 +266,7 @@ 110 format (a120) next = 1 call gettext (record,answer,next) - call upcase (answer) + call tk_upcase (answer) if (answer .ne. 'N') dblhlx = .true. end if c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/ocvm.f 6.2.06/source/ocvm.f --- 6.2.06/source_orig/ocvm.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/ocvm.f 2013-10-23 11:36:27.059130195 +0200 @@ -143,7 +143,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:7) .eq. 'FCTMIN ') then read (string,*,err=20,end=20) fctmin diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/optimize.f 6.2.06/source/optimize.f --- 6.2.06/source_orig/optimize.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/optimize.f 2013-10-23 11:36:27.059130195 +0200 @@ -60,7 +60,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=10,end=10) iprint diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/optirot.f 6.2.06/source/optirot.f --- 6.2.06/source_orig/optirot.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/optirot.f 2013-10-23 11:36:27.059130195 +0200 @@ -64,7 +64,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=20,end=20) iprint diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/optrigid.f 6.2.06/source/optrigid.f --- 6.2.06/source_orig/optrigid.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/optrigid.f 2013-10-23 11:36:27.059130195 +0200 @@ -67,7 +67,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=20,end=20) iprint diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/orbital.f 6.2.06/source/orbital.f --- 6.2.06/source_orig/orbital.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/orbital.f 2013-10-23 11:36:27.059130195 +0200 @@ -56,7 +56,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:9) .eq. 'PISYSTEM ') then string = record(next:120) read (string,*,err=10,end=10) (list(k),k=nlist+1,n) @@ -152,7 +152,7 @@ c c pack atoms of each pisystem into a contiguous indexed list c - call sort3 (n,list,kconj) + call tk_sort3 (n,list,kconj) k = n - norbit do i = 1, norbit k = k + 1 @@ -182,7 +182,7 @@ c do i = 1, nconj k = iconj(2,i) - iconj(1,i) + 1 - call sort (k,kconj(iconj(1,i))) + call tk_sort (k,kconj(iconj(1,i))) end do do i = 1, norbit iorbit(i) = kconj(i) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/pdbxyz.f 6.2.06/source/pdbxyz.f --- 6.2.06/source_orig/pdbxyz.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/pdbxyz.f 2013-10-23 11:36:27.059130195 +0200 @@ -138,7 +138,7 @@ it = type(i) if (it .eq. 0) then letter = name(i)(1:1) - call upcase (letter) + call tk_upcase (letter) if (letter .eq. 'H') then size(i) = 1 else if (letter .eq. 'C') then @@ -201,7 +201,7 @@ c sort the attached atom lists into ascending order c do i = 1, n - call sort (n12(i),i12(1,i)) + call tk_sort (n12(i),i12(1,i)) end do c c check for atom pairs with identical coordinates diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/picalc.f 6.2.06/source/picalc.f --- 6.2.06/source_orig/picalc.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/picalc.f 2013-10-21 18:20:56.441885306 +0200 @@ -31,6 +31,9 @@ integer ncalls data ncalls / 0 / save ncalls +cqmmm + include 'qmmm.i' + integer iqmmm,jqmmm,ijqmmm c c c only needs to be done if pisystem is present @@ -58,10 +61,18 @@ kk = iconj(2,i) - iconj(1,i) + 1 do ii = 1, norbit-1 iorb = iorbit(ii) +cqmmm + iqmmm = qmmm(iorb) do jj = ii+1, norbit jorb = iorbit(jj) +cqmmm + jqmmm = qmmm(jorb) do k = 1, n12(iorb) if (i12(k,iorb) .eq. jorb) then +cqmmm + ijqmmm = iqmmm + jqmmm + if (ijqmmm .ne. 2 .or. ijqmmm .ne. 3 .or. + & ijqmmm .ne. 6) goto 10 nbpi = nbpi + 1 do m = 1, nbond if (iorb.eq.ibnd(1,m) .and. diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/poledit.f 6.2.06/source/poledit.f --- 6.2.06/source_orig/poledit.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/poledit.f 2013-10-23 11:36:27.059130195 +0200 @@ -263,7 +263,7 @@ do i = 1, n atomic(i) = 0 atmnam = name(i) - call upcase (atmnam) + call tk_upcase (atmnam) if (atmnam(1:2) .eq. 'SI') then atomic(i) = 14 else if (atmnam(1:2) .eq. 'CL') then @@ -554,7 +554,7 @@ end do end do do i = 1, n - call sort (n12(i),i12(1,i)) + call tk_sort (n12(i),i12(1,i)) end do c c perform deallocation of some local arrays @@ -2133,7 +2133,7 @@ 20 format (a120) next = 1 call gettext (record,answer,next) - call upcase (answer) + call tk_upcase (answer) c c perform averaging for equivalent monovalent atoms c @@ -2196,7 +2196,7 @@ 50 format (a120) next = 1 call gettext (record,answer,next) - call upcase (answer) + call tk_upcase (answer) c c remove multipole components that are zero by symmetry c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/polymer.f 6.2.06/source/polymer.f --- 6.2.06/source_orig/polymer.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/polymer.f 2013-10-23 11:36:27.059130195 +0200 @@ -50,7 +50,7 @@ next = 1 record = keyline(j) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:15) .eq. 'POLYMER-CUTOFF ') then string = record(next:120) read (string,*,err=10,end=10) polycut diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/potential.f 6.2.06/source/potential.f --- 6.2.06/source_orig/potential.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/potential.f 2013-10-23 11:36:27.059130195 +0200 @@ -273,7 +273,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:16) .eq. 'POTENTIAL-ATOMS ') then read (string,*,err=180,end=180) (glist(k),k=nglist+1,nmax) @@ -441,7 +441,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') dofull = .true. end if c @@ -802,7 +802,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:17) .eq. 'POTENTIAL-SHELLS ') then read (string,*,err=10,end=10) nshell @@ -870,7 +870,7 @@ & ' Increase MAXDOT') call fatal end if - call sphere (ndot,dot) + call tk_sphere (ndot,dot) do j = 1, ndot xj = xi + rad(i)*dot(1,j) yj = yi + rad(i)*dot(2,j) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/prmedit.f 6.2.06/source/prmedit.f --- 6.2.06/source_orig/prmedit.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/prmedit.f 2013-10-23 11:36:27.059130195 +0200 @@ -192,7 +192,7 @@ length = trimtext (record) next = 1 call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:5) .eq. 'ATOM ') then ia = -1 @@ -792,7 +792,7 @@ kg = j end if end do - call sort (kg,ig) + call tk_sort (kg,ig) write (iprm,1130) ia,pol,thl,(ig(j),j=1,kg) 1130 format ('polarize',2x,i5,5x,2f11.4,2x,20i5) else if (keyword(1:7) .eq. 'PIATOM ') then @@ -939,7 +939,7 @@ record = prmline(i) next = 1 call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:5) .eq. 'ATOM ') then it = 0 ic = 0 @@ -973,7 +973,7 @@ length = trimtext (record) next = 1 call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:5) .eq. 'ATOM ') then ia = 0 ib = 0 @@ -1424,7 +1424,7 @@ ig(j) = itype(ig(j)) end if end do - call sort (kg,ig) + call tk_sort (kg,ig) write (iprm,420) ia,pol,thl,(ig(j),j=1,kg) 420 format ('polarize',2x,i5,5x,2f11.4,2x,20i5) else if (keyword(1:7) .eq. 'PIATOM ') then @@ -1590,7 +1590,7 @@ record = prmline(i) next = 1 call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:10) .eq. 'MULTIPOLE ') then ia = 0 ib = 0 @@ -1617,7 +1617,7 @@ c c sort the parameters based on the atom type numbers c - call sort7 (n,list,key) + call tk_sort7 (n,list,key) c c format and output the sorted multipole parameters c @@ -1707,7 +1707,7 @@ record = prmline(i) next = 1 call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:8) .eq. 'BIOTYPE ') then n = n + 1 call getnumb (record,ia,next) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/prmkey.f 6.2.06/source/prmkey.f --- 6.2.06/source_orig/prmkey.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/prmkey.f 2013-10-23 11:36:27.063130195 +0200 @@ -42,7 +42,7 @@ c record = text next = 1 - call upcase (record) + call tk_upcase (record) call gettext (record,keyword,next) string = record(next:120) c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/promo.f 6.2.06/source/promo.f --- 6.2.06/source_orig/promo.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/promo.f 2013-11-19 14:43:18.193647940 +0100 @@ -38,5 +38,14 @@ & /,2x,'###',70x,'###', & /,3x,74('#'), & /,5x,70('#'),/) +c +c QM/MM promo +c + write (iout,20) + 20 format (/,' ##',19x,'QM/MM modifications: November 2013',21x, + & '##',/,' ##',19x,'Nicolas Ferre, Aix-Marseille Universite', + & 16x,'##',/,' ##',19x,'Federico Melaccio, Universita di Siena', + & 17x,'##',/) + return end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/protein.f 6.2.06/source/protein.f --- 6.2.06/source_orig/protein.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/protein.f 2013-10-23 11:36:27.063130195 +0200 @@ -210,7 +210,7 @@ 20 format (/,' Enter Residue',i4,' : ',$) read (input,30) record 30 format (a120) - call upcase (record) + call tk_upcase (record) next = 1 call gettext (record,name,next) length = trimtext (name) @@ -370,7 +370,7 @@ 20 format (a120) next = 1 call gettext (record,answer,next) - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') cyclic = .true. c c perform dynamic allocation of some local arrays diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/prtxyz.f 6.2.06/source/prtxyz.f --- 6.2.06/source_orig/prtxyz.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/prtxyz.f 2013-11-19 14:43:18.193647940 +0100 @@ -34,6 +34,9 @@ character*2 digc character*25 fstr character*120 xyzfile +cqmmm + include 'qmmm.i' + integer iqmmm c c c open the output unit if not already done @@ -87,8 +90,13 @@ fstr = '('//atmc//',2x,a3,3f'//crdc// & '.'//digc//',i6,8'//atmc//')' do i = 1, n +cqmmm + iqmmm = qmmm(i) + if (iqmmm .eq. 1) n12(i) = 2 write (ixyz,fstr) i,name(i),x(i),y(i),z(i),type(i), & (i12(k,i),k=1,n12(i)) +cqmmm + if (iqmmm .eq. 1) n12(i) = 0 end do c c close the output unit if opened by this routine diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/pss.f 6.2.06/source/pss.f --- 6.2.06/source_orig/pss.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/pss.f 2013-10-23 11:36:27.063130195 +0200 @@ -89,7 +89,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'N') use_forward = .false. c c get the functional form for the deformation schedule @@ -105,7 +105,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Q') formtyp = answer if (answer .eq. 'S') formtyp = answer c @@ -123,7 +123,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'C') use_cart = .true. if (answer .eq. 'T') use_tors = .true. c @@ -191,7 +191,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') check = .true. end if c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/pssrigid.f 6.2.06/source/pssrigid.f --- 6.2.06/source_orig/pssrigid.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/pssrigid.f 2013-10-23 11:36:27.063130195 +0200 @@ -106,7 +106,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') use_local = .true. c c get the number of eigenvectors to use for the local search diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/pssrot.f 6.2.06/source/pssrot.f --- 6.2.06/source_orig/pssrot.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/pssrot.f 2013-10-23 11:36:27.063130195 +0200 @@ -105,7 +105,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') use_local = .true. c c get the number of eigenvectors to use for the local search diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/qmmm_eg.f 6.2.06/source/qmmm_eg.f --- 6.2.06/source_orig/qmmm_eg.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/qmmm_eg.f 2013-11-08 11:38:59.422657584 +0100 @@ -0,0 +1,65 @@ + subroutine qmmm_eg(QMMM_energy,QMMM_gradient) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'energi.i' + include 'inform.i' + include 'iounit.i' + include 'qmmm.i' + include 'units.i' + integer i,j,imm + character*3 qmmmlabel(3) + save qmmmlabel + data qmmmlabel/'HLA','QM ','Y '/ + real*8 energy + real*8 derivs(3,maxatm) + real*8 QMMM_energy,QMMM_gradient(3,nbinqm) +c + if (debug) then + write (iout,10) + 10 format (/,' Analysis of the MM energy (in a QM/MM calc.)') + do i = 1, n + if (qmmm(i) .ne. 0) write(iout,20) i,qmmmlabel(qmmm(i)) + 20 format (' Atom ',i5,' is ',a3) + end do + call analysis(energy) + end if + call gradient(energy,derivs) + if(eb .ne.0.0d0) write(iout,100) ' eb = ',eb /hartree,eb + if(ea .ne.0.0d0) write(iout,100) ' ea = ',ea /hartree,ea + if(eba .ne.0.0d0) write(iout,100) ' eba = ',eba /hartree,eba + if(eub .ne.0.0d0) write(iout,100) ' eub = ',eub /hartree,eub + if(eaa .ne.0.0d0) write(iout,100) ' eaa = ',eaa /hartree,eaa + if(eopb.ne.0.0d0) write(iout,100) ' eopb = ',eopb/hartree,eopb + if(eopd.ne.0.0d0) write(iout,100) ' eopd = ',eopd/hartree,eopd + if(eid .ne.0.0d0) write(iout,100) ' eid = ',eid /hartree,eid + if(eit .ne.0.0d0) write(iout,100) ' eit = ',eit /hartree,eit + if(et .ne.0.0d0) write(iout,100) ' et = ',et /hartree,et + if(ept .ne.0.0d0) write(iout,100) ' ept = ',ept /hartree,ebt + if(ebt .ne.0.0d0) write(iout,100) ' ebt = ',ebt /hartree,ept + if(ett .ne.0.0d0) write(iout,100) ' ett = ',ett /hartree,ett + if(ev .ne.0.0d0) write(iout,100) ' ev = ',ev /hartree,ev + if(ec .ne.0.0d0) write(iout,100) ' ec = ',ec /hartree,ec + if(ecd .ne.0.0d0) write(iout,100) ' ecd = ',ecd /hartree,ecd + if(ed .ne.0.0d0) write(iout,100) ' ed = ',ed /hartree,ed + if(em .ne.0.0d0) write(iout,100) ' em = ',em /hartree,em + if(ep .ne.0.0d0) write(iout,100) ' ep = ',ep /hartree,ep + if(er .ne.0.0d0) write(iout,100) ' er = ',er /hartree,er + if(es .ne.0.0d0) write(iout,100) ' es = ',es /hartree,es + if(elf .ne.0.0d0) write(iout,100) ' elf = ',elf /hartree,elf + if(eg .ne.0.0d0) write(iout,100) ' eg = ',eg /hartree,eg + if(ex .ne.0.0d0) write(iout,100) ' ex = ',ex /hartree,ex + 100 format(a,f15.8,' ua = ',f15.8,' kcal/mol') +c + QMMM_energy = energy + j = 0 + do imm = 1, n + i = atinqm(imm) + if (i.ne.0) then + QMMM_gradient(1,i) = derivs(1,imm) + QMMM_gradient(2,i) = derivs(2,imm) + QMMM_gradient(3,i) = derivs(3,imm) + end if + end do + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/qmmm.i 6.2.06/source/qmmm.i --- 6.2.06/source_orig/qmmm.i 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/qmmm.i 2013-11-30 10:24:44.206831059 +0100 @@ -0,0 +1,112 @@ +c ############################################################## +c ## ## +c ## qmmm.i -- QM/MM stuff for coupling of tinker with QM ## +c ## ## +c ############################################################## +c +c maxqmmm the maximum number of atoms also defined in the qm program +c maxy the maximum number of QM/MM frontier bonds +c +c common /itkqmmm/: +c qmmm QM or MM atom ? for each atom in the system: +c MM -> 0 +c Link atom -> 1 +c QM -> 2 +c Y(LSCF/MM) -> 3 +c e4qmmm count or not some QM/MM electrostatic interactions +c -1 -> none, aka mechanical embedding +c 0 -> none but will be computed elsewhere +c 3 -> includes the QM/MM ones (microiteration or MD cases) +c nbinqm the number of atoms defined also in the qm program +c atinqm the mapping array between the qm program and tinker +c nybond the number of QM/MM SLBO frontiers +c iybond the array containing the frontier atom numbers +c qmcode selection of the QM program +c Molcas -> 0 or 1 +c Gaussian -> 2 +c casroot the casscf root which energy is scaled +c micromode MM microiterations mode: Full or On(ly) +c mmmdmode MM MD mode: Full or On(ly) +c mdnequi number of MD steps for equilibration +c mdnprod number of MD steps for production +c nsnap number of dumped MD snapshots +c +c common /ltkqmmm/: +c doespf ESPF calculation ? +c dorunmd Molecular Dynamics ? +c doqmmmdyn QM/MM molecular dynamics run ? +c doqmmmhessian QM/MM hessian contribution ? +c domdhess Hessian MD averaging ? +c +c common /ctkqmmm/: +c qmline the command line needed to run the qm job +c ensemble MD statistical ensemble for periodic systems +c +c common /rtkqmmm/: +c lahg the array containing the scaling factors of each frontier +c qmmmscale scale factor for qm/mm interactions +c casmme the saved MM energy when the caspt2 starts +c dtstep MD time step in ps +c dtdump MD dump time in ps +c x,y e zavg MD run coordinate averages +c epavg MD average electostatic potential +c epgavg MD average components of elec potential 1st derivative +c ephavg MD average components of elec potential 2nd derivative +c avgen MD average total energy +c avgderiv MD average components of total energy 1st derivative +c rmsd MD RMSD respect to the first structure +c eprmsd MD RMSD of elec potential respect to previous structure +c epgrmsd MD RMSD of 1st derivative of elec potential +c xpre ecc. MD 1st structure coordinates +c nstrut number of MD snaps used for average +c +c + integer maxqmmm,maxy,qmmm,e4qmmm,nbinqm,atinqm,nybond, + & iybond,micromode,mmmdmode,qmcode,casroot,nsnap,mdnequi,mdnprod + parameter(maxqmmm=1000) + parameter(maxy=100) + logical doespf,dorunmd,doqmmmdyn,doqmmmhessian,domdhess + character*120 qmline + character*3 ensemble + real*8 lahg,qmmmscale,casmme,dtstep,dtdump, + & xavg,yavg,zavg,rmsd,xpre,ypre,zpre,epgrmsd, + & nstrut + real*8 epavg,epgavg,ephavg,avgen,avgderiv,eprmsd + real*8 rcov(0:104) + save rcov + data rcov/0.0d0, + $ 0.354D0,0.849D0, + $ 1.336D0,1.010D0,0.838D0,0.757D0,0.700D0,0.658D0,0.668D0,0.920D0, + $ 1.539D0,1.421D0,1.244D0,1.117D0,1.101D0,1.064D0,1.044D0,1.032D0, + $ 1.953D0,1.761D0, + $ 1.513D0,1.412D0,1.402D0,1.345D0,1.382D0, + $ 1.270D0,1.241D0,1.164D0,1.302D0,1.193D0, + $ 1.260D0,1.197D0,1.211D0,1.190D0,1.192D0,1.147D0, + $ 2.260D0,2.052D0, + $ 1.698D0,1.564D0,1.473D0,1.467D0,1.322D0, + $ 1.478D0,1.332D0,1.338D0,1.386D0,1.403D0, + $ 1.459D0,1.398D0,1.407D0,1.386D0,1.382D0,1.267D0, + $ 2.570D0,2.277D0, + $ 1.943D0,1.841D0,1.823D0,1.816D0,1.801D0,1.780D0,1.771D0, + $ 1.735D0,1.732D0,1.710D0,1.696D0,1.673D0,1.660D0,1.637D0, + $ 1.671D0,1.611D0,1.511D0,1.392D0,1.372D0, + $ 1.372D0,1.371D0,1.364D0,1.262D0,1.340D0, + $ 1.518D0,1.459D0,1.512D0,1.500D0,1.545D0,1.420D0, + $ 2.880D0,2.512D0,1.983D0,1.721D0,1.711D0,1.684D0,1.666D0, + $ 1.657D0,1.660D0,1.801D0,1.761D0,1.750D0,1.724D0,1.712D0, + $ 1.689D0,1.679D0,1.698D0, + $ 1.850D0/ + + common /itkqmmm/ qmmm(maxatm),e4qmmm,nbinqm,atinqm(maxatm), + & nybond,iybond(2,maxy),qmcode,casroot,micromode, + & mmmdmode,nsnap,mdnequi,mdnprod + common /ltkqmmm/ doespf,dorunmd,doqmmmdyn,doqmmmhessian, + & domdhess + common /ctkqmmm/ qmline,ensemble + common /rtkqmmm/ lahg(maxy),qmmmscale,casmme,dtstep,dtdump, + & xavg(maxatm),yavg(maxatm),zavg(maxatm), + & epavg(maxqmmm),epgavg(3,maxqmmm),avgen(25), + & ephavg(6,maxqmmm),avgderiv(3,maxatm),rmsd, + & xpre(maxatm),ypre(maxatm),zpre(maxatm), + & eprmsd,epgrmsd(3),nstrut + diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/qmmm_post.f 6.2.06/source/qmmm_post.f --- 6.2.06/source_orig/qmmm_post.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/qmmm_post.f 2013-12-18 10:28:26.163518643 +0100 @@ -0,0 +1,100 @@ +cqmmm +c +c Post-processing in QM/MM calculations +c - Copy the MM atom numbers and coordinates in +c MMatnum(nMM) and MMcoord(3,nMM) +c - Save informations for Morokuma's scaling factors +c - Save the last xyz file +c - Copy it to a numbered file in case of geometry relax +c + subroutine qmmm_post(do_relax,nMM,MMatnum,MMcoord,nLAH,QMMM_laha, + & QMMM_lahg) + implicit none + include 'sizes.i' + include 'atmtyp.i' + include 'atoms.i' + include 'couple.i' + include 'files.i' + include 'iounit.i' + include 'qmmm.i' + character*7 ext + character*60 minfile + integer i,j,nMM,iAlloc + integer imin,freeunit,lext,icycle + integer MMatnum(nMM) + integer nLAH + integer QMMM_laha(3,maxy) + logical do_relax,exist + real*8 MMcoord(3,nMM) + real*8 QMMM_lahg(maxy) +c +c Copy the MM atoms +c + j = 0 + do i = 1, n + if (atinqm(i) .eq. 0) then + j = j + 1 + MMatnum(j) = atomic(i) + MMcoord(1,j) = x(i) + MMcoord(2,j) = y(i) + MMcoord(3,j) = z(i) + end if + end do + if (j .ne. nMM) then + write(iout,10) j, nMM +10 format('QMMM_POST -- j = ',i5,' different from nMM = ',i5) + call fatal + end if +c +c Link atom scaling factors +c + j = 0 + do i = 1, n + if (j > maxy) then + write(iout,20) +20 format('QMMM_POST -- too much link atoms.', + & ' Increase maxy in qmmm.i') + call fatal + end if + if (qmmm(i) .eq. 1) then + j = j + 1 + QMMM_laha(1,j) = atinqm(i) + QMMM_laha(2,j) = atinqm(i12(1,i)) + QMMM_laha(3,j) = atinqm(i12(2,i)) + if (lahg(j) .le. 0.0d0) then + lahg(j) = (rcov(atomic(i12(2,i)))+rcov(atomic(i)))/ + & (rcov(atomic(i12(2,i)))+rcov(atomic(i12(1,i)))) + QMMM_lahg(j) = lahg(j) + end if + end if + end do + nLAH = j +c +c Save the new coordinates in the xyz file +c + imin = freeunit () + minfile = filename(1:leng)//'.xyz' + open (unit=imin,file=minfile,status='unknown') + rewind (unit=imin) + call prtxyz (imin) + close (unit=imin) +c +c Save the coordinates into a numbered file too +c + if (do_relax .and. .not. dorunmd) then + icycle = 0 + exist = .true. + lext = 3 + 1999 icycle = icycle + 1 + call numeral (icycle,ext,lext) + minfile = filename(1:leng)//'.'//ext(1:lext) + inquire (file=minfile,exist=exist) + if (exist) goto 1999 + imin = freeunit () + open (unit=imin,file=minfile,status='unknown') + call prtxyz (imin) + close (unit=imin) + end if +c + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/qmmmsetup.f 6.2.06/source/qmmmsetup.f --- 6.2.06/source_orig/qmmmsetup.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/qmmmsetup.f 2013-12-18 10:28:26.163518643 +0100 @@ -0,0 +1,237 @@ + subroutine qmmmsetup + implicit none +c +c From its name ... setup the QM/MM run +c Basically read the key file and check the informations +c Also update the coordinates coming from the QM code +c + include 'sizes.i' + include 'atoms.i' + include 'bath.i' + include 'charge.i' + include 'files.i' + include 'inform.i' + include 'iounit.i' + include 'keys.i' + include 'mdstuf.i' + include 'qmmm.i' +c + integer next,i,j,k,ii,kk + integer nqmmmtmp + integer iqmmmtmp(maxqmmm) + logical found + character*20 keyword + character*120 record + character*120 string + character*2 qmmmcode + +c +c Look for the QMMM keywords in the key file +c + nbinqm = 0 + nybond = 0 + micromode = 0 + mmmdmode = 0 + if (n .eq. 0) return + do i = 1, n + atinqm(i) = 0 + end do + do i = 1, maxy + lahg(i) = -1.0d0 + end do + e4qmmm = 0 + doespf = .false. + found = .false. + doqmmmdyn = .false. + doqmmmhessian = .false. + qmcode = 0 + qmline = 'NOTHING' + qmmmscale = 1.0d0 + casroot = 0 + casmme = 0.0d0 + nqmmmtmp = 0 + mdnequi = 0 + mdnprod = 0 + dtstep = 1.0d-3 + dtdump = 1.0d-1 + domdhess = .false. + kelvin = 298.0d0 + atmsph = 1.0d0 + ensemble = 'NVE' + isothermal = .false. + isobaric = .false. + do j = 1, nkey + next = 1 + record = keyline(j) + call gettext (record,keyword,next) + call tk_upcase (keyword) + string = record(next:120) + do i = 1, maxqmmm + iqmmmtmp(i) = 0 + end do +c +c QMMM keyword followed by 2 integers +c - NbInQM: the number of atoms defined in the QM code +c - NYBond: the number of SLBOs in the LSCF/MM computation +c + if (keyword(1:5) .eq. 'QMMM ') then + found = .true. + read(string,*,err=1,end=1) nbinqm,nybond +1 write (iout,2) +2 format(/,' This is a QM/MM calculation') + if (nbinqm.le.0.or.nbinqm.gt.n.or.nbinqm.gt.maxqmmm) then + write (iout,3) nbinqm +3 format (/,' QMMMSETUP -- Wrong NbInQM value ',i2) + call fatal + end if + if (nybond.lt.0.or.nybond.gt.n.or.nybond.gt.maxqmmm) then + write (iout,4) nybond +4 format (/,' QMMMSETUP -- Wrong NYBond value ',i2) + call fatal + end if + else if (keyword(1:3) .eq. 'QM ' + & .or. keyword(1:3) .eq. 'MM ' + & .or. keyword(1:3) .eq. 'LA ' + & .or. keyword(1:3) .eq. 'YA ') then + qmmmcode = keyword(1:2) + read(string,*,err=5,end=5) (iqmmmtmp(i),i=1,maxqmmm) +5 i = 0 +6 i = i + 1 + k = iqmmmtmp(i) + if (k .eq. 0) goto 8 + if (k .gt. n) then + write (iout,7) k +7 format (/,' QMMMSETUP -- Wrong QM/MM/LA/YA value ',i2) + call fatal + else if (k .gt. 0) then + if (qmmmcode(1:2) .eq. 'MM') then + qmmm(k) = 0 + else if (qmmmcode(1:2) .eq. 'LA') then + qmmm(k) = 1 + else if (qmmmcode(1:2) .eq. 'QM') then + qmmm(k) = 2 + else + qmmm(k) = 3 + end if + nqmmmtmp = nqmmmtmp + 1 + atinqm(k) = nqmmmtmp + else + kk = iqmmmtmp(i+1) + if (kk.le.0 .or. kk.lt.k) then + write (iout,7) kk + call fatal + end if + do ii = -k, kk + nqmmmtmp = nqmmmtmp + 1 + atinqm(ii) = nqmmmtmp + if (qmmmcode(1:2) .eq. 'MM') then + qmmm(ii) = 0 + else if (qmmmcode(1:2) .eq. 'LA') then + qmmm(ii) = 1 + else if (qmmmcode(1:2) .eq. 'QM') then + qmmm(ii) = 2 + else + qmmm(ii) = 3 + end if + end do + i = i + 1 + end if + goto 6 +8 continue +c +c Select the QM/MM electrostatics interaction mode +c + else if (keyword(1:20) .eq. 'QMMM-ELECTROSTATICS ') then + call gettext (record,keyword,next) + call tk_upcase (keyword) + if (keyword(1:5) .eq. 'NONE ') then + e4qmmm = -1 + else + write (iout,*) ' QMMMSETUP -- Wrong QMMM-ELECTROSTATICS' + call fatal + end if +c +c Select the MM micro-iterations mode +c + else if (keyword(1:20) .eq. 'QMMM-MICROITERATION ') then + call gettext (record,keyword,next) + call tk_upcase (keyword) + if (keyword(1:5) .eq. 'FULL ') then + micromode = 1 + else if (keyword(1:3) .eq. 'ON ' + & .or. keyword(1:5) .eq. 'ONLY ') then + micromode = 2 + else if (keyword(1:4) .eq. 'OFF ') then + else + write (iout,*) ' QMMMSETUP -- Wrong QMMM-MICROITERATION' + call fatal + end if +c +c Select the QM/MM Hessian +c + else if (keyword(1:13) .eq. 'QMMM-HESSIAN ') then + call gettext (record,keyword,next) + call tk_upcase (keyword) + if (keyword(1:2) .eq. 'ON') then + doqmmmhessian = .true. + else if (keyword(1:3) .eq. 'OFF') then + doqmmmhessian = .false. + else + write (iout,*) ' QMMMSETUP -- Wrong QMMM-HESSIAN' + call fatal + end if +c +c Select the QM/MM dynamics arguments +c + else if (keyword(1:14) .eq. 'QMMM-EXTERNAL ') then + doqmmmdyn = .true. + call gettext (record,keyword,next) + call tk_upcase (keyword) + if (keyword(1:7) .eq. 'MOLCAS ') then + qmcode = 1 + else if (keyword(1:8) .eq. 'GAUSSIAN ') then + qmcode = 2 + end if + qmline = record(next:120) +c +c Is there any QM/MM scale factor ? +c + else if (keyword(1:11) .eq. 'QMMM-SCALE ') then + read(string,*,err=10,end=10) qmmmscale,casroot +10 if (casroot .gt. 0) then + write (iout,11) qmmmscale,casroot +11 format(/,' Initial QM/MM scale factor:' ,f7.3, + & ' for QM state ',i2) + else if (casroot .lt. 0) then + write (iout,12) qmmmscale,abs(casroot) +12 format(/,' Constant QM/MM scale factor: ',f7.3, + & ' for QM state ',i2) + else + write (iout,13) qmmmscale +13 format(/,' Constant QM/MM scale factor: ',f7.3) + end if + if (qmmmscale .le. 0.0d0) call fatal + end if + end do + if (nqmmmtmp .ne. nbinqm) then + write(iout,19) nqmmmtmp, nbinqm +19 format(/,' QMMMSETUP -- Found ',i4,' QM/MM/LA/YA atoms', + & /,' while ',i4,' were expected') + end if + if (.not.found) return +c +c Check the mapping. +c + do 20 i = 1, (n-1) + if (atinqm(i).eq.0) goto 20 + do j = i+1, n + if (atinqm(i).eq.atinqm(j)) then + write(iout,21) i,j,atinqm(i) +21 format(/,' QMMMSETUP -- Two atoms ',i4,' and ',i4, + & ' are mapped to the same QM atom ',i4) + call fatal + end if + end do +20 continue + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/qmmm_todo.f 6.2.06/source/qmmm_todo.f --- 6.2.06/source_orig/qmmm_todo.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/qmmm_todo.f 2013-10-21 18:20:56.409885307 +0200 @@ -0,0 +1,52 @@ +cqmmm + subroutine qmmm_todo + implicit none + include 'sizes.i' + include 'iounit.i' + include 'potent.i' + include 'qmmm.i' + logical do_fatal +c +c +c NYI in QM/MM --> TODO!!! +c + do_fatal = .false. + if (nbinqm .ne. 0) then + if (use_angang .or. use_strtor .or. use_tortor) then + write(iout,10) 'Coupled bonded interactions' + do_fatal = .true. + end if + if (use_chgdpl .or. use_dipole) then + write(iout,10) 'Bond dipoles' + do_fatal = .true. + end if + if (use_mpole) then + write(iout,10) 'Multipoles' + do_fatal = .true. + end if + if (use_polar) then + write(iout,10) 'Induced dipoles' + do_fatal = .true. + end if + if (use_solv) then + write (iout,10) 'SOLV' + do_fatal = .true. + end if + if (use_metal) then + write (iout,10) 'METAL' + do_fatal = .true. + end if + if (use_geom) then + write (iout,10) 'GEOM' + do_fatal = .true. + end if + end if + 10 format(//,' QMMM_TODO -- ',A,' NYI in QM/MM. Abort') + if ((use_polar .or. use_mpole) .and. nybond.ne.0) then + write (iout,20) + 20 format(//,' QMMM_TODO -- QM/MM Pol NYI with LSCF. Abort') + do_fatal = .true. + end if + if (do_fatal) call fatal + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/radial.f 6.2.06/source/radial.f --- 6.2.06/source_orig/radial.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/radial.f 2013-10-23 11:36:27.063130195 +0200 @@ -224,7 +224,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') intramol = .true. c c set the number of distance bins to be accumulated diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/random.f 6.2.06/source/random.f --- 6.2.06/source_orig/random.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/random.f 2013-10-23 11:36:27.063130195 +0200 @@ -82,7 +82,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:11) .eq. 'RANDOMSEED ') then string = record(next:120) read (string,*,err=10) seed @@ -135,23 +135,23 @@ end c c -c ############################################################ -c ## ## -c ## function normal -- random number from normal curve ## -c ## ## -c ############################################################ +c ############################################################### +c ## ## +c ## function tk_normal -- random number from normal curve ## +c ## ## +c ############################################################### c c -c "normal" generates a random number from a normal Gaussian +c "tk_normal" generates a random number from a normal Gaussian c distribution with a mean of zero and a variance of one c c - function normal () + function tk_normal () implicit none include 'inform.i' include 'iounit.i' real*8 random,v1,v2,rsq - real*8 factor,store,normal + real*8 factor,store,tk_normal logical compute save compute,store data compute / .true. / @@ -167,20 +167,20 @@ if (rsq .ge. 1.0d0) goto 10 factor = sqrt(-2.0d0*log(rsq)/rsq) store = v1 * factor - normal = v2 * factor + tk_normal = v2 * factor compute = .false. c c use the second random value computed at the last call c else - normal = store + tk_normal = store compute = .true. end if c c print the value of the current random number c c if (debug) then -c write (iout,20) normal +c write (iout,20) tk_normal c 20 format (' NORMAL -- The Random Number Value is',f12.8) c end if return @@ -240,14 +240,14 @@ end c c -c ############################################################## -c ## ## -c ## subroutine sphere -- uniform set of points on sphere ## -c ## ## -c ############################################################## +c ################################################################# +c ## ## +c ## subroutine tk_sphere -- uniform set of points on sphere ## +c ## ## +c ################################################################# c c -c "sphere" finds a specified number of uniformly distributed +c "tk_sphere" finds a specified number of uniformly distributed c points on a sphere of unit radius centered at the origin c c literature reference: @@ -257,7 +257,7 @@ c 19, 5-11 (1997) c c - subroutine sphere (ndot,dot) + subroutine tk_sphere (ndot,dot) implicit none include 'math.i' integer i,ndot diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/readgau.f 6.2.06/source/readgau.f --- 6.2.06/source_orig/readgau.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/readgau.f 2013-10-23 11:36:27.063130195 +0200 @@ -95,7 +95,7 @@ string = record call trimhead (string) length = trimtext (string) - call upcase (string) + call tk_upcase (string) if (waiter .and. string(1:12).ne.'JOB CPU TIME') then goto 160 else diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/readmol2.f 6.2.06/source/readmol2.f --- 6.2.06/source_orig/readmol2.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/readmol2.f 2013-10-23 11:36:27.063130195 +0200 @@ -60,7 +60,7 @@ 20 format (a120) next = 1 call gettext (record,string,next) - call upcase (string) + call tk_upcase (string) if (string .eq. '@MOLECULE') then read (isyb,30) title 30 format (a120) @@ -94,7 +94,7 @@ 80 format (a120) next = 1 call gettext (record,string,next) - call upcase (string) + call tk_upcase (string) if (string .eq. '@ATOM') then do j = 1, n read (isyb,90) record @@ -127,7 +127,7 @@ 110 format (a120) next = 1 call gettext (record,string,next) - call upcase (string) + call tk_upcase (string) if (string .eq. '@BOND') then do j = 1, nbond read (isyb,120) record @@ -146,7 +146,7 @@ c for each atom, sort its list of attached atoms c do i = 1, n - call sort (n12(i),i12(1,i)) + call tk_sort (n12(i),i12(1,i)) end do if (.not. opened) close (unit=isyb) return diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/readmol.f 6.2.06/source/readmol.f --- 6.2.06/source_orig/readmol.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/readmol.f 2013-10-23 11:36:27.063130195 +0200 @@ -112,7 +112,7 @@ c for each atom, sort its list of attached atoms c do i = 1, n - call sort (n12(i),i12(1,i)) + call tk_sort (n12(i),i12(1,i)) end do if (.not. opened) close (unit=imdl) return diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/readpdb.f 6.2.06/source/readpdb.f --- 6.2.06/source_orig/readpdb.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/readpdb.f 2013-10-23 11:36:27.063130195 +0200 @@ -93,7 +93,7 @@ do while (.true.) read (ipdb,20,err=190,end=190) record 20 format (a120) - call upcase (record) + call tk_upcase (record) remark = record(1:6) if (remark .eq. 'HEADER') then title = record(11:70) @@ -387,7 +387,7 @@ do while (.not. done) read (ipdb,10,err=60,end=60) record 10 format (a120) - call upcase (record) + call tk_upcase (record) remark = record(1:6) if (remark.eq.'ATOM ' .or. remark.eq.'HETATM') then next = 7 @@ -470,7 +470,7 @@ read (input,80) chntemp 80 format (a20) end if - call upcase (chntemp) + call tk_upcase (chntemp) next = 1 call gettext (chntemp,text,next) if (text.eq.blank .or. text(1:3).eq.'ALL') then @@ -515,7 +515,7 @@ call gettext (record,altsym,next) end if if (altsym .eq. ' ') altsym = alttyp(1:1) - call upcase (altsym) + call tk_upcase (altsym) end if c c find out which of the insert records will be used @@ -538,7 +538,7 @@ read (input,120) instemp 120 format (a20) end if - call upcase (instemp) + call tk_upcase (instemp) next = 1 call gettext (instemp,text,next) if (text.eq.blank .or. text.eq.'ALL ') then diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/readprm.f 6.2.06/source/readprm.f --- 6.2.06/source_orig/readprm.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/readprm.f 2013-10-23 11:36:27.063130195 +0200 @@ -141,7 +141,7 @@ record = prmline(iprm) next = 1 call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) c c check for a force field modification keyword c @@ -877,9 +877,9 @@ ntt = ntt + 1 ktt(ntt) = pa//pb//pc//pd//pe nx = nxy - call sort9 (nx,tx) + call tk_sort9 (nx,tx) ny = nxy - call sort9 (ny,ty) + call tk_sort9 (ny,ty) tnx(ntt) = nx tny(ntt) = ny do i = 1, nx diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/readxyz.f 6.2.06/source/readxyz.f --- 6.2.06/source_orig/readxyz.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/readxyz.f 2013-10-28 17:44:02.952040265 +0100 @@ -25,6 +25,7 @@ include 'files.i' include 'inform.i' include 'iounit.i' + include 'qmmm.i' include 'titles.i' integer i,j,k,m integer ixyz,nmax @@ -39,6 +40,8 @@ character*120 xyzfile character*120 record character*120 string +cqmmm + integer ia,ib,ilah,iya c c c initialize the total number of atoms in the system @@ -152,6 +155,12 @@ 80 format (/,' READXYZ -- Error in Coordinate File at Atom',i6) call fatal end if +cqmmm +c set up the qm/mm options +cqmmm + call qmmmsetup + ilah = 0 + iya = 0 c c for each atom, count and sort its attached atoms c @@ -164,9 +173,74 @@ end if end do 90 continue - call sort (n12(i),i12(1,i)) + call tk_sort (n12(i),i12(1,i)) +cqmmm +c cancel the link atom connectivity but keeps the numbering +c of the frontier bond atoms +cqmmm + if (qmmm(i).eq.1) then + write (iout,81) i + 81 format (/,i6,' is defined as a QM/MM Link Atom') + ilah = ilah + 1 + if (ilah .gt. maxy) then + write (iout,*) 'READXYZ -- Too much link atoms' + call fatal + end if + if (n12(i).ne.2) then + write (iout,82) + 82 format (/,' Wrong definition of this frontier bond') + call fatal + end if + ia = i12(1,i) + ib = i12(2,i) + if (qmmm(ia).eq.0.and.qmmm(ib).eq.2) then + i12(1,i) = ia + i12(2,i) = ib + else if (qmmm(ia).eq.2.and.qmmm(ib).eq.0) then + i12(1,i) = ib + i12(2,i) = ia + else + write (iout,83) + 83 format(/,' A frontier bond must be defined between ', + & '1 MM atom and 1 QM atom') + call fatal + end if + n12(i) = 0 + end if +cqmmm +c found a hybrid Y atom in LSCF/MM +c + if (qmmm(i).eq.3) then + write (iout,85) i + 85 format (/,i6,' is defined as a LSCF/MM frontier Y atom') + do j = 1, n12(i) + k = i12(j,i) +c If k is a QM atom, add them to the iybond list + if (qmmm(k).eq.2) then + iya = iya + 1 + if (iya .gt. maxy) then + write(iout,86) + 86 format(/,' READXYZ -- Too much QM-Y SLBO bonds') + call fatal + end if + iybond (1,iya) = atinqm(i) +c Look what is the numbering of the current QM atom in the QM code + iybond (2,iya) = atinqm(k) + end if + end do + end if +cqmmm end do c +c Check the LSCF/MM frontiers. +c + if (iya.ne.nybond) then + write (iout,87) iya,nybond + 87 format (/,' QMMMSETUP -- Counted ',i2,' QM-Y bonds but ', + & i2,' are expected') + call fatal + end if +c c perform dynamic allocation of some local arrays c nmax = 0 @@ -185,6 +259,8 @@ list(tag(i)) = i if (tag(i) .ne. i) reorder = .true. end do +cqmmm + if (reorder) reorder = (nbinqm .eq. 0) if (reorder) then write (iout,100) 100 format (/,' READXYZ -- Atom Labels not Sequential,', @@ -194,7 +270,7 @@ do j = 1, n12(i) i12(j,i) = list(i12(j,i)) end do - call sort (n12(i),i12(1,i)) + call tk_sort (n12(i),i12(1,i)) end do end if c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/runqm.f 6.2.06/source/runqm.f --- 6.2.06/source_orig/runqm.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/runqm.f 2013-10-21 18:20:56.449885306 +0200 @@ -0,0 +1,190 @@ +cqmmm +c +c ##################################################################### +c ## ## +c ## subroutine RunQM -- driver calling the QM part of a QM/MM job ## +c ## ## +c ##################################################################### +c + subroutine RunQM + implicit none + include 'sizes.i' + include 'atmtyp.i' + include 'atoms.i' + include 'charge.i' + include 'argue.i' + include 'energi.i' + include 'iounit.i' + include 'units.i' + include 'usage.i' + include 'files.i' + include 'group.i' + include 'inform.i' + include 'potent.i' + include 'deriv.i' + include 'qmmm.i' + character*60 minfile + integer i,j,k,kk,imin,espfmode,freeunit + real*8 fx,fy,fz,qtmp,mux,muy,muz,epf,epg(3),eph(6) +c +c atomic symbols +c + character*2 atosym(103) + save atosym + data atosym/' H','He', + $ 'Li','Be',' B',' C',' N',' O',' F','Ne', + $ 'Na','Mg','Al','Si',' P',' S','Cl','Ar', + $ ' K','Ca','Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu', + $ 'Zn','Ga','Ge','As','Se','Br','Kr', + $ 'Rb','Sr',' Y','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag', + $ 'Cd','In','Sn','Sb','Te',' I','Xe', + $ 'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb','Dy', + $ 'Ho','Er','Tm','Yb','Lu','Hf','Ta',' W','Re','Os','Ir','Pt', + $ 'Au','Hg','Tl','Pb','Bi','Po','At','Rn', + $ 'Fr','Ra','Ac','Th','Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es', + $ 'Fm','Md','No','Lr'/ +c +c initialization +c + if (qmcode .lt. 0 .or. qmcode .gt. 2) then + write(iout,'(A,I2)') 'RUNQM -- wrong QM code: ',qmcode + call fatal + end if + doespf = .true. + e4qmmm = 0 +c +c the coordinates +c + if (qmcode .eq. 0 .or. qmcode .eq. 1) then + imin = freeunit () + minfile = filename(1:leng)//'.coor' + open (unit=imin,file=minfile,status='unknown') + else + imin = 54 + open (unit=imin,status='unknown') + end if + rewind (unit=imin) + write(imin,'(i10,/,a)') nbinqm,'Coordinates from tinker' + do i = 1, nbinqm + do j = 1, n + if (i.eq.atinqm(j)) write(imin,1) atosym(atomic(j)),x(j), + & y(j),z(j) + 1 format (a,3f12.7) + end do + end do + close (unit=imin) +c +c the electrostatic potential and its derivatives +c + if (qmcode .eq. 0 .or. qmcode .eq. 1) then + imin = freeunit () + minfile = filename(1:leng)//'.qmmm' + open (unit=imin,file=minfile,status='unknown') + else if (qmcode .eq. 2) then + imin = 55 + open (unit=imin,status='unknown') + end if + rewind (unit=imin) + if (qmcode.ne.2) write(imin,'(A1)') '0' + do i = 1, nbinqm + do j = 1, n + if (i.eq.atinqm(j)) then +c call elecpot(j,epf,epg,eph) + write(imin,10) epf*bohr, + & epg(1)*bohr*bohr, + & epg(2)*bohr*bohr, + & epg(3)*bohr*bohr, + & eph(1)*bohr*bohr*bohr, + & eph(2)*bohr*bohr*bohr, + & eph(3)*bohr*bohr*bohr, + & eph(4)*bohr*bohr*bohr, + & eph(5)*bohr*bohr*bohr, + & eph(6)*bohr*bohr*bohr + 10 format (10f11.7) + if (debug) then + write(iout,'(/,A,I5)') ' Ext. Pot. on Tinker atom ',j + write(iout,11) ' V= ',epf * bohr + write(iout,12) ' X= ',epg(1)*bohr*bohr, + & ' Y= ',epg(2)*bohr*bohr, + & ' Z= ',epg(3)*bohr*bohr + write(iout,12) ' XX=',eph(1)*bohr*bohr*bohr, + & ' YY=',eph(2)*bohr*bohr*bohr, + & ' ZZ=',eph(3)*bohr*bohr*bohr + write(iout,12) ' XY=',eph(4)*bohr*bohr*bohr, + & ' XZ=',eph(5)*bohr*bohr*bohr, + & ' YZ=',eph(6)*bohr*bohr*bohr + 11 format(A,F10.5) + 12 format(3(A,F10.5)) + end if + end if + end do + end do + close (unit=imin) +c +c run the QM code +c + call system(qmline) +c +c get back informations from the same .qmmm file +c + if (qmcode .eq. 0 .or. qmcode .eq. 1) then + imin = freeunit () + minfile = filename(1:leng)//'.qmmm' + open (unit=imin,file=minfile,status='unknown') + else + imin = 56 + open (unit=imin,status='unknown') + end if + espfmode = -1 + rewind (unit=imin) + read(imin,20) ex, espfmode + 20 format(F12.7,I5) + ex = ex * hartree +c +c in the near future, espfmode = 1 should be ok too +c +c if (espfmode.ne.0 .or. espfmode.ne.1) then +c + if (espfmode.ne.0) then + write(iout,'(A,I5)') 'RUNQM -- wrong ESPFMODE = ',espfmode + call fatal + end if + do i = 1, nbinqm + fx = 0.0d0 + fy = 0.0d0 + fz = 0.0d0 + qtmp = 0.0d0 + mux = 0.0d0 + mux = 0.0d0 + mux = 0.0d0 + if (espfmode.eq.1) then + read(imin,21) fx,fy,fz,qtmp + 21 format(4F12.7) + else + read(imin,22) fx,fy,fz,qtmp,mux,muy,muz + 22 format(7F12.7) + end if + do j = 1, n + if (atinqm(j) .eq. i .and. qmmm(j).ne.0) then + dex(1,j) = qmmmscale * fx * hartree / bohr + dex(2,j) = qmmmscale * fy * hartree / bohr + dex(3,j) = qmmmscale * fz * hartree / bohr + do k = 1, nion + kk = iion(k) + if (j .eq. kk) then + pchg(k) = qtmp + if (debug) write (iout,23) j,pchg(k) + 23 format(' RUNQM -- New QM point charge value for ', + & i4,' = ',f10.5) + if (abs(qtmp) .gt. 1.0d0) write (iout,24) j,pchg(k) + 24 format(' RUNQM -- Warning: pchg(',i4,')= ',f10.5) + end if + end do + end if + end do + end do + close (unit=imin) + doespf = .false. +c + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/saddle.f 6.2.06/source/saddle.f --- 6.2.06/source_orig/saddle.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/saddle.f 2013-10-23 11:36:27.063130195 +0200 @@ -152,7 +152,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:8) .eq. 'DIVERGE ') then read (string,*,err=10,end=10) diverge @@ -191,7 +191,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') scan = .true. c c superimpose the two conformational endpoints diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/sdstep.f 6.2.06/source/sdstep.f --- 6.2.06/source_orig/sdstep.f 2013-07-14 04:23:54.000000000 +0200 +++ 6.2.06/source/sdstep.f 2013-10-23 11:36:27.063130195 +0200 @@ -195,7 +195,7 @@ real*8 gdt8,gdt9 real*8 pterm,vterm real*8 pnorm,vnorm - real*8 normal + real*8 tk_normal real*8 psig,vsig real*8 rho,rhoc real*8 pfric(*) @@ -287,8 +287,8 @@ vsig = sqrt(ktm*vterm) rhoc = sqrt(1.0d0 - rho*rho) do j = 1, 3 - pnorm = normal () - vnorm = normal () + pnorm = tk_normal () + vnorm = tk_normal () prand(j,i) = psig * pnorm vrand(j,i) = vsig * (rho*pnorm+rhoc*vnorm) end do diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/shakeup.f 6.2.06/source/shakeup.f --- 6.2.06/source_orig/shakeup.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/shakeup.f 2013-10-23 11:36:27.063130195 +0200 @@ -57,7 +57,7 @@ next = 1 record = keyline(k) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:11) .eq. 'RATTLE-EPS ') then read (string,*,err=10,end=10) rateps @@ -70,7 +70,7 @@ do k = 1, nkey next = 1 record = keyline(k) - call upcase (record) + call tk_upcase (record) call gettext (record,keyword,next) if (keyword(1:7) .eq. 'RATTLE ') then call getword (record,rattyp,next) @@ -252,7 +252,7 @@ next = 1 record = keyline(k) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) if (keyword(1:16) .eq. 'RATTLE-DISTANCE ') then call getnumb (record,ia,next) call getnumb (record,ib,next) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/sort.f 6.2.06/source/sort.f --- 6.2.06/source_orig/sort.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/sort.f 2013-10-23 11:36:27.063130195 +0200 @@ -5,18 +5,18 @@ c ## All Rights Reserved ## c ################################################### c -c ######################################################### -c ## ## -c ## subroutine sort -- heapsort of an integer array ## -c ## ## -c ######################################################### +c ############################################################ +c ## ## +c ## subroutine tk_sort -- heapsort of an integer array ## +c ## ## +c ############################################################ c c -c "sort" takes an input list of integers and sorts it +c "tk_sort" takes an input list of integers and sorts it c into ascending order using the Heapsort algorithm c c - subroutine sort (n,list) + subroutine tk_sort (n,list) implicit none integer i,j,k,n integer index,lists @@ -60,19 +60,19 @@ end c c -c ############################################################## -c ## ## -c ## subroutine sort2 -- heapsort of real array with keys ## -c ## ## -c ############################################################## +c ################################################################# +c ## ## +c ## subroutine tk_sort2 -- heapsort of real array with keys ## +c ## ## +c ################################################################# c c -c "sort2" takes an input list of reals and sorts it +c "tk_sort2" takes an input list of reals and sorts it c into ascending order using the Heapsort algorithm; c it also returns a key into the original ordering c c - subroutine sort2 (n,list,key) + subroutine tk_sort2 (n,list,key) implicit none integer i,j,k,n integer index,keys @@ -130,19 +130,19 @@ end c c -c ################################################################# -c ## ## -c ## subroutine sort3 -- heapsort of integer array with keys ## -c ## ## -c ################################################################# +c #################################################################### +c ## ## +c ## subroutine tk_sort3 -- heapsort of integer array with keys ## +c ## ## +c #################################################################### c c -c "sort3" takes an input list of integers and sorts it +c "tk_sort3" takes an input list of integers and sorts it c into ascending order using the Heapsort algorithm; c it also returns a key into the original ordering c c - subroutine sort3 (n,list,key) + subroutine tk_sort3 (n,list,key) implicit none integer i,j,k,n integer index @@ -201,18 +201,18 @@ end c c -c ################################################################# -c ## ## -c ## subroutine sort4 -- heapsort of integer absolute values ## -c ## ## -c ################################################################# +c #################################################################### +c ## ## +c ## subroutine tk_sort4 -- heapsort of integer absolute values ## +c ## ## +c #################################################################### c c -c "sort4" takes an input list of integers and sorts it into +c "tk_sort4" takes an input list of integers and sorts it into c ascending absolute value using the Heapsort algorithm c c - subroutine sort4 (n,list) + subroutine tk_sort4 (n,list) implicit none integer i,j,k,n integer index @@ -257,18 +257,18 @@ end c c -c ################################################################ -c ## ## -c ## subroutine sort5 -- heapsort of integer array modulo m ## -c ## ## -c ################################################################ +c ################################################################### +c ## ## +c ## subroutine tk_sort5 -- heapsort of integer array modulo m ## +c ## ## +c ################################################################### c c -c "sort5" takes an input list of integers and sorts it +c "tk_sort5" takes an input list of integers and sorts it c into ascending order based on each value modulo "m" c c - subroutine sort5 (n,list,m) + subroutine tk_sort5 (n,list,m) implicit none integer i,j,k,m,n integer index,smod @@ -326,18 +326,18 @@ end c c -c ############################################################# -c ## ## -c ## subroutine sort6 -- heapsort of a text string array ## -c ## ## -c ############################################################# +c ################################################################ +c ## ## +c ## subroutine tk_sort6 -- heapsort of a text string array ## +c ## ## +c ################################################################ c c -c "sort6" takes an input list of character strings and sorts +c "tk_sort6" takes an input list of character strings and sorts c it into alphabetical order using the Heapsort algorithm c c - subroutine sort6 (n,list) + subroutine tk_sort6 (n,list) implicit none integer i,j,k,n integer index @@ -382,19 +382,19 @@ end c c -c ################################################################ -c ## ## -c ## subroutine sort7 -- heapsort of text strings with keys ## -c ## ## -c ################################################################ +c ################################################################### +c ## ## +c ## subroutine tk_sort7 -- heapsort of text strings with keys ## +c ## ## +c ################################################################### c c -c "sort7" takes an input list of character strings and sorts it +c "tk_sort7" takes an input list of character strings and sorts it c into alphabetical order using the Heapsort algorithm; it also c returns a key into the original ordering c c - subroutine sort7 (n,list,key) + subroutine tk_sort7 (n,list,key) implicit none integer i,j,k,n integer index @@ -453,19 +453,19 @@ end c c -c ######################################################### -c ## ## -c ## subroutine sort8 -- heapsort to unique integers ## -c ## ## -c ######################################################### +c ############################################################ +c ## ## +c ## subroutine tk_sort8 -- heapsort to unique integers ## +c ## ## +c ############################################################ c c -c "sort8" takes an input list of integers and sorts it into +c "tk_sort8" takes an input list of integers and sorts it into c ascending order using the Heapsort algorithm, duplicate c values are removed from the final sorted list c c - subroutine sort8 (n,list) + subroutine tk_sort8 (n,list) implicit none integer i,j,k,n integer index @@ -521,19 +521,19 @@ end c c -c ############################################################ -c ## ## -c ## subroutine sort9 -- heapsort to unique real values ## -c ## ## -c ############################################################ +c ############################################################### +c ## ## +c ## subroutine tk_sort9 -- heapsort to unique real values ## +c ## ## +c ############################################################### c c -c "sort9" takes an input list of reals and sorts it into +c "tk_sort9" takes an input list of reals and sorts it into c ascending order using the Heapsort algorithm, duplicate c values are removed from the final sorted list c c - subroutine sort9 (n,list) + subroutine tk_sort9 (n,list) implicit none integer i,j,k,n integer index @@ -589,19 +589,19 @@ end c c -c ############################################################## -c ## ## -c ## subroutine sort10 -- heapsort to unique text strings ## -c ## ## -c ############################################################## +c ################################################################# +c ## ## +c ## subroutine tk_sort10 -- heapsort to unique text strings ## +c ## ## +c ################################################################# c c -c "sort10" takes an input list of character strings and sorts +c "tk_sort10" takes an input list of character strings and sorts c it into alphabetical order using the Heapsort algorithm, c duplicate values are removed from the final sorted list c c - subroutine sort10 (n,list) + subroutine tk_sort10 (n,list) implicit none integer i,j,k,n integer index diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/spacefill.f 6.2.06/source/spacefill.f --- 6.2.06/source_orig/spacefill.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/spacefill.f 2013-10-23 11:36:27.063130195 +0200 @@ -120,7 +120,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .ne. 'Y') then do i = 1, n if (atomic(i) .eq. 1) use(i) = .false. diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/square.f 6.2.06/source/square.f --- 6.2.06/source_orig/square.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/square.f 2013-10-23 11:36:27.067130195 +0200 @@ -154,7 +154,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:7) .eq. 'FCTMIN ') then read (string,*,err=30,end=30) fctmin diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/superpose.f 6.2.06/source/superpose.f --- 6.2.06/source_orig/superpose.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/superpose.f 2013-10-23 11:36:27.067130195 +0200 @@ -201,7 +201,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (start.eq.0 .and. stop.eq.0) then start = 1 stop = min(n1,n2) @@ -288,7 +288,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') dopbc = .true. end if c @@ -304,7 +304,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'M') then do i = 1, nfit wfit(i) = 0.5d0 * (mass1(ifit(1,i)) + mass2(ifit(2,i))) @@ -328,7 +328,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') dowrite = .true. c c chose cutoff value for output of atom pair deviations diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/surface.f 6.2.06/source/surface.f --- 6.2.06/source_orig/surface.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/surface.f 2013-10-23 11:36:27.067130195 +0200 @@ -251,7 +251,7 @@ c current sphere; sort intersecting spheres by their degree c of overlap with the current main sphere c - call sort2 (io,gr,key) + call tk_sort2 (io,gr,key) do i = 1, io k = key(i) intag(i) = intag1(k) @@ -437,7 +437,7 @@ c c general case; sum up arclength and set connectivity code c - call sort2 (narc,arci,key) + call tk_sort2 (narc,arci,key) arcsum = arci(1) mi = key(1) t = arcf(mi) @@ -857,7 +857,7 @@ c current sphere; sort intersecting spheres by their degree c of overlap with the current main sphere c - call sort2 (io,gr,key) + call tk_sort2 (io,gr,key) do i = 1, io k = key(i) intag(i) = intag1(k) @@ -1043,7 +1043,7 @@ c c general case; sum up arclength and set connectivity code c - call sort2 (narc,arci,key) + call tk_sort2 (narc,arci,key) arcsum = arci(1) mi = key(1) t = arcf(mi) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/surfatom.f 6.2.06/source/surfatom.f --- 6.2.06/source_orig/surfatom.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/surfatom.f 2013-10-23 11:36:27.067130195 +0200 @@ -195,7 +195,7 @@ c case where many spheres intersect the sphere of interest; c sort the intersecting spheres by their degree of overlap c - call sort2 (io,gr,key) + call tk_sort2 (io,gr,key) do i = 1, io k = key(i) intag(i) = intag1(k) @@ -378,7 +378,7 @@ c c general case; sum up arclength and set connectivity code c - call sort2 (narc,arci,key) + call tk_sort2 (narc,arci,key) arcsum = arci(1) mi = key(1) t = arcf(mi) @@ -712,7 +712,7 @@ c case where many spheres intersect the sphere of interest; c sort the intersecting spheres by their degree of overlap c - call sort2 (io,gr,key) + call tk_sort2 (io,gr,key) do i = 1, io k = key(i) intag(i) = intag1(k) @@ -895,7 +895,7 @@ c c general case; sum up arclength and set connectivity code c - call sort2 (narc,arci,key) + call tk_sort2 (narc,arci,key) arcsum = arci(1) mi = key(1) t = arcf(mi) diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/temper.f 6.2.06/source/temper.f --- 6.2.06/source_orig/temper.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/temper.f 2013-10-23 11:36:27.067130195 +0200 @@ -158,7 +158,7 @@ real*8 eksum,ekt real*8 scale,speed real*8 c,d,r,s,si - real*8 random,normal + real*8 random,tk_normal real*8 kt,rate,trial real*8 temp,expterm real*8 w(3) @@ -203,10 +203,10 @@ if (temp .eq. 0.0d0) temp = 0.1d0 c = exp(-dt/tautemp) d = (1.0d0-c) * (kelvin/temp) / dble(nfree) - r = normal () + r = tk_normal () s = 0.0d0 do i = 1, nfree-1 - si = normal () + si = tk_normal () s = s + si*si end do scale = c + (s+r*r)*d + 2.0d0*r*sqrt(c*d) @@ -242,7 +242,7 @@ if (trial .lt. rate) then speed = sqrt(kt/grpmass(i)) do j = 1, 3 - vcm(j,i) = speed * normal () + vcm(j,i) = speed * tk_normal () end do end if end do @@ -256,7 +256,7 @@ k = kmol(j) speed = sqrt(kt/mass(k)) do m = 1, 3 - v(m,k) = speed * normal () + v(m,k) = speed * tk_normal () end do end do end if @@ -269,7 +269,7 @@ if (trial .lt. rate) then speed = sqrt(kt/mass(i)) do j = 1, 3 - v(j,i) = speed * normal () + v(j,i) = speed * tk_normal () end do end if end if diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/testgrad.f 6.2.06/source/testgrad.f --- 6.2.06/source_orig/testgrad.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/testgrad.f 2013-10-23 11:36:27.067130195 +0200 @@ -90,7 +90,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'N') doanalyt = .false. c c decide whether to do a numerical gradient calculation @@ -105,7 +105,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'N') donumer = .false. c c get the stepsize for numerical gradient calculation @@ -145,7 +145,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') dofull = .true. end if c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/testhess.f 6.2.06/source/testhess.f --- 6.2.06/source_orig/testhess.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/testhess.f 2013-10-23 11:36:27.067130195 +0200 @@ -76,7 +76,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'N') doanalyt = .false. c c decide whether to do a numerical Hessian calculation @@ -94,7 +94,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'N') donumer = .false. end if c @@ -112,7 +112,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'F') dograd = .false. c c get the stepsize for numerical Hessian calculation @@ -150,7 +150,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'Y') dofull = .true. end if c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/timer.f 6.2.06/source/timer.f --- 6.2.06/source_orig/timer.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/timer.f 2013-10-23 11:36:27.067130195 +0200 @@ -76,7 +76,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'N') dohessian = .false. c c perform dynamic allocation of some local arrays diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/timerot.f 6.2.06/source/timerot.f --- 6.2.06/source_orig/timerot.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/timerot.f 2013-10-23 11:36:27.067130195 +0200 @@ -79,7 +79,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'N') dohessian = .false. c c print the time required for the computation setup diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/tkr2qm.f 6.2.06/source/tkr2qm.f --- 6.2.06/source_orig/tkr2qm.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/tkr2qm.f 2014-02-18 10:13:27.596108542 +0100 @@ -0,0 +1,253 @@ +cqmmm +c For QM/MM calculations, tkr2qm is the main bridge between any QM program and Tinker. +c Arguments: +c - is_syscall: true if tkr2qm was called by the tkr2qm_s program +c - Project: name of the project +c - nAtInQM: number of atoms defined in the QMprog calling program +c - QMprog: currently only 'Molcas' or 'Gaussian' shall work, but accepts any +c - QMcoord: updated atom coordinates in angstrom +c - MltOrd: order of the QM multipoles +c ESPF -> MltOrd = 0 (charges) or 1 (charges + dipoles) +c Direct -> MltOrd = -1 +c - QMmult: QM-centered atomic charges or dipoles +c - do_calc: compute the MM contribution to the QM/MM energy +c + compute the MM contribution to the gradient at the QM atoms +c (* if false, tkr2qm is used for preparing the QM input *) +c - do_relax: shall the MM subsystem be relaxed? +c - QMMM_energy: MM contribution to the QM/MM energy +c - QMMM_gradient: MM contribution to the QM/MM gradient at the QMprog atoms +c - QMMM_extpot: MM electrostatic potential generated by all the MM atoms +c including the ones present in the QMprog program +c (* this array must be sized according to the value of MltOrd *) +c - nMM: number of MM atoms unknown from QMprog +c - MMatnum: atomic numbers of the nMM atoms +c - MMcoord: coordinates of the nMM atoms +c - nLAH: number of Link Atoms +c - QMMM_laha: triplet of atom numbers needed to apply the Morokuma's scaling scheme +c - QMMM_lahg: scaling factors for Morokuma's scaling scheme +c - elec_cpl: -1 -> mechanical embedding +c 0 -> normal electrostatic embedding +c 1 -> self-consistent electrostatic embedding +c + subroutine tkr2qm(is_syscall,Project,nAtInQM,QMprog,QMcoord, + & MltOrd,QMmult,do_calc,do_relax, + & QMMM_energy,QMMM_gradient,QMMM_extpot, + & nMM,MMatnum,MMcoord, + & nLAH,QMMM_laha,QMMM_lahg, + & elec_cpl) + implicit none + include 'sizes.i' + include 'argue.i' + include 'atmtyp.i' + include 'atoms.i' + include 'bound.i' + include 'charge.i' + include 'couple.i' + include 'cutoff.i' + include 'energi.i' + include 'files.i' + include 'group.i' + include 'inform.i' + include 'iounit.i' + include 'moldyn.i' + include 'mpole.i' + include 'polar.i' + include 'potent.i' + include 'qmmm.i' + include 'scales.i' + include 'units.i' + include 'usage.i' +c + character*(*) Project + character*(*) QMprog + integer nAtInQM,MltOrd,nMM,elec_cpl + integer MMatnum(*),nLAH,QMMM_laha(*) + logical is_syscall + logical do_calc,do_relax + real*8 QMcoord(3,*),QMmult(4,*) + real*8 QMMM_energy,QMMM_gradient(*),QMMM_extpot(*) + real*8 MMcoord(*),QMMM_lahg(*) +c + character*2 zsymbol(0:103) + character*3 MMsymbol + character*60 minfile + character*7 ext + integer i,j,ll,trimtext,imin,freeunit,nComp,nCenter + integer lext,icycle + logical exist,domicro + external trimtext + save zsymbol + data zsymbol/ + & ' X', + & ' H','He','Li','Be',' B',' C',' N',' O',' F','Ne', + & 'Na','Mg','Al','Si',' P',' S','Cl','Ar',' K','Ca', + & 'Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu','Zn', + & 'Ga','Ge','As','Se','Br','Kr','Rb','Sr',' Y','Zr', + & 'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn', + & 'Sb','Te',' I','Xe','Cs','Ba','La','Ce','Pr','Nd', + & 'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb', + & 'Lu','Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg', + & 'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th', + & 'Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es','Fm', + & 'Md','No','Lr' + & / +c +c Initialization +c + QMMM_energy = 0.0d0 + if (.not. is_syscall) then + call initial + narg = 1 + listarg(1) = .true. + arg(1) = Project + call getxyz + nAtInQM = nbinqm + end if +c +c Who's the master? +c + ll = trimtext(QMprog) + call tk_upcase(QMprog(1:ll)) + write (iout,10) QMprog(1:ll) + 10 format (/, ' Tinker is called by ',a) +c +c Setup of the ff parameters +c + call mechanic + if (use_born .and. nbinqm .ne. 0) then + write (iout,*) ' Tkr2QM: Born NYI with QM/MM, turned off' + use_born = .false. + end if + if (use_polar .or. use_ewald) elec_cpl = 1 + if (e4qmmm .eq. -1) elec_cpl = -1 +c +c Activate all the atoms defined in QMprog input +c + do i = 1, n + if (atinqm(i) .ne. 0 .and. .not.use(i)) then + write (iout,11) i + 11 format(' TKR2QM -- ',i6,' was inactive. Now active.') + use(i) = .true. + nuse = nuse + 1 + end if +c +c Atoms in QMprog input have to be put in group 0 to inactivate +c them in rigid body calculations +c + if (atinqm(i) .ne. 0 .and. use_group) then + j = grplist(i) + grplist(i) = 0 + kgrp(i) = 0 + if (i .eq. igrp(1,j)) igrp(1,j) = 1 + if (i .eq. igrp(2,j)) then + igrp(2,j) = 0 + ngrp = ngrp - 1 + end if + end if + end do +c +c Inconsistencies? +c + doespf = MltOrd .ge. 0 + call qmmm_todo + if ((use_mpole .or. use_polar) .and. .not.doespf) then + write(iout,*) 'TKR2QM -- Direct QM/MM electrostatics not ', + & 'compatible with MM multipoles' + call fatal + end if + if (qmline(1:7) .ne. 'NOTHING') then + write(iout,*) qmline + write (iout,*) 'TKR2QM -- QMMM-EXTERNAL keyword found. Abort' + call fatal + end if + do i = 1, n + if (mod(qmmm(i),3) .eq. 0 .and. atinqm(i) .ne. 0 + & .and. (use_chgdpl .or. use_dipole)) then + write (iout,*) ' TKR2QM -- cannot include MM/Y atoms', + & 'carrying bond dipole in the QM input. Abort' + call fatal + end if + end do +c +c Prepares a QMprog input. Store it in file named "Project.qmmm" +c + if (.not. do_calc) then + write(iout,*) + write(iout,*) 'Tinker is preparing a QM input' + write(iout,20) nbinqm,QMprog(1:ll) + 20 format(' ->',i5,' atoms are transfered to ',a10) + imin = freeunit () + minfile = filename(1:leng)//'.qmmm' + open (unit=imin,file=minfile,status='unknown') + rewind (unit=imin) + write(imin,'(i10)') nAtInQM + write(imin,'(a8)') 'Angstrom' + do j = 1, nbinqm + i = 1 + do while (j .ne. atinqm(i) .and. i .le. n) + i = i + 1 + end do + MMsymbol = ' ' + if (qmmm(i) .eq. 0) MMsymbol = '_MM' + write(imin,'(a2,a3,x,3f12.6)') zsymbol(atomic(i)), + & MMSymbol(1:3),x(i),y(i),z(i) + end do + close(unit=imin) + goto 9999 + end if +c +c Update the coordinates and multipoles carried by QMMM atoms +c + write(iout,30) + & ' Coordinates/multipoles updated from '//QMprog(1:ll) + 30 format(/,a) + if (use_charge .and. MltOrd .eq. 1) write(iout,*) + & 'Warning: get only the ESPF charges, not the dipoles' + call update_qmmm(QMcoord,QMmult,.false.) +c +c MM microiterations and/or MD +c + domicro = micromode .gt. 0 + domicro = domicro .and. do_relax + if (domicro) then + write(iout,33) + 33 format (/,'Minimizing the MM subsystem energy') + call minimizeMM() + end if + dorunmd = dorunmd .and. do_relax + if (dorunmd) then + write(iout,36) + 36 format (/,'MD sampling of the MM subsystem') + write(iout,*) '... skipped (NYI)' +c call MDinMM() + end if + call update_qmmm(QMcoord,QMmult,.true.) +c +c MM energy + gradient block +c + write(iout,40) + & ' Tinker is computing the MM contribution to the QM/MM energy', + & ' and the MM contributions to the gradient' + 40 format(/,a,/,a) + call qmmm_eg(QMMM_energy,QMMM_gradient) +c +c QM/MM electrostatics +c + nComp = 4 + if (doespf) nComp = nComp + 6*MltOrd + nCenter = n + if (doespf) nCenter = nbinqm + if (elec_cpl .ne. -1) then + call extpot(nComp,nCenter,QMMM_extpot) + end if +c +c QM/MM post-processing +c + call qmmm_post(do_relax,nMM,MMatnum,MMcoord,nLAH,QMMM_laha, + & QMMM_lahg) +c +c perform any final tasks before program exit +c + 9999 if (.not. is_syscall) call final + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/tkr2qm_s.f 6.2.06/source/tkr2qm_s.f --- 6.2.06/source_orig/tkr2qm_s.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/tkr2qm_s.f 2014-02-18 10:13:27.596108542 +0100 @@ -0,0 +1,265 @@ +cqmmm +c tkr2qm_s is the superdriver for tkr2qm. +c For QM/MM calculations, tkr2qm_s is the main bridge between any QM program and Tinker. +c See tkr2qm.f for a detailed explanation of the exchanged data. + program tkr2qm_s + implicit none + include 'sizes.i' + include 'argue.i' + include 'atoms.i' + include 'charge.i' + include 'files.i' + include 'inform.i' + include 'iounit.i' + include 'qmmm.i' +c + character*120 Project + character*120 QMprog + integer nAtInQM,MltOrd,elec_cpl,nMM,nLAH + integer, dimension(:), allocatable :: MMatnum + integer, dimension(:,:), allocatable :: QMMM_laha + logical is_syscall + logical do_calc,do_relax + real*8 QMMM_energy + real*8, dimension(:,:), allocatable :: QMcoord,QMmult + real*8, dimension(:,:), allocatable :: QMMM_gradient,QMMM_extpot + real*8, dimension(:,:), allocatable :: MMcoord + real*8, dimension(:), allocatable :: QMMM_lahg +c + character*20 keyword + character*120 minfile + character*120 record + character*120 string + integer iAlloc,freeunit,imin,next,iNum,i,ii,j,extpotSize + logical found + 999 format(/,' Not enough memory for allocating ',a,'. Abort') + 1000 format(a20) + 1001 format(a20,f20.8) + 1004 format(a20,4f20.8) + 1010 format(a20,i5) + 1013 format(a20,i5,3f20.8) + 1014 format(a20,i5,4f20.8) + 1020 format(a20,2i5) + 1031 format(a20,3i5,f20.8) + 1110 format(a20,i5,a20) +c +c +c Initialization +c + call initial + is_syscall = .true. + Project = "XXX" + nAtInQM = 0 + QMprog = "XXX" + MltOrd = -99 + do_calc = .false. + do_relax = .false. + elec_cpl = 0 +c +c Name of the project +c + narg = 1 + listarg(1) = .true. + Project = arg(1) + call getxyz + nAtinQM = nbinqm +c +c Get info/data from Project.qmmm +c + found = .false. + imin = freeunit () + minfile = filename(1:leng)//'.qmmm' + inquire (file=minfile,exist=found) + if (.not.found) then + write (iout,10) minfile + 10 format(/,' TKR2QM_S -- File not found: ',a120) + call fatal + end if + open (unit=imin,file=minfile,status='old') + rewind (unit=imin) + read (imin,11,end=90,err=91) record + 11 format(a120) + next = 1 + call gettext (record,keyword,next) + call tk_upcase(keyword) + QMprog = keyword + call gettext (record,string,next) + read (string,*) iNum + do_calc = (iNum .ne. -1) + do_relax = (iNum .ne. 0) + call gettext (record,string,next) + read (string,*) iNum + MltOrd = iNum + allocate(QMcoord(3,nAtInQM),stat=iAlloc) + if (iAlloc .ne. 0) then + write(iout,999) 'QMcoord' + call fatal + end if + allocate(QMmult(4,nAtInQM),stat=iAlloc) + if (iAlloc .ne. 0) then + write(iout,999) 'QMmult' + call fatal + end if + do i = 1, nAtInQM + QMcoord(1,i) = 0.0d0 + QMcoord(2,i) = 0.0d0 + QMcoord(3,i) = 0.0d0 + QMmult(1,i) = 0.0d0 + QMmult(2,i) = 0.0d0 + QMmult(3,i) = 0.0d0 + QMmult(4,i) = 0.0d0 + end do + if (.not. do_calc) goto 90 +c +c Continue only if some calcs have to be done +c + do j = 1, nbinqm + read (imin,*,end=91,err=91) QMcoord(1,j),QMcoord(2,j), + & QMcoord(3,j) + end do + read (imin,11,end=90,err=91) record + next = 1 + call gettext (record,keyword,next) + call tk_upcase(keyword) + if (keyword(1:10) .eq. 'MULTIPOLES') then + do j = 1, nbinqm + read (imin,*,end=90,err=91) i,QMmult(1,i),QMmult(2,i), + & QMmult(3,i),QMmult(4,i) + end do + end if + 90 close (unit=imin) + goto 99 + 91 write (iout,92) minfile,string + 92 format(/,' Error when reading ',a120,/,' Last string was: ',/, + & a120) + call fatal + 99 continue +c +c Allocations +c + allocate(QMMM_gradient(3,nAtInQM),stat=iAlloc) + if (iAlloc .ne. 0) then + write(iout,999) 'QMMM_gradient' + call fatal + end if + if (MltOrd .ge. 0) then + extpotSize = 4 + 6*MltOrd + allocate(QMMM_extpot(extpotSize,nAtInQM),stat=iAlloc) + else + extpotSize = 4 + allocate(QMMM_extpot(extpotSize,n),stat=iAlloc) + end if + if (iAlloc .ne. 0) then + write(iout,999) 'QMMM_extpot' + call fatal + end if + nMM = n - nAtInQM + allocate(MMatnum(nMM),stat=iAlloc) + if (iAlloc .ne. 0) then + write(iout,999) 'MMatnum' + call fatal + end if + allocate(MMcoord(3,nMM),stat=iAlloc) + if (iAlloc .ne. 0) then + write(iout,999) 'MMcoord' + call fatal + end if + allocate(QMMM_laha(3,maxy),stat=iAlloc) + if (iAlloc .ne. 0) then + write(iout,999) 'QMMM_laha' + call fatal + end if + allocate(QMMM_lahg(maxy),stat=iAlloc) + if (iAlloc .ne. 0) then + write(iout,999) 'QMMM_lahg' + call fatal + end if +c +c Call to tkr2qm +c + call tkr2qm(is_syscall,Project,nAtInQM,QMprog,QMcoord,MltOrd, + & QMmult,do_calc,do_relax,QMMM_energy,QMMM_gradient, + & QMMM_extpot,nMM,MMatnum,MMcoord,nLAH,QMMM_laha, + & QMMM_lahg,elec_cpl) +c +c Write info/data in Project.qmmm +c + if (do_calc) then + imin = freeunit () + open (unit=imin,file=minfile,status='old') + rewind (unit=imin) + write(imin,1000) 'MMisOK' + if (elec_cpl .eq. 1) write(imin,1000) 'FullCoupling ' + write(imin,1001) 'MMEnergy ',QMMM_energy + do i = 1, nAtInQM + write(imin,1013) 'MMGradient ',i,QMMM_gradient(1,i), + & QMMM_gradient(2,i), + & QMMM_gradient(3,i) + if (MltOrd .ge. 0) then + write(imin,1014) 'ESPF1 ',i,QMMM_extpot(1,i), + & QMMM_extpot(2,i), + & QMMM_extpot(3,i), + & QMMM_extpot(4,i) + end if + if (MltOrd .gt. 0) then + write(imin,1013) 'ESPF21 ',i,QMMM_extpot(5,i), + & QMMM_extpot(6,i), + & QMMM_extpot(7,i) + write(imin,1013) 'ESPF22 ',i,QMMM_extpot(8,i), + & QMMM_extpot(9,i), + & QMMM_extpot(10,i) + end if + end do + if (MltOrd .lt. 0) then + j = nion + do i = 1, nion + ii = iion(i) + if (mod(qmmm(ii),3) .ne. 0) j = j - 1 + end do + write(imin,1010) 'MMq ',j + do i = 1, nion + ii = iion(i) + j = mod(qmmm(ii),3) + if (j .eq. 0) + & write(imin,1004) ' ',QMMM_extpot(1,i),QMMM_extpot(2,i), + & QMMM_extpot(3,i),QMMM_extpot(4,i) + end do + end if +c +c What about MM atoms? +c + write(imin,1010) 'NMM ',nMM + do i = 1, nMM + write(imin,1013) 'MMCoord ',MMatnum(i),MMcoord(1,i), + & MMcoord(2,i),MMcoord(3,i) + end do +c +c What about Link atoms? +c + do i = 1, nLAH + write (imin,1031) 'LAH ',QMMM_laha(1,i),QMMM_laha(2,i), + & QMMM_laha(3,i),QMMM_lahg(i) + end do +c +c What about LSCF hybrid atoms? +c + do i = 1, nybond + write (imin,1020) 'YBond ',iybond(1,i),iybond(2,i) + end do +c + write(imin,1000) 'TheEnd ' + close (unit=imin) + end if +c +c Deallocations +c + deallocate(QMcoord) + deallocate(QMmult) + deallocate(QMMM_gradient) + deallocate(QMMM_extpot) + deallocate(MMatnum) + deallocate(MMcoord) + deallocate(QMMM_laha) + deallocate(QMMM_lahg) + call final + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/tncg.f 6.2.06/source/tncg.f --- 6.2.06/source_orig/tncg.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/tncg.f 2013-10-23 11:36:27.067130195 +0200 @@ -189,7 +189,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:7) .eq. 'FCTMIN ') then read (string,*,err=20,end=20) fctmin diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/torsions.f 6.2.06/source/torsions.f --- 6.2.06/source_orig/torsions.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/torsions.f 2013-10-21 18:20:56.497885303 +0200 @@ -25,6 +25,10 @@ include 'tors.i' integer i,j,k integer ia,ib,ic,id +cqmmm +! include 'angle.i' +! include 'qmmm.i' +! integer ii,iix c c c loop over all bonds, storing the atoms in each torsion @@ -55,5 +59,43 @@ end if end do end do +cqmmm !! Was in the previous code, need to know why !! +cqmmm Torsions with only one mm atom are added +! do i = 1, nangle +! ia = iang(1,i) +! ib = iang(2,i) +! ic = iang(3,i) +! if(qmmm(ia).eq.2 .and. qmmm(ib).ge.2) then +! do ii = 1, n12(ia) +! iix = i12(ii,ia) +! if (iix.ne.ib .and. iix.ne.ic) then +! ntors = ntors + 1 +! if (ntors .gt. maxtors) then +! write (iout,10) +! call fatal +! end if +! itors(1,ntors) = iix +! itors(2,ntors) = ia +! itors(3,ntors) = ib +! itors(4,ntors) = ic +! end if +! end do +! else if(qmmm(ib).ge.2 .and. qmmm(ic).eq.2) then +! do ii = 1, n12(ic) +! iix = i12(ii,ic) +! if (iix.ne.ia .and. iix.ne.ib) then +! ntors = ntors + 1 +! if (ntors .gt. maxtors) then +! write (iout,10) +! call fatal +! end if +! itors(1,ntors) = ia +! itors(2,ntors) = ib +! itors(3,ntors) = ic +! itors(4,ntors) = iix +! end if +! end do +! end if +! end do return end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/trimtext.f 6.2.06/source/trimtext.f --- 6.2.06/source_orig/trimtext.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/trimtext.f 2013-10-23 11:36:27.067130195 +0200 @@ -105,17 +105,17 @@ end c c -c ############################################################### -c ## ## -c ## subroutine upcase -- convert string to all upper case ## -c ## ## -c ############################################################### +c ################################################################## +c ## ## +c ## subroutine tk_upcase -- convert string to all upper case ## +c ## ## +c ################################################################## c c -c "upcase" converts a text string to all upper case letters +c "tk_upcase" converts a text string to all upper case letters c c - subroutine upcase (string) + subroutine tk_upcase (string) implicit none integer i,size,len integer code,ichar diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/unitcell.f 6.2.06/source/unitcell.f --- 6.2.06/source_orig/unitcell.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/unitcell.f 2013-10-23 11:36:27.067130195 +0200 @@ -57,7 +57,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:7) .eq. 'X-AXIS ') then read (string,*,err=10,end=10) xbox diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/update_qmmm.f 6.2.06/source/update_qmmm.f --- 6.2.06/source_orig/update_qmmm.f 1970-01-01 01:00:00.000000000 +0100 +++ 6.2.06/source/update_qmmm.f 2013-10-30 14:28:30.251847142 +0100 @@ -0,0 +1,129 @@ +cqmmm +c +c Update the coordinates/multipoles of QMMM atoms +c + subroutine update_qmmm(QMcoord,QMmult,do_restore) + implicit none + include 'sizes.i' + include 'atoms.i' + include 'charge.i' + include 'inform.i' + include 'iounit.i' + include 'mpole.i' + include 'polar.i' + include 'potent.i' + include 'qmmm.i' + include 'usage.i' + integer i,j,k,kk,l,iqmmm + logical found,do_restore + real*8 QMcoord(3,nbinqm),QMmult(4,nbinqm) + real*8 summu +c + if (do_restore) then + e4qmmm = 0 + do i = 1, n + if (atinqm(i) .ne. 0 .and. .not.use(i)) then + use(i) = .true. + nuse = nuse + 1 + end if + end do + if (use_charge) then + do k = 1, nion + kk = iion(k) + j = atinqm(kk) + if (qmmm(kk) .eq. 3) pchg(k) = pchg(k) - QMmult(1,j) + end do + else if (use_polar .or. use_mpole) then + do k = 1, npole + kk = ipole(k) + j = atinqm(kk) + if (qmmm(kk) .eq. 3) then + pole(1,k) = pole(1,k) - QMmult(1,j) + pole(2,k) = pole(2,k) - QMmult(2,j) + pole(3,k) = pole(3,k) - QMmult(3,j) + pole(4,k) = pole(4,k) - QMmult(4,j) + end if + end do + end if + return + end if +c + e4qmmm = 3 + do j = 1, nbinqm + found = .false. + i = 0 + do while (.not. found .and. i .lt. n) + i = i + 1 + found = atinqm(i) .eq. j + end do + if (.not. found) then + write (iout,10) j + 10 format(' UPDATE_QMMM -- ',i3,'th QM atom has no Tinker ', + & ' equivalent') + call fatal + end if + x(i) = QMcoord(1,j) + y(i) = QMcoord(2,j) + z(i) = QMcoord(3,j) + iqmmm = qmmm(i) + if (verbose) write (iout,11) i,x(i),y(i),z(i) + 11 format(' Atom ',i4,' (x,y,z) = ',3f10.5) + if (use_charge .or. use_chgdpl .or. use_dipole) then + do k = 1, nion + kk = iion(k) + if (i .eq. kk .and. iqmmm .ne. 0) then + summu = abs(QMmult(2,j)) + abs(QMmult(3,j)) + & + abs(QMmult(4,j)) + if (summu .ne. 0.0d0 .and. + & (use_chgdpl .or. use_dipole)) then + write (iout,*) ' UPDATE_QMMM -- cannot afford', + & ' QM-derived two-center dipole' + call fatal + end if + if (iqmmm .eq. 3) then + pchg(k) = pchg(k) + QMmult(1,j) + else + pchg(k) = QMmult(1,j) + end if + if (verbose) write (iout,12) pchg(k) + 12 format(' q = ',f8.3) + end if + end do + else if (use_polar .or. use_mpole) then + do k = 1, npole + kk = ipole(k) + if (i .eq. kk .and. iqmmm .ne. 0) then + if (iqmmm .eq. 3) then + pole(1,k) = pole(1,k) + QMmult(1,j) + pole(2,k) = pole(2,k) + QMmult(2,j) + pole(3,k) = pole(3,k) + QMmult(3,j) + pole(4,k) = pole(4,k) + QMmult(4,j) + else + pole(1,k) = QMmult(1,j) + pole(2,k) = QMmult(2,j) + pole(3,k) = QMmult(3,j) + pole(4,k) = QMmult(4,j) + end if + do l = 5, maxpole + pole(l,k) = 0.0d0 + enddo + if (verbose) write (iout,13) pole(1,k),pole(2,k), + & pole(3,k),pole(4,k) + 13 format(' q = ',f8.3, + & /,' (mux,muy,muz) = ',3f8.3) + end if + end do + end if + end do +c +c Desactivate any atom defined in QMprog +c + do i = 1, n + if (atinqm(i) .ne. 0 .and. use(i)) then + use(i) = .false. + nuse = nuse - 1 + end if + end do +c + return + end diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/valence.f 6.2.06/source/valence.f --- 6.2.06/source_orig/valence.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/valence.f 2013-10-23 11:36:27.067130195 +0200 @@ -135,7 +135,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'FIT-BOND ') then fit_bond = .true. diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/vibbig.f 6.2.06/source/vibbig.f --- 6.2.06/source_orig/vibbig.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/vibbig.f 2013-10-23 11:36:27.067130195 +0200 @@ -113,7 +113,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:8) .eq. 'MAXITER ') then read (string,*,err=10,end=10) maxiter @@ -142,7 +142,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) if (answer .eq. 'H') factor = -1.0d0 c c find cutoff value for desired extreme frequency diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/vibrate.f 6.2.06/source/vibrate.f --- 6.2.06/source_orig/vibrate.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/vibrate.f 2013-10-23 11:36:27.067130195 +0200 @@ -196,7 +196,7 @@ if (exist) then query = .false. letter = string(1:1) - call upcase (letter) + call tk_upcase (letter) if (letter .eq. 'A') then nlist = nvib do i = 1, nlist @@ -236,7 +236,7 @@ letter = ' ' next = 1 call gettext (record,letter,next) - call upcase (letter) + call tk_upcase (letter) if (letter .eq. ' ') then nlist = 0 else if (letter .eq. 'A') then diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/xtalmin.f 6.2.06/source/xtalmin.f --- 6.2.06/source_orig/xtalmin.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/xtalmin.f 2013-10-23 11:36:27.067130195 +0200 @@ -60,7 +60,7 @@ next = 1 record = keyline(i) call gettext (record,keyword,next) - call upcase (keyword) + call tk_upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=10,end=10) iprint diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/xyzedit.f 6.2.06/source/xyzedit.f --- 6.2.06/source_orig/xyzedit.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/xyzedit.f 2013-10-23 11:36:27.071130196 +0200 @@ -32,6 +32,13 @@ include 'titles.i' include 'units.i' include 'usage.i' +cqmmm + include 'bond.i' + include 'charge.i' + include 'fields.i' + include 'potent.i' + include 'qmmm.i' +cqmmm integer i,j,k,m integer it,ixyz integer init,stop @@ -57,6 +64,29 @@ real*8 a(3,3) real*8, allocatable :: rad(:) logical write +cqmmm + character qmmm_symbol + logical add1la + integer iqm,imm,nold,iinput + real*8 xlink,ylink,zlink,xqm,yqm,zqm,xmm,ymm,zmm,qi,kla + character*10 iname + character*2 zsymbol(0:103) + save zsymbol + data zsymbol/ + & ' X', + & ' H','He','Li','Be',' B',' C',' N',' O',' F','Ne', + & 'Na','Mg','Al','Si',' P',' S','Cl','Ar',' K','Ca', + & 'Sc','Ti',' V','Cr','Mn','Fe','Co','Ni','Cu','Zn', + & 'Ga','Ge','As','Se','Br','Kr','Rb','Sr',' Y','Zr', + & 'Nb','Mo','Tc','Ru','Rh','Pd','Ag','Cd','In','Sn', + & 'Sb','Te',' I','Xe','Cs','Ba','La','Ce','Pr','Nd', + & 'Pm','Sm','Eu','Gd','Tb','Dy','Ho','Er','Tm','Yb', + & 'Lu','Hf','Ta',' W','Re','Os','Ir','Pt','Au','Hg', + & 'Tl','Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th', + & 'Pa',' U','Np','Pu','Am','Cm','Bk','Cf','Es','Fm', + & 'Md','No','Lr' + & / +cqmmm character*120 xyzfile character*120 record external merge @@ -102,12 +132,19 @@ & /,3x,'(16) Delete Molecules outside of Periodic Box', & /,3x,'(17) Create and Fill a Periodic Boundary Box', & /,3x,'(18) Soak Current Molecule in Box of Solvent', - & /,3x,'(19) Append a Second XYZ File to Current One') +cqmmm + & /,3x,'(19) Append a Second XYZ File to Current One', + & /,3x,'(20) Prepare a QM/MM input (G09/Tinker)', + & /,3x,'(21) Prepare a QM/MM input (Molcas/Tinker)', + & /,3x,'(22) Dump the inactive point charges') +cqmmm c c get the desired type of coordinate file modification c 20 continue - nmode = 19 +cqmmm + nmode = 22 +cqmmm mode = -1 do while (mode.lt.0 .or. mode.gt.nmode) mode = 0 @@ -149,7 +186,7 @@ if (list(i) .gt. n) list(i) = n if (list(i) .lt. -n) list(i) = -n end do - call sort4 (nlist,list) + call tk_sort4 (nlist,list) do i = nlist, 1, -1 if (i .gt. 1) then if (list(i-1) .lt. 0) then @@ -262,7 +299,7 @@ do while (list(nlist+1) .ne. 0) nlist = nlist + 1 end do - call sort4 (nlist,list) + call tk_sort4 (nlist,list) do i = nlist, 1, -1 if (i .gt. 1) then if (list(i-1) .lt. 0) then @@ -349,7 +386,7 @@ end do end do do i = 1, n - call sort (n12(i),i12(1,i)) + call tk_sort (n12(i),i12(1,i)) end do write = .true. goto 20 @@ -648,6 +685,264 @@ write = .true. goto 20 end if +cqmmm +c +c prepare QM/MM inputs for G03/09 or Molcas +c + if (mode .eq. 20 .or. mode .eq. 21) then + call mechanic + nold = n +c +c step 1: find the missing link atoms +c + do i = 1, nbond + add1la = .false. + if(qmmm(ibnd(1,i)).eq.0 .and. qmmm(ibnd(2,i)).eq.2) then + iqm = ibnd(2,i) + imm = ibnd(1,i) + xqm = x(iqm) + yqm = y(iqm) + zqm = z(iqm) + xmm = x(imm) + ymm = y(imm) + zmm = z(imm) + kla = (rcov(atomic(iqm))+rcov(1))/ + & (rcov(atomic(iqm))+rcov(atomic(imm))) + xlink = xqm + kla*(xmm-xqm) + ylink = yqm + kla*(ymm-yqm) + zlink = zqm + kla*(zmm-zqm) + add1la = .true. + do j = 1, n + if ((qmmm(j).eq.1).and.(i12(1,j).eq.imm).and. + & (i12(2,j).eq.iqm)) add1la = .false. + end do + end if + if(qmmm(ibnd(1,i)).eq.2 .and. qmmm(ibnd(2,i)).eq.0) then + iqm = ibnd(1,i) + imm = ibnd(2,i) + xqm = x(iqm) + yqm = y(iqm) + zqm = z(iqm) + xmm = x(imm) + ymm = y(imm) + zmm = z(imm) + kla = (rcov(atomic(iqm))+rcov(1))/ + & (rcov(atomic(iqm))+rcov(atomic(imm))) + xlink = xqm + kla*(xmm-xqm) + ylink = yqm + kla*(ymm-yqm) + zlink = zqm + kla*(zmm-zqm) + add1la = .true. + do j = 1, n + if ((qmmm(j).eq.1).and.(i12(1,j).eq.imm).and. + & (i12(2,j).eq.iqm)) add1la = .false. + end do + end if + if (add1la) then + n = n + 1 + nbinqm = nbinqm + 1 + atinqm(n) = nbinqm + x(n) = xlink + y(n) = ylink + z(n) = zlink + type(n) = 2999 + class(n) = 99 + qmmm(n) = 1 + n12(n) = 0 + i12(1,n) = imm + i12(2,n) = iqm + name(n) = 'HLA' + atomic(n) = 1 + end if + end do +c +c step 2: the .xyz file (if some HLA have been added) +c + if (nold .ne. n) then + ixyz = freeunit () + xyzfile = filename(1:leng)//'.xyz' + call version (xyzfile,'new') + open(unit=ixyz,file=xyzfile,status='new') + if (ltitle .eq. 0) then + write (ixyz,450) n + 450 format (i6) + else + write (ixyz,460) n,title(1:ltitle) + 460 format (i6,2x,a) + end if + do i = 1, n + if (qmmm(i).eq.1) n12(i) = 2 + write(ixyz,480) i,name(i),x(i),y(i),z(i), + & type(i),(i12(j,i),j=1,n12(i)) + 480 format(i5,x,a3,3f12.6,5i6) + if (qmmm(i).eq.1) n12(i) = 0 + end do + close(unit=ixyz) + end if +c +c step 3: the g03/09 file +c + if (mode .eq. 20) then + ixyz = freeunit () + xyzfile = 'Gau_'//filename(1:leng)//'.com' + call version (xyzfile,'new') + open(unit=ixyz,file=xyzfile,status='new') + write(ixyz,500) filename(1:leng) + 500 format('%SUBST L101 ',/, + & '%SUBST L301 ',/, + & '%SUBST L302 ',/, + & '%SUBST L397 ',/, + & '%SUBST L701 ',/, + & '%CHK=',a,/, + & '%MEM=',/, + & '#P KEYWORDS HERE',/, + & ' NoSym QMMM=(LinkAtom1,Tinker1)',/,/, + & ' TITLE HERE',/,/ + & ' CHARGE & MULTIPLICITY HERE') + do j = 1, nbinqm + i = 0 + 501 i = i + 1 + if (atinqm(i).eq.j) goto 502 + if (i.gt.n) then + write (iout,503) j + 503 format(' No Tinker atom associated with the ',i4, + & 'th QM code atom !') + call fatal + end if + goto 501 + 502 continue + if (qmmm(i).eq.0) then + qmmm_symbol = 'L' + else if (qmmm(i).eq.1) then + qmmm_symbol = 'M' + else if (qmmm(i).eq.2) then + qmmm_symbol = 'H' + else if (qmmm(i).eq.3) then + qmmm_symbol = 'M' + end if + write(ixyz,520) zsymbol(atomic(i)),0,x(i),y(i),z(i), + & qmmm_symbol + 520 format(a2,i3,3(f10.5,2x),a1) + end do + write(ixyz,540) filename(1:leng),n + 540 format(/,a,x,i7) + write(ixyz,560) + 560 format(/,/) + close(unit=ixyz) + write(iout,599) + 599 format(/,' Do not forget to finish the set-up of G03 !') +c +c step 3': the Molcas file +c + else + ixyz = freeunit () + xyzfile = filename(1:leng)//'.input' + call version (xyzfile,'new') + open(unit=ixyz,file=xyzfile,status='new') + write(ixyz,600) + 600 format('&Gateway') + write (iout,601) + 601 format(/,' Standard (0, default) or older (1) input : ',$) + iinput = 0 + read (input,602) iinput + 602 format (i10) + if (iinput .eq. 0) then + write(ixyz,605) filename(1:leng) + 605 format( ' Tinker',/,' Group = NoSym',/,' Basis = ',/, + & /,'&Seward',/,' Title = QM/MM ',a,/, + & /,'&Espf',/,' External = Tinker') + else + do j = 1, nbinqm + i = 0 + 611 i = i + 1 + if (atinqm(i).eq.j) goto 612 + if (i.gt.n) then + write (iout,613) j + 613 format(' No Tinker atom associated with the ',i4, + & 'th QM code atom !') + call fatal + end if + goto 611 + 612 continue + iname = zsymbol(atomic(i))//' ' + if (j .lt. 10) then + write(iname(3:3),'(i1)') j + else if (j .ge. 10 .and. j .lt. 100) then + write(iname(3:4),'(i2)') j + else if (j .ge. 100 .and. j .lt. maxqmmm) then + write(iname(3:5),'(i3)') j + else + write(iout,*) 'XYZEDIT -- Too much QM/MM atoms' + write(iout,*) 'XYZEDIT -- Increase maxqmmm in qmmm.i' + call fatal + end if + if (qmmm(i).eq.0) then + qi = 0.0d0 + if (use_charge) then + do k = 1, nion + if (i .eq. iion(k)) qi = pchg(k) + end do + end if + write(ixyz,614) zsymbol(atomic(i)),iname, + & x(i),y(i),z(i),qi + 614 format(' Basis set',/, + & a2,'...... / MM',/, + & a10,3f12.6,' Angstrom',/, + & ' Charge = ',f12.6,/ + & ' End of Basis') + else if (qmmm(i).eq.1 .or .qmmm(i) .eq. 2) then + write(ixyz,615) zsymbol(atomic(i)),iname, + & x(i),y(i),z(i) + 615 format(' Basis set',/, + & a2,'......',/, + & a10,3f12.6,' Angstrom',/, + & ' End of Basis') + else if (qmmm(i).eq.3) then + write (iout,619) + 619 format(' LSCF method is not available in Molcas') + call fatal + end if + end do + write(ixyz,630) filename(1:leng) + 630 format(/,/,'&Seward',/,' Title = QM/MM ',a,/,/, + & '&Espf',/,' External = @tinker') + end if + close(unit=ixyz) + write(iout,700) + 700 format(/,' Do not forget to finish the set-up of Molcas !') + end if + if (nold.ne.n) write(iout,800) filename(1:leng)//'.key', + & n-nold + 800 format(' Please update the QMMM keyword in ',a,':',/,i2, + & ' Link Atoms (LA) has been added to the xyz file !') + write = .false. + end if +c +c dump the inactive point charges together with their coordinates +c + if (mode .eq. 22) then + call mechanic + ixyz = freeunit () + xyzfile = filename(1:leng)//'.q' + call version (xyzfile,'new') + open(unit=ixyz,file=xyzfile,status='new') + write(ixyz,900) nion-nbinqm + 900 format(i5,' 0 0 0 0 Angstrom') + qi = 0.0d0 + do i = 1, nion + k = iion (i) + if (atinqm(k) .eq. 0) then + write (ixyz,910) x(k), y(k), z(k), pchg(i) + qi = qi + pchg(i) + end if + 910 format(4f12.6) + end do + close(unit=ixyz) + write(iout,920) nion-nbinqm,qi,filename(1:leng)//'.q' + 920 format(i6, ' charges have been dumped (total charge = ',f7.3, + & ')',/,' Please check the number of point charges in ',a) + write = .false. + end if +cqmmm c c perform deallocation of some local arrays c diff -Nu -x '*~' -x '*.o' 6.2.06/source_orig/xyzint.f 6.2.06/source/xyzint.f --- 6.2.06/source_orig/xyzint.f 2013-07-14 04:23:55.000000000 +0200 +++ 6.2.06/source/xyzint.f 2013-10-23 11:36:27.071130196 +0200 @@ -48,7 +48,7 @@ next = 1 call gettext (record,answer,next) end if - call upcase (answer) + call tk_upcase (answer) mode = 0 if (answer .eq. 'M') then mode = 1