c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module action -- total number of each energy term type ## c ## ## c ################################################################ c c c neb number of bond stretch energy terms computed c nea number of angle bend energy terms computed c neba number of stretch-bend energy terms computed c neub number of Urey-Bradley energy terms computed c neaa number of angle-angle energy terms computed c neopb number of out-of-plane bend energy terms computed c neopd number of out-of-plane distance energy terms computed c neid number of improper dihedral energy terms computed c neit number of improper torsion energy terms computed c net number of torsional energy terms computed c nept number of pi-system torsion energy terms computed c nebt number of stretch-torsion energy terms computed c neat number of angle-torsion energy terms computed c nett number of torsion-torsion energy terms computed c nev number of van der Waals energy terms computed c ner number of Pauli repulsion energy terms computed c nedsp number of dispersion energy terms computed c nec number of charge-charge energy terms computed c necd number of charge-dipole energy terms computed c ned number of dipole-dipole energy terms computed c nem number of multipole energy terms computed c nep number of polarization energy terms computed c nect number of charge transfer energy terms computed c new number of Ewald summation energy terms computed c nerxf number of reaction field energy terms computed c nes number of solvation energy terms computed c nelf number of metal ligand field energy terms computed c neg number of geometric restraint energy terms computed c nex number of extra energy terms computed c c module action implicit none integer neb,nea,neba,neub integer neaa,neopb,neopd integer neid,neit,net,nept integer nebt,neat,nett,nev integer ner,nedsp,nec,necd integer ned,nem,nep,nect integer new,nerxf,nes,nelf integer neg,nex save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################### c ## ## c ## subroutine active -- set the list of active atoms ## c ## ## c ########################################################### c c c "active" sets the list of atoms that are used during c coordinate manipulation or potential energy calculations c c subroutine active use atoms use inform use iounit use keys use usage implicit none integer i,j,next integer nmobile,nfixed integer center,nsphere integer, allocatable :: mobile(:) integer, allocatable :: fixed(:) real*8 xcenter,ycenter,zcenter real*8 radius,radius2,dist2 character*20 keyword character*240 record character*240 string logical header c c c perform dynamic allocation of some global arrays c if (allocated(iuse)) deallocate (iuse) if (allocated(use)) deallocate (use) allocate (iuse(n)) allocate (use(0:n)) c c perform dynamic allocation of some local arrays c allocate (mobile(n)) allocate (fixed(n)) c c set defaults for the numbers and lists of active atoms c nuse = n use(0) = .false. do i = 1, n use(i) = .true. end do nmobile = 0 nfixed = 0 do i = 1, n mobile(i) = 0 fixed(i) = 0 end do nsphere = 0 c c get any keywords containing active atom parameters c do j = 1, nkey next = 1 record = keyline(j) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) c c get any lists of atoms whose coordinates are active c if (keyword(1:7) .eq. 'ACTIVE ') then read (string,*,err=10,end=10) (mobile(i),i=nmobile+1,n) 10 continue do while (mobile(nmobile+1) .ne. 0) nmobile = nmobile + 1 end do c c get any lists of atoms whose coordinates are inactive c else if (keyword(1:9) .eq. 'INACTIVE ') then read (string,*,err=20,end=20) (fixed(i),i=nfixed+1,n) 20 continue do while (fixed(nfixed+1) .ne. 0) nfixed = nfixed + 1 end do c c get the center and radius of the sphere of active atoms c else if (keyword(1:14) .eq. 'ACTIVE-SPHERE ') then center = 0 xcenter = 0.0d0 ycenter = 0.0d0 zcenter = 0.0d0 radius = 0.0d0 read (string,*,err=30,end=30) xcenter,ycenter, & zcenter,radius 30 continue if (radius .eq. 0.0d0) then read (string,*,err=60,end=60) center,radius xcenter = x(center) ycenter = y(center) zcenter = z(center) end if nsphere = nsphere + 1 if (nsphere .eq. 1) then nuse = 0 do i = 1, n use(i) = .false. end do if (verbose) then write (iout,40) 40 format (/,' Spheres used to Select Active Atoms :', & //,3x,'Atom Center',11x,'Coordinates', & 12x,'Radius',6x,'# Active Atoms') end if end if radius2 = radius * radius do i = 1, n if (.not. use(i)) then dist2 = (x(i)-xcenter)**2 + (y(i)-ycenter)**2 & + (z(i)-zcenter)**2 if (dist2 .le. radius2) then nuse = nuse + 1 use(i) = .true. end if end if end do if (verbose) then write (iout,50) center,xcenter,ycenter, & zcenter,radius,nuse 50 format (2x,i8,6x,3f9.2,2x,f9.2,7x,i8) end if 60 continue end if end do c c remove active or inactive atoms not in the system c header = .true. do i = 1, n if (abs(mobile(i)) .gt. n) then mobile(i) = 0 if (header) then header = .false. write (iout,70) 70 format (/,' ACTIVE -- Warning, Illegal Atom Number', & ' in ACTIVE Atom List') end if end if end do header = .true. do i = 1, n if (abs(fixed(i)) .gt. n) then fixed(i) = 0 if (header) then header = .false. write (iout,80) 80 format (/,' ACTIVE -- Warning, Illegal Atom Number', & ' in INACTIVE Atom List') end if end if end do c c set active atoms to those marked as not inactive c i = 1 do while (fixed(i) .ne. 0) if (fixed(i) .gt. 0) then j = fixed(i) if (use(j)) then use(fixed(i)) = .false. nuse = nuse - 1 end if i = i + 1 else do j = abs(fixed(i)), abs(fixed(i+1)) if (use(j)) then use(j) = .false. nuse = nuse - 1 end if end do i = i + 2 end if end do c c set active atoms to only those marked as active c i = 1 do while (mobile(i) .ne. 0) if (i .eq. 1) then nuse = 0 do j = 1, n use(j) = .false. end do end if if (mobile(i) .gt. 0) then j = mobile(i) if (.not. use(j)) then use(j) = .true. nuse = nuse + 1 end if i = i + 1 else do j = abs(mobile(i)), abs(mobile(i+1)) if (.not. use(j)) then use(j) = .true. nuse = nuse + 1 end if end do i = i + 2 end if end do c c use logical array to set the list of active atoms c j = 0 do i = 1, n if (use(i)) then j = j + 1 iuse(j) = i end if end do c c output the final list of the active atoms c if (debug .and. nuse.gt.0 .and. nuse.lt.n) then write (iout,90) 90 format (/,' List of Active Atoms for Energy', & ' Calculations :',/) write (iout,100) (iuse(i),i=1,nuse) 100 format (3x,10i7) end if c c perform deallocation of some local arrays c deallocate (mobile) deallocate (fixed) return end c c c ############################################################### c ## COPYRIGHT (C) 1991 by Shawn Huston & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################### c c ############################################################# c ## ## c ## program alchemy -- perform free energy perturbation ## c ## ## c ############################################################# c c c "alchemy" computes the free energy difference corresponding c to a small perturbation by Boltzmann weighting the potential c energy difference over a number of sample states; current c version (incorrectly) considers the charge energy to be c intermolecular in finding the perturbation energies c c variables and parameters: c c nlamb number of lambda values for energy computation c delta step size for the perturbation in lambda c nstep number of steps over which to calculate averages c c deplus energy change for postive delta lambda c deminus energy change for negative delta lambda c sdep,sdem accumulated energy changes c adep,adem (running) average energy changes c adapb,adamb average over block averages of free energy changes c bdep,bdem (block) accumulated energy changes c badep,badem (block) average energy changes c vdep,vdem SD of energy changes from variance of subaverages c fdep,fdem fluctuations of perturbation energies c se_ap,se_am standard error of free energy changes c c program alchemy use analyz use atoms use energi use files use inform use iounit use katoms use mutant use potent use units use usage implicit none integer i,j,k,ixyz,start,stop integer lext,next,freeunit integer istep,ilamb,nlamb integer nstep,modstep integer nblock,modblock real*8 delta,lam0,lamp,lamm real*8 rt,e0,energy real*8 pos,neg,temp real*8 eplus,eminus real*8 deplus,deminus real*8 sdep,s2dep,sdep2 real*8 sdem,s2dem,sdem2 real*8 spos,bpos,sdapb real*8 sneg,bneg,sdamb real*8 bdep,adep,a2dep,adep2 real*8 bdem,adem,a2dem,adem2 real*8 da,dap,dam,adapb,adamb real*8 v,vdap,vdam,vdep,vdem real*8 fdep,fdem,bda real*8 se_ep,se_em,se_ap,se_am real*8 eb0,ebpos,ebneg real*8 ea0,eapos,eaneg real*8 eit0,eitpos,eitneg real*8 et0,etpos,etneg real*8 ev0,evpos,evneg real*8 ec0,ecpos,ecneg real*8 sbp,sap,sitp,stp,svp,scp real*8 sbm,sam,sitm,stm,svm,scm real*8 abp,aap,aitp,atp,avp,acp real*8 abm,aam,aitm,atm,avm,acm real*8, allocatable :: badep(:) real*8, allocatable :: badem(:) real*8, allocatable :: bdap(:) real*8, allocatable :: bdam(:) real*8, allocatable :: nrg(:,:) real*8, allocatable :: cb(:,:) real*8, allocatable :: ca(:,:) real*8, allocatable :: cit(:,:) real*8, allocatable :: ct(:,:) real*8, allocatable :: cv(:,:) real*8, allocatable :: cc(:,:) logical dogeom character*1 answer character*7 ext character*240 xyzfile character*240 record c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c get the numbers of the files to be used c start = 0 stop = 0 write (iout,10) 10 format (/,' Numbers of First and Last File to Analyze : ',$) read (input,20) record 20 format (a240) read (record,*,err=30,end=30) start,stop 30 continue if (start .eq. 0) start = 1 if (stop .eq. 0) stop = start nstep = stop - start + 1 c c obtain the lambda values to be calculated c delta = 0.0d0 write (iout,40) 40 format (/,' Enter the Lambda Increment for FEP : ',$) read (input,50) delta 50 format (f7.4) nlamb = 3 lam0 = lambda lamp = min(1.0d0,lambda+delta) lamm = max(0.0d0,lambda-delta) c c obtain the target temperature value c temp = 0.0d0 write (iout,60) 60 format (/,' Enter the System Temperature [300 K] : ',$) read (input,70) temp 70 format (f20.0) if (temp .eq. 0.0d0) temp = 300.0d0 rt = gasconst * temp c c set number of steps for running averages and block averages c nblock = 0 write (iout,80) 80 format (/,' Enter Number of Blocks for Sub-Averages [1] : ',$) read (input,90) nblock 90 format (i10) if (nblock .eq. 0) nblock = 1 nblock = nstep / nblock c c decide whether to include the intramolecular energies c dogeom = .true. write (iout,100) 100 format (/,' Consider only Intermolecular Perturbation', & ' Energy [N] : ',$) read (input,110) record 110 format (a240) next = 1 call gettext (record,answer,next) call upcase (answer) if (answer .eq. 'Y') dogeom = .false. if (dogeom) then write (iout,120) 120 format (/,' Calculation will Involve Full Perturbation', & ' Energy ') else write (iout,130) 130 format (/,' Calculation will Consider Only Intermolecular', & ' Interactions ') end if c c perform dynamic allocation of some local arrays c allocate (badep(nblock)) allocate (badem(nblock)) allocate (bdap(nblock)) allocate (bdam(nblock)) allocate (nrg(3,nstep)) allocate (cb(3,nstep)) allocate (ca(3,nstep)) allocate (cit(3,nstep)) allocate (ct(3,nstep)) allocate (cv(3,nstep)) allocate (cc(3,nstep)) c c zero out block average potential and free energy changes c do i = 1, nblock badep(i) = 0.0d0 badem(i) = 0.0d0 bdap(i) = 0.0d0 bdam(i) = 0.0d0 end do c c cycle over the coordinate files once per lambda value c do ilamb = 1, nlamb i = start istep = 0 if (ilamb .eq. 2) lambda = lamp if (ilamb .eq. 3) lambda = lamm call hybrid c c read in the next molecular dynamics coordinate frame c do while (i.ge.start .and. i.le.stop) istep = istep + 1 lext = 3 call numeral (i,ext,lext) xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'old') ixyz = freeunit () open (unit=ixyz,file=xyzfile,status='old',err=160) call readxyz (ixyz) close (unit=ixyz) call hatom c c select interactions for perturbation energy calculation c do j = 1, n use(j) = .false. end do do j = 1, nmut use(imut(j)) = .true. end do if (.not. dogeom) then use_bond = .false. use_angle = .false. use_strbnd = .false. use_urey = .false. use_imptor = .false. use_tors = .false. use_strtor = .false. end if c c compute and store energy components for the current lambda c nrg(ilamb,istep) = energy () cb(ilamb,istep) = eb ca(ilamb,istep) = ea cit(ilamb,istep) = eit ct(ilamb,istep) = et cv(ilamb,istep) = ev cc(ilamb,istep) = ec if (verbose) then if (istep .eq. 1) then write (iout,140) 140 format (/,2x,'Step',7x,'EB',9x,'EA',8x,'EIT', & 9x,'ET',10x,'EV',10x,'EC',/) end if write (iout,150) istep,eb,ea,eit,et,ev,ec 150 format (i6,4f11.4,2f12.4) end if 160 continue i = i + 1 end do end do nstep = istep c c get free energy change by averaging over all frames c do istep = 1, nstep e0 = nrg(1,istep) eplus = nrg(2,istep) eminus = nrg(3,istep) ev0 = cv(1,istep) evpos = cv(2,istep) evneg = cv(3,istep) ec0 = cc(1,istep) ecpos = cc(2,istep) ecneg = cc(3,istep) if (dogeom) then eb0 = cb(1,istep) ebpos = cb(2,istep) ebneg = cb(3,istep) ea0 = ca(1,istep) eapos = ca(2,istep) eaneg = ca(3,istep) eit0 = cit(1,istep) eitpos = cit(2,istep) eitneg = cit(3,istep) et0 = ct(1,istep) etpos = ct(2,istep) etneg = ct(3,istep) end if modstep = mod(istep-1,nstep) modblock = mod(istep-1,nblock) c c zero out summation variables for new running average c if (modstep .eq. 0) then sdep = 0.0d0 s2dep = 0.0d0 sdep2 = 0.0d0 sdem = 0.0d0 s2dem = 0.0d0 sdem2 = 0.0d0 spos = 0.0d0 sneg = 0.0d0 sdapb = 0.0d0 sdamb = 0.0d0 sbp = 0.0d0 sbm = 0.0d0 sap = 0.0d0 sam = 0.0d0 sitp = 0.0d0 sitm = 0.0d0 stp = 0.0d0 stm = 0.0d0 svp = 0.0d0 svm = 0.0d0 scp = 0.0d0 scm = 0.0d0 fdep = 0.0d0 fdem = 0.0d0 vdep = 0.0d0 vdem = 0.0d0 vdap = 0.0d0 vdam = 0.0d0 k = 0 end if c c zero out summation variables for new block average c if (modblock .eq. 0) then bdep = 0.0d0 bdem = 0.0d0 bpos = 0.0d0 bneg = 0.0d0 end if modstep = mod(istep,nstep) modblock = mod(istep,nblock) c c accumulate statistics c deplus = eplus - e0 deminus = eminus - e0 if (verbose) then if (modblock.eq.1 .or. nblock.eq.1) then write (iout,170) 170 format (/,2x,'Step',12x,'E0',11x,'EP',11x,'EM', & 11x,'DEP',10x,'DEM',/) end if write (iout,180) istep,e0,eplus,eminus,deplus,deminus 180 format (i6,3x,5f13.4) end if pos = exp(-deplus/rt) neg = exp(-deminus/rt) bdep = bdep + deplus bdem = bdem + deminus bpos = bpos + pos bneg = bneg + neg sdep = sdep + deplus sdem = sdem + deminus s2dep = s2dep + deplus*deplus s2dem = s2dem + deminus*deminus spos = spos + pos sneg = sneg + neg svp = svp + evpos - ev0 svm = svm + evneg - ev0 scp = scp + ecpos - ec0 scm = scm + ecneg - ec0 if (dogeom) then sbp = sbp + ebpos - eb0 sbm = sbm + ebneg - eb0 sap = sap + eapos - ea0 sam = sam + eaneg - ea0 sitp = sitp + eitpos - eit0 sitm = sitm + eitneg - eit0 stp = stp + etpos - et0 stm = stm + etneg - et0 end if c c calculate block averages c if (modblock .eq. 0) then k = k + 1 badep(k) = bdep / dble(nblock) badem(k) = bdem / dble(nblock) bda = bpos / dble(nblock) bda = -rt * log(bda) bdap(k) = bdap(k) + bda bda = bneg / dble(nblock) bda = -rt * log(bda) bdam(k) = bdam(k) + bda sdapb = sdapb + bdap(k) sdamb = sdamb + bdam(k) if (verbose .or. k.eq.1) then write (iout,190) 190 format (/,2x,'Block',9x,'NStep',9x,'BADEP', & 8x,'BADEM',9x,'BDAP',9x,'BDAM',/) end if write (iout,200) k,istep,badep(k),badem(k), & bdap(k),bdam(k) 200 format (i6,8x,i6,2x,4f13.4) end if c c calculate running averages for potential energy c if (modstep .eq. 0) then adep = sdep / dble(nstep) adem = sdem / dble(nstep) a2dep = s2dep / dble(nstep) a2dem = s2dem / dble(nstep) adep2 = adep * adep adem2 = adem * adem fdep = sqrt(a2dep - adep2) fdem = sqrt(a2dem - adem2) do k = 1, nstep / nblock v = (badep(k) - adep)**2 vdep = vdep + v v = (badem(k) - adem)**2 vdem = vdem + v end do vdep = vdep / dble(nstep/nblock) se_ep = sqrt(vdep / dble(nstep/nblock)) vdem = vdem / dble(nstep/nblock) se_em = sqrt(vdem / dble(nstep/nblock)) c c calculate running averages for free energy c da = spos / dble(nstep) da = -rt * log (da) dap = da da = sneg / dble(nstep) da = -rt * log (da) dam = da adapb = sdapb / dble(nstep/nblock) adamb = sdamb / dble(nstep/nblock) do k = 1, nstep/nblock v = (bdap(k) - adapb)**2 vdap = vdap + v v = (bdam(k) - adamb)**2 vdam = vdam + v end do vdap = vdap / dble(nstep/nblock) se_ap = sqrt(vdap / dble(nstep/nblock)) vdam = vdam / dble(nstep/nblock) se_am = sqrt(vdam / dble(nstep/nblock)) c c calculate running averages for energy components c avp = svp / dble(nstep) avm = svm / dble(nstep) acp = scp / dble(nstep) acm = scm / dble(nstep) if (dogeom) then abp = sbp / dble(nstep) abm = sbm / dble(nstep) aap = sap / dble(nstep) aam = sam / dble(nstep) aitp = sitp / dble(nstep) aitm = sitm / dble(nstep) atp = stp / dble(nstep) atm = stm / dble(nstep) end if sdep = 0.0d0 sdem = 0.0d0 c c write information about running averages and block averages c write (iout,210) nstep,nstep/nblock 210 format (/,' Running Averages over',i5,' Steps', & ' with Std Error from',i4,' Blocks :') write (iout,220) 220 format (/,' Free Energy :') write (iout,230) dap,se_ap 230 format (/,' DA(+) =',f12.4,' with Std Error',f10.4) write (iout,240) dam,se_am 240 format (' DA(-) =',f12.4,' with Std Error',f10.4) write (iout,250) 250 format (/,' Potential Energy :') write (iout,260) adep,fdep,se_ep 260 format (/,' DE(+) =',f12.4,' with Fluct',f10.4, & ' and Std Error',f10.4) write (iout,270) adem,fdem,se_em 270 format (' DE(-) =',f12.4,' with Fluct',f10.4, & ' and Std Error',f10.4) write (iout,280) 280 format (/,' Component Energies :',/) if (dogeom) then write (iout,290) abp,abm 290 format (' BOND +/- :',f12.4,5x,f12.4) write (iout,300) aap,aam 300 format (' ANGLE +/- :',f12.4,5x,f12.4) write (iout,310) aitp,aitm 310 format (' IMPT +/- :',f12.4,5x,f12.4) write (iout,320) atp,atm 320 format (' TORS +/- :',f12.4,5x,f12.4) end if write (iout,330) avp,avm 330 format (' VDW +/- :',f12.4,5x,f12.4) write (iout,340) acp,acm 340 format (' CHG +/- :',f12.4,5x,f12.4) end if end do c c perform deallocation of some local arrays c deallocate (badep) deallocate (badem) deallocate (bdap) deallocate (bdam) deallocate (nrg) deallocate (cb) deallocate (ca) deallocate (cit) deallocate (ct) deallocate (cv) deallocate (cc) c c perform any final tasks before program exit c call final end c c c ######################################################### c ## COPYRIGHT (C) 2024 by Moses Chung & Jay W. Ponder ## c ## All Rights Reserved ## c ######################################################### c c ############################################################### c ## ## c ## module alfmol -- AlphaMol area and volume information ## c ## ## c ############################################################### c c c alfthread number of OpenMP threads to use for AlphaMol2 c delcxeps eps value for AlphaMol Delaunay triangulation c alfhydro logical flag to include hydrogen atoms in AlphaMol c alfsosgmp logical flag governing use of SoS GMP in AlphaMol c alfmethod set AlphaMol1 or AlphaMol2 (SINGLE or MULTI threaded) c alfsort set sort method (NONE, SORT3D, BRIO, SPLIT, KDTREE) c c module alfmol implicit none integer alfthread real*8 delcxeps logical alfhydro logical alfsosgmp character*6 alfmethod character*6 alfsort save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module align -- information for structure superposition ## c ## ## c ################################################################# c c c nfit number of atoms to use in superimposing two structures c ifit atom numbers of pairs of atoms to be superimposed c wfit weights assigned to atom pairs during superposition c c module align implicit none integer nfit integer, allocatable :: ifit(:,:) real*8, allocatable :: wfit(:) save end c c c ########################################################## c ## COPYRIGHT (C) 2020 by Chengwen Liu & Jay W. Ponder ## c ## All Rights Reserved ## c ########################################################## c c ################################################################ c ## ## c ## subroutine alterchg -- modification of partial charges ## c ## ## c ################################################################ c c c "alterchg" calculates the change in atomic partial charge or c monopole values due to bond and angle charge flux coupling c c literature reference: c c C. Liu, J.-P. Piquemal and P. Ren, "Implementation of Geometry- c Dependent Charge Flux into the Polarizable AMOEBA+ Potential", c Journal of Physical Chemistry Letters, 11, 419-426 (2020) c c subroutine alterchg use atoms use charge use chgpen use inform use iounit use mplpot use mpole implicit none integer i,ii real*8, allocatable :: pdelta(:) logical header c c c perform dynamic allocation of some local arrays c allocate (pdelta(n)) c c zero out the change in charge value at each site c do i = 1, n pdelta(i) = 0.0d0 end do c c find charge modifications due to charge flux c call bndchg (pdelta) call angchg (pdelta) c c alter atomic partial charge values for charge flux c header = .true. do ii = 1, nion i = iion(ii) pchg(i) = pchg0(i) + pdelta(i) if (debug .and. pdelta(i).ne.0.0d0) then if (header) then header = .false. write (iout,10) 10 format (/,' Charge Flux Modification of Partial', & ' Charges :', & //,4x,'Atom',14x,'Base Value',7x,'Actual',/) end if write (iout,20) i,pchg0(i),pchg(i) 20 format (i8,9x,2f14.5) end if end do c c alter monopoles and charge penetration for charge flux c header = .true. do ii = 1, npole i = ipole(ii) pole(1,i) = mono0(i) + pdelta(i) if (use_chgpen) pval(i) = pval0(i) + pdelta(i) if (debug .and. pdelta(i).ne.0.0d0) then if (header) then header = .false. write (iout,30) 30 format (/,' Charge Flux Modification of Atomic', & ' Monopoles :', & //,4x,'Atom',14x,'Base Value',7x,'Actual',/) end if write (iout,40) i,mono0(i),pole(1,i) 40 format (i8,9x,2f14.5) end if end do c c perform deallocation of some local arrays c deallocate (pdelta) return end c c c ################################################################ c ## ## c ## subroutine bndchg -- charge flux bond stretch coupling ## c ## ## c ################################################################ c c c "bndchg" computes modifications to atomic partial charges or c monopoles due to bond stretch using a charge flux formulation c c subroutine bndchg (pdelta) use sizes use atoms use bndstr use bound use cflux implicit none integer i,ia,ib real*8 xab,yab,zab real*8 rab,rab0 real*8 pb,dq real*8 pdelta(*) c c c loop over all the bond distances in the system c do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) pb = bflx(i) c c compute the bond length value for the current bond c xab = x(ia) - x(ib) yab = y(ia) - y(ib) zab = z(ia) - z(ib) if (use_polymer) call image (xab,yab,zab) rab = sqrt(xab*xab + yab*yab + zab*zab) c c find the charge flux increment for the current bond c rab0 = bl(i) dq = pb * (rab-rab0) pdelta(ia) = pdelta(ia) - dq pdelta(ib) = pdelta(ib) + dq end do return end c c c ############################################################## c ## ## c ## subroutine angchg -- charge flux angle bend coupling ## c ## ## c ############################################################## c c c "angchg" computes modifications to atomic partial charges or c monopoles due to angle bending using a charge flux formulation c c subroutine angchg (pdelta) use sizes use angbnd use atmlst use atoms use bndstr use bound use cflux use math implicit none integer i,ia,ib,ic real*8 angle,eps real*8 rab,rcb real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 dot,cosine real*8 pa1,pa2 real*8 pb1,pb2 real*8 theta0 real*8 rab0,rcb0 real*8 dq1,dq2 real*8 pdelta(*) c c c loop over all the bond angles in the system c eps = 0.0001d0 do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) pa1 = aflx(1,i) pa2 = aflx(2,i) pb1 = abflx(1,i) pb2 = abflx(2,i) c c calculate the angle values and included bond lengths c xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib if (use_polymer) then call image (xab,yab,zab) call image (xcb,ycb,zcb) end if rab = sqrt(max(xab*xab+yab*yab+zab*zab,eps)) rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / (rab*rcb) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) c c find the charge flux increment for the current angle c theta0 = anat(i) rab0 = bl(balist(1,i)) rcb0 = bl(balist(2,i)) dq1 = pb1*(rcb-rcb0) + pa1*(angle-theta0)/radian dq2 = pb2*(rab-rab0) + pa2*(angle-theta0)/radian pdelta(ia) = pdelta(ia) + dq1 pdelta(ib) = pdelta(ib) - dq1 - dq2 pdelta(ic) = pdelta(ic) + dq2 end do return end c c c ################################################################ c ## COPYRIGHT (C) 2022 by Moses Chung, Zhi Wang & Jay Ponder ## c ## All Rights Reserved ## c ################################################################ c c ################################################################ c ## ## c ## subroutine alterpol -- variable polarizability scaling ## c ## ## c ################################################################ c c c "alterpol" computes the variable polarizability scaling for c use with exchange polarization c c literature reference: c c M. K. J. Chung, Z. Wang, J. A. Rackers and J. W. Ponder, c "Classical Exchange Polarization: An Anisotropic Variable c Polarizability Model", Journal of Physical Chemistry B, c submitted, June 2022 c c subroutine alterpol use limits use mpole implicit none c c c choose the method for summing over pairwise interactions c if (use_mlist) then call altpol0b else call altpol0a end if return end c c c ################################################################# c ## ## c ## subroutine altpol0a -- variable polarizability via loop ## c ## ## c ################################################################# c c c "altpol0a" computes the variable polarizability values due to c exchange polarization using a double loop c c subroutine altpol0a use atoms use bound use cell use couple use expol use mpole use polgrp use polpot use shunt implicit none integer i,j,k,m integer ii,kk integer jcell real*8 xi,yi,zi real*8 xr,yr,zr real*8 r,r2,r3,r4,r5 real*8 sizi,sizk,sizik real*8 alphai,alphak real*8 springi,springk real*8 s2,ds2 real*8 p33i, p33k real*8 ks2i(3,3) real*8 ks2k(3,3) real*8 taper real*8, allocatable :: pscale(:) logical epli,eplk character*6 mode c c c perform dynamic allocation of some local arrays c allocate (pscale(n)) c c set the switching function coefficients c mode = 'REPULS' call switch (mode) c c set polarizability tensor scaling to the identity matrix c do ii = 1, npole i = ipole(ii) polscale(1,1,i) = 1.0d0 polscale(2,1,i) = 0.0d0 polscale(3,1,i) = 0.0d0 polscale(1,2,i) = 0.0d0 polscale(2,2,i) = 1.0d0 polscale(3,2,i) = 0.0d0 polscale(1,3,i) = 0.0d0 polscale(2,3,i) = 0.0d0 polscale(3,3,i) = 1.0d0 end do c c set array needed to scale atom and group interactions c do i = 1, n pscale(i) = 1.0d0 end do c c find variable polarizability scale matrix at each site c do ii = 1, npole-1 i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) springi = kpep(i) sizi = prepep(i) alphai = dmppep(i) epli = lpep(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = p2scale do k = 1, np11(i) if (i12(j,i) .eq. ip11(k,i)) & pscale(i12(j,i)) = p2iscale end do end do do j = 1, n13(i) pscale(i13(j,i)) = p3scale do k = 1, np11(i) if (i13(j,i) .eq. ip11(k,i)) & pscale(i13(j,i)) = p3iscale end do end do do j = 1, n14(i) pscale(i14(j,i)) = p4scale do k = 1, np11(i) if (i14(j,i) .eq. ip11(k,i)) & pscale(i14(j,i)) = p4iscale end do end do do j = 1, n15(i) pscale(i15(j,i)) = p5scale do k = 1, np11(i) if (i15(j,i) .eq. ip11(k,i)) & pscale(i15(j,i)) = p5iscale end do end do c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) eplk = lpep(k) if (epli .or. eplk) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) springk = kpep(k) sizk = prepep(k) alphak = dmppep(k) sizik = sizi * sizk call dampexpl (r,sizik,alphai,alphak,s2,ds2) c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 s2 = s2 * taper end if p33i = springi * s2 * pscale(k) p33k = springk * s2 * pscale(k) call rotexpl (r,xr,yr,zr,p33i,p33k,ks2i,ks2k) do j = 1, 3 do m = 1, 3 polscale(j,m,i) = polscale(j,m,i) + ks2i(j,m) polscale(j,m,k) = polscale(j,m,k) + ks2k(j,m) end do end do end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 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 energy with other unit cells c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) springi = kpep(i) sizi = prepep(i) alphai = dmppep(i) epli = lpep(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = p2scale do k = 1, np11(i) if (i12(j,i) .eq. ip11(k,i)) & pscale(i12(j,i)) = p2iscale end do end do do j = 1, n13(i) pscale(i13(j,i)) = p3scale do k = 1, np11(i) if (i13(j,i) .eq. ip11(k,i)) & pscale(i13(j,i)) = p3iscale end do end do do j = 1, n14(i) pscale(i14(j,i)) = p4scale do k = 1, np11(i) if (i14(j,i) .eq. ip11(k,i)) & pscale(i14(j,i)) = p4iscale end do end do do j = 1, n15(i) pscale(i15(j,i)) = p5scale do k = 1, np11(i) if (i15(j,i) .eq. ip11(k,i)) & pscale(i15(j,i)) = p5iscale end do end do c c evaluate all sites within the cutoff distance c do kk = ii, npole k = ipole(kk) eplk = lpep(k) if (epli .or. eplk) then do jcell = 2, ncell xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call imager (xr,yr,zr,jcell) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) springk = kpep(k) sizk = prepep(k) alphak = dmppep(k) sizik = sizi * sizk call dampexpl (r,sizik,alphai,alphak,s2,ds2) c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 s2 = s2 * taper end if c c interaction of an atom with its own image counts half c if (i .eq. k) s2 = 0.5d0 * s2 p33i = springi * s2 * pscale(k) p33k = springk * s2 * pscale(k) call rotexpl (r,xr,yr,zr,p33i,p33k,ks2i,ks2k) do j = 1, 3 do m = 1, 3 polscale(j,m,i) = polscale(j,m,i) & + ks2i(j,m) polscale(j,m,k) = polscale(j,m,k) & + ks2k(j,m) end do end do end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 end do end do end if c c find inverse of the polarizability scaling matrix c do ii = 1, npole i = ipole(ii) do j = 1, 3 do m = 1, 3 polinv(j,m,i) = polscale(j,m,i) end do end do call invert (3,polinv(1,1,i)) end do c c perform deallocation of some local arrays c deallocate (pscale) return end c c c ################################################################# c ## ## c ## subroutine altpol0b -- variable polarizability via list ## c ## ## c ################################################################# c c c "altpol0b" computes variable polarizability values due to c exchange polarization using a neighbor list c c subroutine altpol0b use atoms use bound use couple use expol use mpole use neigh use polgrp use polpot use shunt implicit none integer i,j,k,m integer ii,kk,kkk real*8 xi,yi,zi real*8 xr,yr,zr real*8 r,r2,r3,r4,r5 real*8 sizi,sizk,sizik real*8 alphai,alphak real*8 springi,springk real*8 s2,ds2 real*8 p33i, p33k real*8 ks2i(3,3) real*8 ks2k(3,3) real*8 taper real*8, allocatable :: pscale(:) logical epli,eplk character*6 mode c c c perform dynamic allocation of some local arrays c allocate (pscale(n)) c c set the switching function coefficients c mode = 'REPULS' call switch (mode) c c set polarizability tensor scaling to the identity matrix c do ii = 1, npole i = ipole(ii) polscale(1,1,i) = 1.0d0 polscale(2,1,i) = 0.0d0 polscale(3,1,i) = 0.0d0 polscale(1,2,i) = 0.0d0 polscale(2,2,i) = 1.0d0 polscale(3,2,i) = 0.0d0 polscale(1,3,i) = 0.0d0 polscale(2,3,i) = 0.0d0 polscale(3,3,i) = 1.0d0 end do c c set array needed to scale atom and group interactions c do i = 1, n pscale(i) = 1.0d0 end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(npole,ipole,x,y,z,kpep,prepep,dmppep,lpep,np11,ip11,n12, !$OMP& i12,n13,i13,n14,i14,n15,i15,p2scale,p3scale,p4scale,p5scale, !$OMP& p2iscale,p3iscale,p4iscale,p5iscale,nelst,elst,use_bounds, !$OMP& cut2,off2,c0,c1,c2,c3,c4,c5,polinv) !$OMP& firstprivate(pscale) !$OMP& shared (polscale) !$OMP DO reduction(+:polscale) schedule(guided) c c find the variable polarizability c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) springi = kpep(i) sizi = prepep(i) alphai = dmppep(i) epli = lpep(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = p2scale do k = 1, np11(i) if (i12(j,i) .eq. ip11(k,i)) & pscale(i12(j,i)) = p2iscale end do end do do j = 1, n13(i) pscale(i13(j,i)) = p3scale do k = 1, np11(i) if (i13(j,i) .eq. ip11(k,i)) & pscale(i13(j,i)) = p3iscale end do end do do j = 1, n14(i) pscale(i14(j,i)) = p4scale do k = 1, np11(i) if (i14(j,i) .eq. ip11(k,i)) & pscale(i14(j,i)) = p4iscale end do end do do j = 1, n15(i) pscale(i15(j,i)) = p5scale do k = 1, np11(i) if (i15(j,i) .eq. ip11(k,i)) & pscale(i15(j,i)) = p5iscale end do end do c c evaluate all sites within the cutoff distance c do kkk = 1, nelst(ii) kk = elst(kkk,ii) k = ipole(kk) eplk = lpep(k) if (epli .or. eplk) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) springk = kpep(k) sizk = prepep(k) alphak = dmppep(k) sizik = sizi * sizk call dampexpl (r,sizik,alphai,alphak,s2,ds2) c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 s2 = s2 * taper end if p33i = springi * s2 * pscale(k) p33k = springk * s2 * pscale(k) call rotexpl (r,xr,yr,zr,p33i,p33k,ks2i,ks2k) do j = 1, 3 do m = 1, 3 polscale(j,m,i) = polscale(j,m,i) + ks2i(j,m) polscale(j,m,k) = polscale(j,m,k) + ks2k(j,m) end do end do end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 end do end do !$OMP END DO c c find inverse of the polarizability scaling matrix c !$OMP DO schedule(guided) do ii = 1, npole i = ipole(ii) do j = 1, 3 do m = 1, 3 polinv(j,m,i) = polscale(j,m,i) end do end do call invert (3,polinv(1,1,i)) end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (pscale) return end c c c ########################################################### c ## ## c ## subroutine rotexpl -- rotation matrix for overlap ## c ## ## c ########################################################### c c c "rotexpl" finds and applies rotation matrices for the c overlap tensor used in computing exchange polarization c c subroutine rotexpl (r,xr,yr,zr,p33i,p33k,ks2i,ks2k) implicit none integer i,j real*8 r,xr,yr,zr real*8 p33i,p33k real*8 a(3) real*8 ks2i(3,3) real*8 ks2k(3,3) c c c compute only needed rotation matrix elements c a(1) = xr / r a(2) = yr / r a(3) = zr / r c c rotate the vector from global to local frame c do i = 1, 3 do j = 1, 3 ks2i(i,j) = p33i * a(i) * a(j) ks2k(i,j) = p33k * a(i) * a(j) end do end do return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine analysis -- energy components and analysis ## c ## ## c ############################################################### c c c "analysis" calls the series of routines needed to calculate c the potential energy and perform energy partitioning analysis c in terms of type of interaction or atom number c c subroutine analysis (energy) use analyz use atoms use energi use group use inter use iounit use limits use potent use vdwpot implicit none integer i real*8 energy real*8 cutoff c c c zero out each of the potential energy components c esum = 0.0d0 eb = 0.0d0 ea = 0.0d0 eba = 0.0d0 eub = 0.0d0 eaa = 0.0d0 eopb = 0.0d0 eopd = 0.0d0 eid = 0.0d0 eit = 0.0d0 et = 0.0d0 ept = 0.0d0 ebt = 0.0d0 eat = 0.0d0 ett = 0.0d0 ev = 0.0d0 er = 0.0d0 edsp = 0.0d0 ec = 0.0d0 ecd = 0.0d0 ed = 0.0d0 em = 0.0d0 ep = 0.0d0 ect = 0.0d0 erxf = 0.0d0 es = 0.0d0 elf = 0.0d0 eg = 0.0d0 ex = 0.0d0 c c perform dynamic allocation of some global arrays c if (allocated(aesum)) then if (size(aesum) .lt. n) then deallocate (aesum) deallocate (aeb) deallocate (aea) deallocate (aeba) deallocate (aeub) deallocate (aeaa) deallocate (aeopb) deallocate (aeopd) deallocate (aeid) deallocate (aeit) deallocate (aet) deallocate (aept) deallocate (aebt) deallocate (aeat) deallocate (aett) deallocate (aev) deallocate (aer) deallocate (aedsp) deallocate (aec) deallocate (aecd) deallocate (aed) deallocate (aem) deallocate (aep) deallocate (aect) deallocate (aerxf) deallocate (aes) deallocate (aelf) deallocate (aeg) deallocate (aex) end if end if if (.not. allocated(aesum)) then allocate (aesum(n)) allocate (aeb(n)) allocate (aea(n)) allocate (aeba(n)) allocate (aeub(n)) allocate (aeaa(n)) allocate (aeopb(n)) allocate (aeopd(n)) allocate (aeid(n)) allocate (aeit(n)) allocate (aet(n)) allocate (aept(n)) allocate (aebt(n)) allocate (aeat(n)) allocate (aett(n)) allocate (aev(n)) allocate (aer(n)) allocate (aedsp(n)) allocate (aec(n)) allocate (aecd(n)) allocate (aed(n)) allocate (aem(n)) allocate (aep(n)) allocate (aect(n)) allocate (aerxf(n)) allocate (aes(n)) allocate (aelf(n)) allocate (aeg(n)) allocate (aex(n)) end if c c zero out energy partitioning components for each atom c do i = 1, n aesum(i) = 0.0d0 aeb(i) = 0.0d0 aea(i) = 0.0d0 aeba(i) = 0.0d0 aeub(i) = 0.0d0 aeaa(i) = 0.0d0 aeopb(i) = 0.0d0 aeopd(i) = 0.0d0 aeid(i) = 0.0d0 aeit(i) = 0.0d0 aet(i) = 0.0d0 aept(i) = 0.0d0 aebt(i) = 0.0d0 aeat(i) = 0.0d0 aett(i) = 0.0d0 aev(i) = 0.0d0 aer(i) = 0.0d0 aedsp(i) = 0.0d0 aec(i) = 0.0d0 aecd(i) = 0.0d0 aed(i) = 0.0d0 aem(i) = 0.0d0 aep(i) = 0.0d0 aect(i) = 0.0d0 aerxf(i) = 0.0d0 aes(i) = 0.0d0 aelf(i) = 0.0d0 aeg(i) = 0.0d0 aex(i) = 0.0d0 end do c c zero out the total intermolecular energy c einter = 0.0d0 c c remove any previous use of the replicates method c cutoff = 0.0d0 call replica (cutoff) c c update the pairwise interaction neighbor lists c if (use_list) call nblist c c many implicit solvation models require Born radii c if (use_born) call born c c alter partial charges and multipoles for charge flux c if (use_chgflx) call alterchg c c modify bond and torsion constants for pisystem c if (use_orbit) call picalc c c call the local geometry energy component routines c if (use_bond) call ebond3 if (use_angle) call eangle3 if (use_strbnd) call estrbnd3 if (use_urey) call eurey3 if (use_angang) call eangang3 if (use_opbend) call eopbend3 if (use_opdist) call eopdist3 if (use_improp) call eimprop3 if (use_imptor) call eimptor3 if (use_tors) call etors3 if (use_pitors) call epitors3 if (use_strtor) call estrtor3 if (use_angtor) call eangtor3 if (use_tortor) call etortor3 c c call the electrostatic energy component routines c if (use_charge) call echarge3 if (use_chgdpl) call echgdpl3 if (use_dipole) call edipole3 if (use_mpole) call empole3 if (use_polar) call epolar3 if (use_chgtrn) call echgtrn3 if (use_rxnfld) call erxnfld3 c c call the van der Waals energy component routines c if (use_vdw) then if (vdwtyp .eq. 'LENNARD-JONES') call elj3 if (vdwtyp .eq. 'BUCKINGHAM') call ebuck3 if (vdwtyp .eq. 'MM3-HBOND') call emm3hb3 if (vdwtyp .eq. 'BUFFERED-14-7') call ehal3 if (vdwtyp .eq. 'GAUSSIAN') call egauss3 end if if (use_repel) call erepel3 if (use_disp) call edisp3 c c call any miscellaneous energy component routines c if (use_solv) call esolv3 if (use_metal) call emetal3 if (use_geom) call egeom3 if (use_extra) call extra3 c c sum up to give the total potential energy c esum = eb + ea + eba + eub + eaa + eopb + eopd + eid + eit & + et + ept + ebt + eat + ett + ev + er + edsp & + ec + ecd + ed + em + ep + ect + erxf + es + elf & + eg + ex energy = esum c c sum up to give the total potential energy per atom c do i = 1, n aesum(i) = aeb(i) + aea(i) + aeba(i) + aeub(i) + aeaa(i) & + aeopb(i) + aeopd(i) + aeid(i) + aeit(i) & + aet(i) + aept(i) + aebt(i) + aeat(i) + aett(i) & + aev(i) + aer(i) + aedsp(i) + aec(i) + aecd(i) & + aed(i) + aem(i) + aep(i) + aect(i) + aerxf(i) & + aes(i) + aelf(i) + aeg(i) + aex(i) end do c c check for an illegal value for the total energy c c if (isnan(esum)) then if (esum .ne. esum) then write (iout,10) 10 format (/,' ANALYSIS -- Illegal Value for the Total', & ' Potential Energy') call fatal end if return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module analyz -- energy components partitioned to atoms ## c ## ## c ################################################################# c c c aesum total potential energy partitioned over atoms c aeb bond stretch energy partitioned over atoms c aea angle bend energy partitioned over atoms c aeba stretch-bend energy partitioned over atoms c aeub Urey-Bradley energy partitioned over atoms c aeaa angle-angle energy partitioned over atoms c aeopb out-of-plane bend energy partitioned over atoms c aeopd out-of-plane distance energy partitioned over atoms c aeid improper dihedral energy partitioned over atoms c aeit improper torsion energy partitioned over atoms c aet torsional energy partitioned over atoms c aept pi-system torsion energy partitioned over atoms c aebt stretch-torsion energy partitioned over atoms c aeat angle-torsion energy partitioned over atoms c aett torsion-torsion energy partitioned over atoms c aev van der Waals energy partitioned over atoms c aer Pauli repulsion energy partitioned over atoms c aedsp damped dispersion energy partitioned over atoms c aec charge-charge energy partitioned over atoms c aecd charge-dipole energy partitioned over atoms c aed dipole-dipole energy partitioned over atoms c aem multipole energy partitioned over atoms c aep polarization energy partitioned over atoms c aect charge transfer energy partitioned over atoms c aerxf reaction field energy partitioned over atoms c aes solvation energy partitioned over atoms c aelf metal ligand field energy partitioned over atoms c aeg geometric restraint energy partitioned over atoms c aex extra energy term partitioned over atoms c c module analyz implicit none real*8, allocatable :: aesum(:) real*8, allocatable :: aeb(:) real*8, allocatable :: aea(:) real*8, allocatable :: aeba(:) real*8, allocatable :: aeub(:) real*8, allocatable :: aeaa(:) real*8, allocatable :: aeopb(:) real*8, allocatable :: aeopd(:) real*8, allocatable :: aeid(:) real*8, allocatable :: aeit(:) real*8, allocatable :: aet(:) real*8, allocatable :: aept(:) real*8, allocatable :: aebt(:) real*8, allocatable :: aeat(:) real*8, allocatable :: aett(:) real*8, allocatable :: aev(:) real*8, allocatable :: aer(:) real*8, allocatable :: aedsp(:) real*8, allocatable :: aec(:) real*8, allocatable :: aecd(:) real*8, allocatable :: aed(:) real*8, allocatable :: aem(:) real*8, allocatable :: aep(:) real*8, allocatable :: aect(:) real*8, allocatable :: aerxf(:) real*8, allocatable :: aes(:) real*8, allocatable :: aelf(:) real*8, allocatable :: aeg(:) real*8, allocatable :: aex(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## program analyze -- energy partitioning and analysis ## c ## ## c ############################################################# c c c "analyze" computes and displays the total potential energy; c options are provided to display system and force field info, c partition the energy by atom or by potential function type, c show force field parameters by atom; output the large energy c interactions and find electrostatic and inertial properties c c program analyze use atoms use boxes use files use inform use iounit use output implicit none integer i,j,ixyz integer frame integer nlist,nold integer freeunit integer trimtext integer, allocatable :: list(:) real*8 energy real*8, allocatable :: told(:) real*8, allocatable :: derivs(:,:) logical dosystem,doparam logical doenergy,doatom logical dolarge,dodetail logical domoment,dovirial logical doconect,dosave logical exist,first logical, allocatable :: active(:) character*1 letter character*240 record character*240 string character*240 xyzfile c c c set up the structure and mechanics calculation c ixyz = 0 call initial call getcart (ixyz) call mechanic xyzfile = filename c c get the desired types of analysis to be performed c call nextarg (string,exist) if (.not. exist) then write (iout,10) 10 format (/,' The Tinker Energy Analysis Utility Can :', & //,' General System and Force Field Information [G]', & /,' Force Field Parameters for Interactions [P]', & /,' Total Potential Energy and its Components [E]', & /,' Energy Breakdown over Each of the Atoms [A]', & /,' List of the Large Individual Interactions [L]', & /,' Details for All Individual Interactions [D]', & /,' Electrostatic Moments and Principle Axes [M]', & /,' Internal Virial & Instantaneous Pressure [V]', & /,' Connectivity Lists for Each of the Atoms [C]') 20 continue write (iout,30) 30 format (/,' Enter the Desired Analysis Types', & ' [G,P,E,A,L,D,M,V,C] : ',$) read (input,40,err=20) string 40 format (a240) end if c c set option control flags based desired analysis types c dosystem = .false. doparam = .false. doenergy = .false. doatom = .false. dolarge = .false. dodetail = .false. domoment = .false. dovirial = .false. doconect = .false. call upcase (string) do i = 1, trimtext(string) letter = string(i:i) if (letter .eq. 'G') dosystem = .true. if (letter .eq. 'P') doparam = .true. if (letter .eq. 'E') doenergy = .true. if (letter .eq. 'A') doatom = .true. if (letter .eq. 'L') dolarge = .true. if (letter .eq. 'D') dodetail = .true. if (letter .eq. 'M') domoment = .true. if (letter .eq. 'V') dovirial = .true. if (letter .eq. 'C') doconect = .true. end do c c set option control flag to save forces or induced dipoles c dosave = .false. call optinit if (frcsave .or. uindsave) dosave = .true. c c perform dynamic allocation of some local arrays c nlist = 40 allocate (list(nlist)) allocate (active(n)) allocate (told(n)) c c get the list of atoms for which output is desired c if (doatom .or. doparam .or. doconect) then do i = 1, nlist list(i) = 0 end do if (exist) then do i = 1, nlist call nextarg (string,exist) if (.not. exist) goto 50 read (string,*,err=50,end=50) list(i) end do 50 continue if (list(1) .eq. 0) then list(1) = -1 list(2) = n end if else write (iout,60) 60 format (/,' List Atoms for which Output is Desired', & ' [ALL] : '/,' > ',$) read (input,70) record 70 format (a240) read (record,*,err=80,end=80) (list(i),i=1,nlist) 80 continue end if do i = 1, n active(i) = .true. end do i = 1 do while (list(i) .ne. 0) if (i .eq. 1) then do j = 1, n active(j) = .false. end do end if if (list(i) .gt. 0) then active(list(i)) = .true. i = i + 1 else do j = abs(list(i)), abs(list(i+1)) active(j) = .true. end do i = i + 2 end if end do end if c c setup to write out the large individual energy terms c if (dolarge) then verbose = .true. end if c c setup to write out all of the individual energy terms c if (dodetail) then doenergy = .true. verbose = .true. debug = .true. else debug = .false. end if c c get parameters used for molecular mechanics potentials c if (doparam .and. doconect) then call amberyze (active) else if (doparam) then call paramyze (active) end if c c provide connectivity lists for the individual atoms c if (doconect) call connyze (active) c c decide whether to perform analysis of individual frames c abort = .true. if (dosystem .or. doenergy .or. doatom .or. dolarge .or. & domoment .or. dovirial .or. dosave) abort = .false. c c perform analysis for each successive coordinate structure c frame = 0 do while (.not. abort) frame = frame + 1 if (frame .gt. 1) then write (iout,90) frame 90 format (/,' Analysis for Archive Structure :',8x,i8) if (nold .ne. n) then call mechanic else do i = 1, n if (type(i) .ne. told(i)) then call mechanic goto 100 end if end do 100 continue end if end if c c get info on the molecular system and force field c if (dosystem) call systyze c c make the call to compute the potential energy c if (doenergy .or. doatom .or. dolarge) call enrgyze c c energy partitioning by potential energy components c if (doenergy) call partyze c c get the various electrostatic and inertial moments c if (domoment) then debug = .false. call momyze if (dodetail) debug = .true. end if c c energy partitioning over the individual atoms c if (doatom) call atomyze (active) c c compute the gradient if force or virial is requested c if (dovirial .or. frcsave) then allocate (derivs(3,n)) call gradient (energy,derivs) deallocate (derivs) end if c c get and test the internal virial and pressure values c if (dovirial) then debug = .false. call viriyze if (dodetail) debug = .true. end if c c save output files with forces or induced dipoles c if (dosave) call saveyze (frame) c c attempt to read next structure from the coordinate file c if (size(told) .lt. n) then deallocate (told) allocate (told(n)) end if nold = n do i = 1, nold told(i) = type(i) end do first = .false. call readcart (ixyz,first) end do c c perform deallocation of some local arrays c deallocate (list) deallocate (active) deallocate (told) c c perform any final tasks before program exit c close (unit=ixyz) if (dodetail) debug = .false. call final end c c c ################################################################ c ## ## c ## subroutine systyze -- system & force field information ## c ## ## c ################################################################ c c c "systyze" is an auxiliary routine for the analyze program c that prints general information about the molecular system c and the force field model c c subroutine systyze use atoms use bound use boxes use ewald use fields use iounit use limits use molcul use mplpot use pme use polpot use potent use units use vdwpot implicit none integer i real*8 dens character*20 value character*20 label(5) c c c info on number of atoms, molecules and mass c if (n .ne. 0) then write (iout,10) n,nmol,totmass 10 format (/,' Overall System Contents :', & //,' Number of Atoms',25x,i8, & /,' Number of Molecules',21x,i8, & /,' Total System Mass',15x,f16.4) if (use_bounds) then dens = (1.0d24/volbox) * (totmass/avogadro) write (iout,20) dens 20 format (' System Density',22x,f12.4) end if end if c c periodic box dimensions and crystal lattice type c if (use_bounds) then value = 'ORTHOGONAL' if (monoclinic) value = 'MONOCLINIC' if (triclinic) value = 'TRICLINIC' if (octahedron) value = 'TRUNCATED OCTAHEDRON' if (dodecadron) value = 'RHOMBIC DODECAHEDRON' call justify (value) write (iout,30) xbox,ybox,zbox,alpha,beta,gamma,volbox,value 30 format (/,' Periodic Boundary Box :', & //,' a-Axis Length',23x,f12.4, & /,' b-Axis Length',23x,f12.4, & /,' c-Axis Length',23x,f12.4, & /,' Alpha Angle',25x,f12.4, & /,' Beta Angle',26x,f12.4, & /,' Gamma Angle',25x,f12.4, & /,' Cell Volume',21x,f16.4, & /,' Lattice Type',16x,a20) write (iout,40) (lvec(1,i),i=1,3),(lvec(2,i),i=1,3), & (lvec(3,i),i=1,3) 40 format (/,' Lattice Vectors :', & //,3x,'a',3x,3f14.4, & /,3x,'b',3x,3f14.4, & /,3x,'c',3x,3f14.4) if (spacegrp .ne. ' ') then value = spacegrp call justify (value) write (iout,50) value 50 format (' Space Group',17x,a20) end if end if c c info on force field potential energy function c value = forcefield call justify (value) write (iout,60) value 60 format (/,' Force Field Name :',10x,a20) c c details of vdw potential energy functional form c if (use_vdw .or. use_repel .or. use_disp) then write (iout,70) 70 format () end if if (use_vdw) then label(1) = vdwtyp label(2) = radtyp label(3) = radsiz label(4) = radrule label(5) = epsrule do i = 1, 5 call justify (label(i)) end do write (iout,80) (label(i),i=1,5) 80 format (' VDW Function',16x,a20, & /,' Size Descriptor',13x,a20, & /,' Size Unit Type',14x,a20, & /,' Size Combining Rule',9x,a20, & /,' Well Depth Rule',13x,a20) if (vdwcut .le. 1000.0d0) then write (iout,90) vdwcut 90 format (' VDW Cutoff',26x,f12.4) end if end if if (use_repel) then value = 'PAULI REPULSION' call justify (value) write (iout,100) value 100 format (' VDW Function',16x,a20) end if if (use_disp) then value = 'DAMPED DISPERSION' call justify (value) write (iout,110) value 110 format (' VDW Function',16x,a20) end if c c details of dispersion particle mesh Ewald calculation c if (use_dewald) then write (iout,120) adewald,dewaldcut,ndfft1, & ndfft2,ndfft3,bsdorder 120 format (/,' PME for Dispersion :', & //,' Ewald Coefficient',19x,f12.4, & /,' Real-Space Cutoff',19x,f12.4, & /,' Grid Dimensions',21x,3i4, & /,' B-Spline Order',26x,i8) end if c c details of electrostatic energy functional form c if (use_charge .or. use_dipole .or. use_mpole .or. use_polar) then write (iout,130) 130 format () end if if (use_charge) then value = 'PARTIAL CHARGE' call justify (value) write (iout,140) value 140 format (' Electrostatics',14x,a20) end if if (use_dipole) then value = 'BOND DIPOLE' call justify (value) write (iout,150) value 150 format (' Electrostatics',14x,a20) end if if (use_mpole) then value = 'ATOMIC MULTIPOLE' call justify (value) write (iout,160) value 160 format (' Electrostatics',14x,a20) end if if (use_chgpen) then value = 'CHARGE PENETRATION' call justify (value) write (iout,170) value 170 format (' Electrostatics',14x,a20) end if if (use_chgtrn) then value = 'CHARGE TRANSFER' call justify (value) write (iout,180) value 180 format (' Induction',19x,a20) end if if (use_polar) then value = 'INDUCED DIPOLE' call justify (value) write (iout,190) value 190 format (' Induction',19x,a20) value = poltyp call justify (value) write (iout,200) value 200 format (' Polarization',16x,a20) if (use_thole) then value = 'THOLE DAMPING' call justify (value) write (iout,210) value 210 format (' Polarization',16x,a20) end if if (use_chgpen) then value = 'CHGPEN DAMPING' call justify (value) write (iout,220) value 220 format (' Polarization',16x,a20) end if end if c c details of electrostatic particle mesh Ewald calculation c if (use_ewald) then value = boundary call justify (value) write (iout,230) aeewald,ewaldcut,nefft1,nefft2, & nefft3,bseorder,value 230 format (/,' PME for Electrostatics :', & //,' Ewald Coefficient',19x,f12.4, & /,' Real-Space Cutoff',19x,f12.4, & /,' Grid Dimensions',21x,3i4, & /,' B-Spline Order',26x,i8, & /,' Boundary Condition',10x,a20) end if return end c c c ################################################################ c ## ## c ## subroutine enrgyze -- compute & report energy analysis ## c ## ## c ################################################################ c c c "enrgyze" is an auxiliary routine for the analyze program c that performs the energy analysis and prints the total and c intermolecular energies c c subroutine enrgyze use atoms use inform use inter use iounit use limits use molcul implicit none real*8 energy character*56 fstr c c c perform the energy analysis by atom and component c call analysis (energy) c c intermolecular energy for systems with multiple molecules c fstr = '(/,'' Intermolecular Energy :'',9x,f16.4,'' Kcal/mole'')' if (digits .ge. 6) fstr(31:38) = '7x,f18.6' if (digits .ge. 8) fstr(31:38) = '5x,f20.8' if (abs(einter) .ge. 1.0d10) fstr(34:34) = 'd' if (nmol.gt.1 .and. nmol.lt.n .and. .not.use_ewald) then write (iout,fstr) einter end if c c print out the total potential energy of the system c fstr = '(/,'' Total Potential Energy :'',8x,f16.4,'' Kcal/mole'')' if (digits .ge. 6) fstr(32:39) = '6x,f18.6' if (digits .ge. 8) fstr(32:39) = '4x,f20.8' if (abs(energy) .ge. 1.0d10) fstr(35:35) = 'd' write (iout,fstr) energy return end c c c ############################################################## c ## ## c ## subroutine partyze -- energy component decomposition ## c ## ## c ############################################################## c c c "partyze" prints the energy component and number of c interactions for each of the potential energy terms c c subroutine partyze use action use energi use inform use iounit use limits use potent implicit none character*12 form1 character*12 form2 character*240 fstr c c c write out each energy component to the desired precision c form1 = '5x,f16.4,i17' if (digits .ge. 6) form1 = '3x,f18.6,i17' if (digits .ge. 8) form1 = '1x,f20.8,i17' form2 = form1(1:3)//'d'//form1(5:12) fstr = '(/,'' Energy Component Breakdown :'', & 11x,''Kcal/mole'',8x,''Interactions'',/)' write (iout,fstr) if (use_bond .and. (neb.ne.0.or.eb.ne.0.0d0)) then fstr = '('' Bond Stretching'',12x,'//form1//')' write (iout,fstr) eb,neb end if if (use_angle .and. (nea.ne.0.or.ea.ne.0.0d0)) then fstr = '('' Angle Bending'',14x,'//form1//')' write (iout,fstr) ea,nea end if if (use_strbnd .and. (neba.ne.0.or.eba.ne.0.0d0)) then fstr = '('' Stretch-Bend'',15x,'//form1//')' write (iout,fstr) eba,neba end if if (use_urey .and. (neub.ne.0.or.eub.ne.0.0d0)) then fstr = '('' Urey-Bradley'',15x,'//form1//')' write (iout,fstr) eub,neub end if if (use_angang .and. (neaa.ne.0.or.eaa.ne.0.0d0)) then fstr = '('' Angle-Angle'',16x,'//form1//')' write (iout,fstr) eaa,neaa end if if (use_opbend .and. (neopb.ne.0.or.eopb.ne.0.0d0)) then fstr = '('' Out-of-Plane Bend'',10x,'//form1//')' write (iout,fstr) eopb,neopb end if if (use_opdist .and. (neopd.ne.0.or.eopd.ne.0.0d0)) then fstr = '('' Out-of-Plane Distance'',6x,'//form1//')' write (iout,fstr) eopd,neopd end if if (use_improp .and. (neid.ne.0.or.eid.ne.0.0d0)) then fstr = '('' Improper Dihedral'',10x,'//form1//')' write (iout,fstr) eid,neid end if if (use_imptor .and. (neit.ne.0.or.eit.ne.0.0d0)) then fstr = '('' Improper Torsion'',11x,'//form1//')' write (iout,fstr) eit,neit end if if (use_tors .and. (net.ne.0.or.et.ne.0.0d0)) then fstr = '('' Torsional Angle'',12x,'//form1//')' write (iout,fstr) et,net end if if (use_pitors .and. (nept.ne.0.or.ept.ne.0.0d0)) then fstr = '('' Pi-Orbital Torsion'',9x,'//form1//')' write (iout,fstr) ept,nept end if if (use_strtor .and. (nebt.ne.0.or.ebt.ne.0.0d0)) then fstr = '('' Stretch-Torsion'',12x,'//form1//')' write (iout,fstr) ebt,nebt end if if (use_angtor .and. (neat.ne.0.or.eat.ne.0.0d0)) then fstr = '('' Angle-Torsion'',14x,'//form1//')' write (iout,fstr) eat,neat end if if (use_tortor .and. (nett.ne.0.or.ett.ne.0.0d0)) then fstr = '('' Torsion-Torsion'',12x,'//form1//')' write (iout,fstr) ett,nett end if if (use_vdw .and. (nev.ne.0.or.ev.ne.0.0d0)) then if (abs(ev) .lt. 1.0d10) then fstr = '('' Van der Waals'',14x,'//form1//')' else fstr = '('' Van der Waals'',14x,'//form2//')' end if write (iout,fstr) ev,nev end if if (use_repel .and. (ner.ne.0.or.er.ne.0.0d0)) then if (abs(er) .lt. 1.0d10) then fstr = '('' Repulsion'',18x,'//form1//')' else fstr = '('' Repulsion'',18x,'//form2//')' end if write (iout,fstr) er,ner end if if (use_disp .and. (nedsp.ne.0.or.edsp.ne.0.0d0)) then fstr = '('' Dispersion'',17x,'//form1//')' write (iout,fstr) edsp,nedsp end if if (use_charge .and. (nec.ne.0.or.ec.ne.0.0d0)) then if (abs(ec) .lt. 1.0d10) then fstr = '('' Charge-Charge'',14x,'//form1//')' else fstr = '('' Charge-Charge'',14x,'//form2//')' end if write (iout,fstr) ec,nec end if if (use_chgdpl .and. (necd.ne.0.or.ecd.ne.0.0d0)) then if (abs(ecd) .lt. 1.0d10) then fstr = '('' Charge-Dipole'',14x,'//form1//')' else fstr = '('' Charge-Dipole'',14x,'//form2//')' end if write (iout,fstr) ecd,necd end if if (use_dipole .and. (ned.ne.0.or.ed.ne.0.0d0)) then if (abs(ed) .lt. 1.0d10) then fstr = '('' Dipole-Dipole'',14x,'//form1//')' else fstr = '('' Dipole-Dipole'',14x,'//form2//')' end if write (iout,fstr) ed,ned end if if (use_mpole .and. (nem.ne.0.or.em.ne.0.0d0)) then if (abs(em) .lt. 1.0d10) then fstr = '('' Atomic Multipoles'',10x,'//form1//')' else fstr = '('' Atomic Multipoles'',10x,'//form2//')' end if write (iout,fstr) em,nem end if if (use_polar .and. (nep.ne.0.or.ep.ne.0.0d0)) then if (abs(ep) .lt. 1.0d10) then fstr = '('' Polarization'',15x,'//form1//')' else fstr = '('' Polarization'',15x,'//form2//')' end if write (iout,fstr) ep,nep end if if (use_chgtrn .and. (nect.ne.0.or.ect.ne.0.0d0)) then if (abs(ect) .lt. 1.0d10) then fstr = '('' Charge Transfer'',12x,'//form1//')' else fstr = '('' Charge Transfer'',12x,'//form2//')' end if write (iout,fstr) ect,nect end if if (use_rxnfld .and. (nerxf.ne.0.or.erxf.ne.0.0d0)) then fstr = '('' Reaction Field'',13x,'//form1//')' write (iout,fstr) erxf,nerxf end if if (use_solv .and. (nes.ne.0.or.es.ne.0.0d0)) then fstr = '('' Implicit Solvation'',9x,'//form1//')' write (iout,fstr) es,nes end if if (use_metal .and. (nelf.ne.0.or.elf.ne.0.0d0)) then fstr = '('' Metal Ligand Field'',9x,'//form1//')' write (iout,fstr) elf,nelf end if if (use_geom .and. (neg.ne.0.or.eg.ne.0.0d0)) then fstr = '('' Geometric Restraints'',7x,'//form1//')' write (iout,fstr) eg,neg end if if (use_extra .and. (nex.ne.0.or.ex.ne.0.0d0)) then fstr = '('' Extra Energy Terms'',9x,'//form1//')' write (iout,fstr) ex,nex end if return end c c c ################################################################ c ## ## c ## subroutine momyze -- electrostatic & inertial analysis ## c ## ## c ################################################################ c c c "momyze" finds and prints the total charge, dipole moment c components, radius of gyration and moments of inertia c c subroutine momyze use chgpot use iounit use moment implicit none real*8 rg character*6 mode c c c get the electrostatic moments over the active atoms c mode = 'ACTIVE' call moments (mode) c c print the total charge, dipole and quadrupole moments c write (iout,10) netchg 10 format (/,' Total Electric Charge :',12x,f13.5,' Electrons') write (iout,20) netdpl,xdpl,ydpl,zdpl 20 format (/,' Dipole Moment Magnitude :',10x,f13.3,' Debye', & //,' Dipole X,Y,Z-Components :',10x,3f13.3) write (iout,30) xxqpl,xyqpl,xzqpl,yxqpl,yyqpl, & yzqpl,zxqpl,zyqpl,zzqpl 30 format (/,' Quadrupole Moment Tensor :',9x,3f13.3, & /,6x,'(Buckinghams)',17x,3f13.3, & /,36x,3f13.3) write (iout,40) netqpl(1),netqpl(2),netqpl(3) 40 format (/,' Principal Axes Quadrupole :',8x,3f13.3) if (dielec .ne. 1.0d0) then write (iout,50) dielec 50 format (/,' Dielectric Constant :',14x,f13.3) write (iout,60) netchg/sqrt(dielec) 60 format (' Effective Total Charge :',11x,f13.5,' Electrons') write (iout,70) netdpl/sqrt(dielec) 70 format (' Effective Dipole Moment :',10x,f13.3,' Debye') end if c c get the radius of gyration and moments of inertia c call gyrate (rg) write (iout,80) rg 80 format (/,' Radius of Gyration :',15x,f13.3,' Angstroms') call inertia (1) return end c c c ############################################################### c ## ## c ## subroutine atomyze -- individual atom energy analysis ## c ## ## c ############################################################### c c c "atomyze" prints the potential energy components broken c down by atom and to a choice of precision c c subroutine atomyze (active) use analyz use atoms use inform use iounit implicit none integer i logical active(*) character*240 fstr c c c energy partitioning over the individual atoms c fstr = '(/,'' Potential Energy Breakdown over Atoms :'')' write (iout,fstr) if (digits .ge. 8) then write (iout,10) 10 format (/,' Atom',9x,'EB',14x,'EA',14x,'EBA',13x,'EUB', & /,15x,'EAA',13x,'EOPB',12x,'EOPD',12x,'EID', & /,15x,'EIT',13x,'ET',14x,'EPT',13x,'EBT', & /,15x,'EAT',13x,'ETT',13x,'EV',14x,'ER', & /,15x,'EDSP',12x,'EC',14x,'ECD',13x,'ED', & /,15x,'EM',14x,'EP',14x,'ECT',13x,'ERXF', & /,15x,'ES',14x,'ELF',13x,'EG',14x,'EX') else if (digits .ge. 6) then write (iout,20) 20 format (/,' Atom',8x,'EB',12x,'EA',12x,'EBA',11x,'EUB', & 11x,'EAA', & /,14x,'EOPB',10x,'EOPD',10x,'EID',11x,'EIT',11x,'ET', & /,14x,'EPT',11x,'EBT',11x,'EAT',11x,'ETT',11x,'EV', & /,14x,'ER',12x,'EDSP',10x,'EC',12x,'ECD',11x,'ED', & /,14x,'EM',12x,'EP',12x,'ECT',11x,'ERXF',10x,'ES', & /,14x,'ELF',11x,'EG',12x,'EX') else write (iout,30) 30 format (/,' Atom',8x,'EB',10x,'EA',10x,'EBA',9x,'EUB', & 9x,'EAA',9x,'EOPB', & /,14x,'EOPD',8x,'EID',9x,'EIT',9x,'ET',10x,'EPT', & 9x,'EBT', & /,14x,'EAT',9x,'ETT',9x,'EV',10x,'ER',10x,'EDSP', & 8x,'EC', & /,14x,'ECD',9x,'ED',10x,'EM',10x,'EP',10x,'ECT', & 9x,'ERXF', & /,14x,'ES',10x,'ELF',9x,'EG',10x,'EX') end if if (digits .ge. 8) then fstr = '(/,i6,4f16.8,/,6x,4f16.8,/,6x,4f16.8,'// & '/,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8,'// & '/,6x,4f16.8)' else if (digits .ge. 6) then fstr = '(/,i6,5f14.6,/,6x,5f14.6,/,6x,5f14.6,'// & '/,6x,5f14.6,/,6x,5f14.6,/,6x,3f14.6)' else fstr = '(/,i6,6f12.4,/,6x,6f12.4,/,6x,6f12.4,'// & '/,6x,6f12.4,/,6x,4f12.4)' end if do i = 1, n if (active(i)) then write (iout,fstr) i,aeb(i),aea(i),aeba(i),aeub(i),aeaa(i), & aeopb(i),aeopd(i),aeid(i),aeit(i),aet(i), & aept(i),aebt(i),aeat(i),aett(i),aev(i), & aer(i),aedsp(i),aec(i),aecd(i),aed(i), & aem(i),aep(i),aect(i),aerxf(i),aes(i), & aelf(i),aeg(i),aex(i) end if end do return end c c c ################################################################# c ## ## c ## subroutine viriyze -- inertial virial & pressure values ## c ## ## c ################################################################# c c c "propyze" finds and prints the internal virial, the dE/dV value c and an estimate of the pressure c c subroutine viriyze use atoms use bath use bound use boxes use iounit use units use virial implicit none integer i real*8 temp,pres,dedv c c c print out the components of the internal virial c write (iout,10) (vir(1,i),vir(2,i),vir(3,i),i=1,3) 10 format (/,' Internal Virial Tensor :',11x,3f13.3, & /,36x,3f13.3,/,36x,3f13.3) c c compute the dE/dV value and construct isotropic pressure c if (use_bounds) then temp = kelvin if (temp .eq. 0.0d0) temp = 298.0d0 dedv = (vir(1,1)+vir(2,2)+vir(3,3)) / (3.0d0*volbox) pres = prescon * (dble(n)*gasconst*temp/volbox-dedv) write (iout,20) nint(temp),pres 20 format (/,' Pressure (Temp',i4,' K) :',12x,f13.3, & ' Atmospheres') end if return end c c c ############################################################## c ## ## c ## subroutine saveyze -- save forces or induced dipoles ## c ## ## c ############################################################## c c c "saveyze" prints the atomic forces and/or the induced dipoles c to separate external files c c subroutine saveyze (frame) use atomid use atoms use deriv use files use iounit use output use mpole use polar use potent use units use titles implicit none integer i,j,ii integer frame,lext integer ifrc,iind integer freeunit integer trimtext logical exist character*7 ext character*240 frcfile character*240 indfile c c c save the force vector components for the current frame c if (frcsave) then ifrc = freeunit () if (archive) then frcfile = filename(1:leng) call suffix (frcfile,'frc','old') inquire (file=frcfile,exist=exist) if (exist) then call openend (ifrc,frcfile) else open (unit=ifrc,file=frcfile,status='new') end if else lext = 3 call numeral (frame,ext,lext) frcfile = filename(1:leng)//'.'//ext(1:lext)//'f' call version (frcfile,'new') open (unit=ifrc,file=frcfile,status='new') end if write (ifrc,10) n,title(1:ltitle) 10 format (i6,2x,a) do i = 1, n write (ifrc,20) i,name(i),(-desum(j,i),j=1,3) 20 format (i6,2x,a3,3x,d13.6,3x,d13.6,3x,d13.6) end do close (unit=ifrc) write (iout,30) frcfile(1:trimtext(frcfile)) 30 format (/,' Force Components Written To : ',a) end if c c save the induced dipole moments for the current frame c if (uindsave .and. use_polar) then iind = freeunit () if (archive) then indfile = filename(1:leng) call suffix (indfile,'uind','old') inquire (file=indfile,exist=exist) if (exist) then call openend (iind,indfile) else open (unit=iind,file=indfile,status='new') end if else lext = 3 call numeral (frame,ext,lext) indfile = filename(1:leng)//'.'//ext(1:lext)//'u' call version (indfile,'new') open (unit=iind,file=indfile,status='new') end if write (iind,40) n,title(1:ltitle) 40 format (i6,2x,a) do ii = 1, npole i = ipole(ii) if (polarity(i) .ne. 0.0d0) then write (iind,50) i,name(i),(debye*uind(j,i),j=1,3) 50 format (i6,2x,a3,3f12.6) end if end do close (unit=iind) write (iout,60) indfile(1:trimtext(indfile)) 60 format (/,' Induced Dipoles Written To : ',a) end if return end c c c ############################################################ c ## ## c ## subroutine connyze -- connected atom list analysis ## c ## ## c ############################################################ c c c "connyze" prints information onconnected atoms as lists c of all atom pairs that are 1-2 through 1-5 interactions c c subroutine connyze (active) use atoms use couple use iounit implicit none integer i,j,k integer ntot integer ntot2,ntot3 integer ntot4,ntot5 logical active(*) c c c count the number of 1-2 through 1-5 interatomic pairs c ntot2 = 0 ntot3 = 0 ntot4 = 0 ntot5 = 0 do i = 1, n ntot2 = ntot2 + n12(i) ntot3 = ntot3 + n13(i) ntot4 = ntot4 + n14(i) ntot5 = ntot5 + n15(i) end do ntot2 = ntot2 / 2 ntot3 = ntot3 / 2 ntot4 = ntot4 / 2 ntot5 = ntot5 / 2 ntot = ntot2 + ntot3 + ntot4 + ntot5 if (ntot .ne. 0) then write (iout,10) 10 format (/,' Total Number of Pairwise Atomic Interactions :',/) end if if (ntot2 .ne. 0) then write (iout,20) ntot2 20 format (' Number of 1-2 Pairs',7x,i15) end if if (ntot3 .ne. 0) then write (iout,30) ntot3 30 format (' Number of 1-3 Pairs',7x,i15) end if if (ntot4 .ne. 0) then write (iout,40) ntot4 40 format (' Number of 1-4 Pairs',7x,i15) end if if (ntot5 .ne. 0) then write (iout,50) ntot5 50 format (' Number of 1-5 Pairs',7x,i15) end if c c generate and print the 1-2 connected atomic interactions c if (ntot2 .ne. 0) then write (iout,60) 60 format (/,' List of 1-2 Connected Atomic Interactions :',/) do i = 1, n if (active(i)) then do j = 1, n12(i) k = i12(j,i) if (active(k)) then if (i .lt. k) then write (iout,70) i,k 70 format (2i8) end if end if end do end if end do end if c c generate and print the 1-3 connected atomic interactions c if (ntot3 .ne. 0) then write (iout,80) 80 format (/,' List of 1-3 Connected Atomic Interactions :',/) do i = 1, n if (active(i)) then do j = 1, n13(i) k = i13(j,i) if (active(k)) then if (i .lt. k) then write (iout,90) i,k 90 format (2i8) end if end if end do end if end do end if c c generate and print the 1-4 connected atomic interactions c if (ntot4 .ne. 0) then write (iout,100) 100 format (/,' List of 1-4 Connected Atomic Interactions :',/) do i = 1, n if (active(i)) then do j = 1, n14(i) k = i14(j,i) if (active(k)) then if (i .lt. k) then write (iout,110) i,k 110 format (2i8) end if end if end do end if end do end if c c generate and print the 1-5 connected atomic interactions c if (ntot5 .ne. 0) then write (iout,120) 120 format (/,' List of 1-5 Connected Atomic Interactions :',/) do i = 1, n if (active(i)) then do j = 1, n15(i) k = i15(j,i) if (active(k)) then if (i .lt. k) then write (iout,130) i,k 130 format (2i8) end if end if end do end if end do end if return end c c c ############################################################### c ## ## c ## subroutine paramyze -- force field parameter analysis ## c ## ## c ############################################################### c c c "paramyze" prints the force field parameters used in the c computation of each of the potential energy terms c c subroutine paramyze (active) use angang use angbnd use angpot use angtor use atomid use atoms use bitor use bndstr use cflux use charge use chgpen use chgtrn use dipole use disp use improp use imptor use iounit use korbs use ktrtor use kvdws use math use mplpot use mpole use opbend use opdist use piorbs use pistuf use pitors use polar use polgrp use polpot use potent use repel use solpot use solute use strbnd use strtor use tors use tortor use units use urey use vdw use vdwpot implicit none integer i,j,k integer ia,ib,ic integer id,ie,ig integer ixaxe integer iyaxe integer izaxe integer fold(9) real*8 bla,blc real*8 radj,rad4j real*8 ampli(9) real*8 phase(9) real*8 mpl(13) logical header logical active(*) c c c number of each type of interaction and site c if (n .ne. 0) then write (iout,10) 10 format (/,' Interactions and Sites :',/) write (iout,20) n 20 format (' Atomic Sites',21x,i15) end if if (use_bond .and. nbond.ne.0) then write (iout,30) nbond 30 format (' Bond Stretches',19x,i15) end if if (use_angle .and. nangle.ne.0) then write (iout,40) nangle 40 format (' Angle Bends',22x,i15) end if if (use_strbnd .and. nstrbnd.ne.0) then write (iout,50) nstrbnd 50 format (' Stretch-Bends',20x,i15) end if if (use_urey .and. nurey.ne.0) then write (iout,60) nurey 60 format (' Urey-Bradley',21x,i15) end if if (use_angang .and. nangang.ne.0) then write (iout,70) nangang 70 format (' Angle-Angles',21x,i15) end if if (use_opbend .and. nopbend.ne.0) then write (iout,80) nopbend 80 format (' Out-of-Plane Bends',15x,i15) end if if (use_opdist .and. nopdist.ne.0) then write (iout,90) nopdist 90 format (' Out-of-Plane Distances',11x,i15) end if if (use_improp .and. niprop.ne.0) then write (iout,100) niprop 100 format (' Improper Dihedrals',15x,i15) end if if (use_imptor .and. nitors.ne.0) then write (iout,110) nitors 110 format (' Improper Torsions',16x,i15) end if if (use_tors .and. ntors.ne.0) then write (iout,120) ntors 120 format (' Torsional Angles',17x,i15) end if if (use_pitors .and. npitors.ne.0) then write (iout,130) npitors 130 format (' Pi-Orbital Torsions',14x,i15) end if if (use_strtor .and. nstrtor.ne.0) then write (iout,140) nstrtor 140 format (' Stretch-Torsions',17x,i15) end if if (use_angtor .and. nangtor.ne.0) then write (iout,150) nangtor 150 format (' Angle-Torsions',19x,i15) end if if (use_tortor .and. ntortor.ne.0) then write (iout,160) ntortor 160 format (' Torsion-Torsions',17x,i15) end if if (use_vdw .and. nvdw.ne.0) then write (iout,170) nvdw 170 format (' Van der Waals Sites',14x,i15) end if if (use_repel .and. nrep.ne.0) then write (iout,180) nrep 180 format (' Repulsion Sites',18x,i15) end if if (use_disp .and. ndisp.ne.0) then write (iout,190) ndisp 190 format (' Dispersion Sites',17x,i15) end if if (use_charge .and. nion.ne.0) then write (iout,200) nion 200 format (' Atomic Partial Charges',11x,i15) end if if (use_dipole .and. ndipole.ne.0) then write (iout,210) ndipole 210 format (' Bond Dipole Moments',14x,i15) end if if (use_mpole .and. npole.ne.0) then write (iout,220) npole 220 format (' Atomic Multipoles',16x,i15) end if if (use_chgpen .and. ncp.ne.0) then write (iout,230) ncp 230 format (' Charge Penetration',15x,i15) end if if (use_polar .and. npolar.ne.0) then write (iout,240) npolar 240 format (' Polarizable Sites',16x,i15) end if if (use_chgtrn .and. nct.ne.0) then write (iout,250) nct 250 format (' Charge Transfer Sites',12x,i15) end if if (use_chgflx .and. nbflx.ne.0) then write (iout,260) nbflx 260 format (' Bond Charge Flux',17x,i15) end if if (use_chgflx .and. naflx.ne.0) then write (iout,270) naflx 270 format (' Angle Charge Flux',16x,i15) end if if (use_orbit .and. norbit.ne.0) then write (iout,280) norbit 280 format (' Pisystem Atoms',19x,i15) end if if (use_orbit .and. nbpi.ne.0) then write (iout,290) nbpi 290 format (' Conjugated Pi-Bonds',14x,i15) end if c c parameters used for molecular mechanics atom types c header = .true. do i = 1, n if (active(i)) then if (header) then header = .false. write (iout,300) 300 format (/,' Atom Definition Parameters :', & //,3x,'Atom',2x,'Symbol',2x,'Type', & 2x,'Class',2x,'Atomic',3x,'Mass', & 2x,'Valence',2x,'Description',/) end if write (iout,310) i,name(i),type(i),class(i),atomic(i), & mass(i),valnum(i),story(i) 310 format (i6,5x,a3,2i7,i6,f10.3,i5,5x,a24) end if end do c c parameters used for bond stretching interactions c if (use_bond) then header = .true. do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (active(ia) .or. active(ib)) then if (header) then header = .false. write (iout,320) 320 format (/,' Bond Stretching Parameters :', & //,10x,'Atom Numbers',25x,'KS',7x,'Bond',/) end if write (iout,330) i,ia,ib,bk(i),bl(i) 330 format (i6,3x,2i6,19x,f10.3,f10.4) end if end do end if c c parameters used for angle bending interactions c if (use_angle) then header = .true. do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) if (active(ia) .or. active(ib) .or. active(ic)) then if (header) then header = .false. write (iout,340) 340 format (/,' Angle Bending Parameters :', & //,13x,'Atom Numbers',22x,'KB', & 6x,'Angle',3x,'Fold',4x,'Type',/) end if if (angtyp(i) .eq. 'HARMONIC') then write (iout,350) i,ia,ib,ic,ak(i),anat(i) 350 format (i6,3x,3i6,13x,2f10.3) else if (angtyp(i) .eq. 'IN-PLANE') then write (iout,360) i,ia,ib,ic,ak(i),anat(i) 360 format (i6,3x,3i6,13x,2f10.3,9x,'In-Plane') else if (angtyp(i) .eq. 'LINEAR') then write (iout,370) i,ia,ib,ic,ak(i),anat(i) 370 format (i6,3x,3i6,13x,2f10.3,9x,'Linear') else if (angtyp(i) .eq. 'FOURIER ') then write (iout,380) i,ia,ib,ic,ak(i),anat(i),afld(i) 380 format (i6,3x,3i6,13x,2f10.3,f7.1,2x,'Fourier') end if end if end do end if c c parameters used for stretch-bend interactions c if (use_strbnd) then header = .true. do i = 1, nstrbnd k = isb(1,i) ia = iang(1,k) ib = iang(2,k) ic = iang(3,k) if (active(ia) .or. active(ib) .or. active(ic)) then if (header) then header = .false. write (iout,390) 390 format (/,' Stretch-Bend Parameters :', & //,13x,'Atom Numbers',8x,'KSB 1',5x,'KSB 2', & 6x,'Angle',3x,'Bond 1',3x,'Bond 2',/) end if bla = 0.0d0 blc = 0.0d0 if (isb(2,i) .ne. 0) bla = bl(isb(2,i)) if (isb(3,i) .ne. 0) blc = bl(isb(3,i)) write (iout,400) i,ia,ib,ic,sbk(1,i),sbk(2,i), & anat(k),bla,blc 400 format (i6,3x,3i6,1x,2f10.3,2x,f9.3,2f9.4) end if end do end if c c parameters used for Urey-Bradley interactions c if (use_urey) then header = .true. do i = 1, nurey ia = iury(1,i) ib = iury(2,i) ic = iury(3,i) if (active(ia) .or. active(ic)) then if (header) then header = .false. write (iout,410) 410 format (/,' Urey-Bradley Parameters :', & //,13x,'Atom Numbers',21x,'KUB', & 4x,'Distance',/) end if write (iout,420) i,ia,ib,ic,uk(i),ul(i) 420 format (i6,3x,3i6,13x,f10.3,f10.4) end if end do end if c c parameters used for out-of-plane bend interactions c if (use_opbend) then header = .true. do i = 1, nopbend k = iopb(i) ia = iang(1,k) ib = iang(2,k) ic = iang(3,k) id = iang(4,k) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,430) 430 format (/,' Out-of-Plane Bend Parameters :', & //,17x,'Atom Numbers',19x,'KOPB',/) end if write (iout,440) i,id,ib,ia,ic,opbk(i) 440 format (i6,3x,4i6,9x,f10.3) end if end do end if c c parameters used for out-of-plane distance interactions c if (use_opdist) then header = .true. do i = 1, nopdist ia = iopd(1,i) ib = iopd(2,i) ic = iopd(3,i) id = iopd(4,i) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,450) 450 format (/,' Out-of-Plane Distance Parameters :', & //,17x,'Atom Numbers',19x,'KOPD',/) end if write (iout,460) i,ia,ib,ic,id,opdk(i) 460 format (i6,3x,4i6,9x,f10.3) end if end do end if c c parameters used for improper dihedral interactions c if (use_improp) then header = .true. do i = 1, niprop ia = iiprop(1,i) ib = iiprop(2,i) ic = iiprop(3,i) id = iiprop(4,i) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,470) 470 format (/,' Improper Dihedral Parameters :', & //,17x,'Atom Numbers',19x,'KID', & 4x,'Dihedral',/) end if write (iout,480) i,ia,ib,ic,id,kprop(i),vprop(i) 480 format (i6,3x,4i6,9x,2f10.4) end if end do end if c c parameters used for improper torsion interactions c if (use_imptor) then header = .true. do i = 1, nitors ia = iitors(1,i) ib = iitors(2,i) ic = iitors(3,i) id = iitors(4,i) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,490) 490 format (/,' Improper Torsion Parameters :', & //,17x,'Atom Numbers',11x, & 'Amplitude, Phase and Periodicity',/) end if j = 0 if (itors1(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 1 ampli(j) = itors1(1,i) phase(j) = itors1(2,i) end if if (itors2(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 2 ampli(j) = itors2(1,i) phase(j) = itors2(2,i) end if if (itors3(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 3 ampli(j) = itors3(1,i) phase(j) = itors3(2,i) end if if (j .eq. 0) then write (iout,500) i,ia,ib,ic,id 500 format (i6,3x,4i6) else if (j .eq. 1) then write (iout,510) i,ia,ib,ic,id, & ampli(1),phase(1),fold(1) 510 format (i6,3x,4i6,10x,f10.3,f8.1,i4) else if (j .eq. 2) then write (iout,520) i,ia,ib,ic,id,(ampli(k), & phase(k),fold(k),k=1,j) 520 format (i6,3x,4i6,2x,2(f10.3,f6.1,i4)) else write (iout,530) i,ia,ib,ic,id,(ampli(k), & nint(phase(k)),fold(k),k=1,j) 530 format (i6,3x,4i6,4x,3(f8.3,i4,'/',i1)) end if end if end do end if c c parameters used for torsional interactions c if (use_tors) then header = .true. do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,540) 540 format (/,' Torsional Angle Parameters :', & //,17x,'Atom Numbers',11x, & 'Amplitude, Phase and Periodicity',/) end if j = 0 if (tors1(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 1 ampli(j) = tors1(1,i) phase(j) = tors1(2,i) end if if (tors2(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 2 ampli(j) = tors2(1,i) phase(j) = tors2(2,i) end if if (tors3(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 3 ampli(j) = tors3(1,i) phase(j) = tors3(2,i) end if if (tors4(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 4 ampli(j) = tors4(1,i) phase(j) = tors4(2,i) end if if (tors5(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 5 ampli(j) = tors5(1,i) phase(j) = tors5(2,i) end if if (tors6(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 6 ampli(j) = tors6(1,i) phase(j) = tors6(2,i) end if if (j .eq. 0) then write (iout,550) i,ia,ib,ic,id 550 format (i6,3x,4i6) else write (iout,560) i,ia,ib,ic,id,(ampli(k), & nint(phase(k)),fold(k),k=1,j) 560 format (i6,3x,4i6,4x,6(f8.3,i4,'/',i1)) end if end if end do end if c c parameters used for pi-system torsion interactions c if (use_pitors) then header = .true. do i = 1, npitors ia = ipit(1,i) ib = ipit(2,i) ic = ipit(3,i) id = ipit(4,i) ie = ipit(5,i) ig = ipit(6,i) if (active(ia) .or. active(ib) .or. active(ic) .or. & active(id) .or. active(ie) .or. active(ig)) then if (header) then header = .false. write (iout,570) 570 format (/,' Pi-Orbital Torsion Parameters :', & //,10x,'Atom Numbers',19x,'Amplitude',/) end if write (iout,580) i,ic,id,kpit(i) 580 format (i6,3x,2i6,19x,f10.4) end if end do end if c c parameters used for stretch-torsion interactions c if (use_strtor) then header = .true. do i = 1, nstrtor k = ist(1,i) ia = itors(1,k) ib = itors(2,k) ic = itors(3,k) id = itors(4,k) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,590) 590 format (/,' Stretch-Torsion Parameters :', & //,17x,'Atom Numbers',10x,'Bond', & 5x,'Amplitude and Phase (1-3 Fold)',/) end if ampli(1) = kst(1,i) phase(1) = tors1(2,k) ampli(2) = kst(2,i) phase(2) = tors2(2,k) ampli(3) = kst(3,i) phase(3) = tors3(2,k) ampli(4) = kst(4,i) phase(4) = tors1(2,k) ampli(5) = kst(5,i) phase(5) = tors2(2,k) ampli(6) = kst(6,i) phase(6) = tors3(2,k) ampli(7) = kst(7,i) phase(7) = tors1(2,k) ampli(8) = kst(8,i) phase(8) = tors2(2,k) ampli(9) = kst(9,i) phase(9) = tors3(2,k) write (iout,600) i,ia,ib,ic,id, & '1st',(ampli(k),nint(phase(k)),k=1,3), & '2nd',(ampli(k),nint(phase(k)),k=4,6), & '3rd',(ampli(k),nint(phase(k)),k=7,9) 600 format (i6,3x,4i6,7x,a3,3x,3(f7.3,i4), & /,40x,a3,3x,3(f7.3,i4), & /,40x,a3,3x,3(f7.3,i4)) end if end do end if c c parameters used for angle-torsion interactions c if (use_angtor) then header = .true. do i = 1, nangtor k = iat(1,i) ia = itors(1,k) ib = itors(2,k) ic = itors(3,k) id = itors(4,k) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,610) 610 format (/,' Angle-Torsion Parameters :', & //,17x,'Atom Numbers',10x,'Angle', & 4x,'Amplitude and Phase (1-3 Fold)',/) end if ampli(1) = kant(1,i) phase(1) = tors1(2,k) ampli(2) = kant(2,i) phase(2) = tors2(2,k) ampli(3) = kant(3,i) phase(3) = tors3(2,k) ampli(4) = kant(4,i) phase(4) = tors1(2,k) ampli(5) = kant(5,i) phase(5) = tors2(2,k) ampli(6) = kant(6,i) phase(6) = tors3(2,k) write (iout,620) i,ia,ib,ic,id, & '1st',(ampli(k),nint(phase(k)),k=1,3), & '2nd',(ampli(k),nint(phase(k)),k=4,6) 620 format (i6,3x,4i6,7x,a3,3x,3(f7.3,i4), & /,40x,a3,3x,3(f7.3,i4)) end if end do end if c c parameters used for torsion-torsion interactions c if (use_tortor) then header = .true. do i = 1, ntortor k = itt(1,i) ia = ibitor(1,k) ib = ibitor(2,k) ic = ibitor(3,k) id = ibitor(4,k) ie = ibitor(5,k) if (active(ia) .or. active(ib) .or. active(ic) .or. & active(id) .or. active(ie)) then if (header) then header = .false. write (iout,630) 630 format (/,' Torsion-Torsion Parameters :', & //,20x,'Atom Numbers',15x,'Spline Grid', & 6x,'Tier',/) end if j = itt(2,i) write (iout,640) i,ia,ib,ic,id,ie,tnx(j),tny(j),ttier(j) 640 format (i6,3x,5i6,7x,2i6,7x,a3) end if end do end if c c parameters used for van der Waals interactions c if (use_vdw) then header = .true. k = 0 do i = 1, n if (active(i)) then k = k + 1 if (header) then header = .false. write (iout,650) 650 format (/,' Van der Waals Parameters :', & //,10x,'Atom Number',7x,'Size', & 3x,'Epsilon',3x,'Size 1-4', & 3x,'Eps 1-4',3x,'Reduction',/) end if j = class(i) if (vdwindex .eq. 'TYPE') j = type(i) if (rad(j).eq.rad4(j) .and. eps(j).eq.eps4(j)) then radj = rad(j) if (radsiz .eq. 'DIAMETER') radj = 2.0d0 * radj if (radtyp .eq. 'SIGMA') radj = radj / twosix if (reduct(j) .eq. 0.0d0) then write (iout,660) k,i,radj,eps(j) 660 format (i6,3x,i6,7x,2f10.4) else write (iout,670) k,i,radj,eps(j),reduct(j) 670 format (i6,3x,i6,7x,2f10.4,22x,f10.4) end if else radj = rad(j) rad4j = rad4(j) if (radsiz .eq. 'DIAMETER') then radj = 2.0d0 * radj rad4j = 2.0d0 * rad4j end if if (radtyp .eq. 'SIGMA') then radj = radj / twosix rad4j = rad4j / twosix end if if (reduct(j) .eq. 0.0d0) then write (iout,680) k,i,radj,eps(j),rad4j,eps4(j) 680 format (i6,3x,i6,7x,2f10.4,1x,2f10.4) else write (iout,690) k,i,radj,eps(j),rad4j, & eps4(j),reduct(j) 690 format (i6,3x,i6,7x,2f10.4,1x,2f10.4,1x,f10.4) end if end if end if end do end if c c parameters used for Pauli repulsion interactions c if (use_repel) then header = .true. do i = 1, nrep ia = irep(i) if (active(ia)) then if (header) then header = .false. write (iout,700) 700 format (/,' Pauli Repulsion Parameters :', & //,10x,'Atom Number',25x,'Size',6x,'Damp', & 3x,'Valence',/) end if write (iout,710) i,ia,sizpr(i),dmppr(i),elepr(i) 710 format (i6,3x,i6,25x,2f10.4,f10.3) end if end do end if c c parameters used for damped dispersion interactions c if (use_disp) then header = .true. do i = 1, ndisp ia = idisp(i) if (active(ia)) then if (header) then header = .false. write (iout,720) 720 format (/,' Damped Dispersion Parameters :', & //,10x,'Atom Number',26x,'C6',7x,'Damp',/) end if write (iout,730) i,ia,csix(i),adisp(i) 730 format (i6,3x,i6,25x,f10.3,f10.4) end if end do end if c c parameters used for atomic partial charges c if (use_charge .or. use_chgdpl) then header = .true. do i = 1, nion ia = iion(i) ib = jion(ia) ic = kion(ia) if (active(ia) .or. active(ic)) then if (header) then header = .false. write (iout,740) 740 format (/,' Atomic Partial Charge Parameters :', & /,45x,'Neighbor',3x,'Cutoff', & /,10x,'Atom Number',13x,'Charge', & 7x,'Site',6x,'Site',/) end if if (ia.eq.ib .and. ia.eq.ic) then write (iout,750) i,ia,pchg(ia) 750 format (i6,3x,i6,15x,f10.4) else write (iout,760) i,ia,pchg(ia),ib,ic 760 format (i6,3x,i6,15x,f10.4,5x,i6,4x,i6) end if end if end do end if c c parameters used for bond dipole moments c if (use_dipole .or. use_chgdpl) then header = .true. do i = 1, ndipole ia = idpl(1,i) ib = idpl(2,i) if (active(ia) .or. active(ib)) then if (header) then header = .false. write (iout,770) 770 format (/,' Bond Dipole Moment Parameters :', & //,10x,'Atom Numbers',22x,'Dipole', & 3x,'Position',/) end if write (iout,780) i,ia,ib,bdpl(i),sdpl(i) 780 format (i6,3x,2i6,19x,f10.4,f10.3) end if end do end if c c parameters used for atomic multipole moments c if (use_mpole) then header = .true. do i = 1, npole ia = ipole(i) if (active(ia)) then if (header) then header = .false. write (iout,790) 790 format (/,' Atomic Multipole Parameters :', & //,11x,'Atom',3x,'Z-Axis',1x,'X-Axis', & 1x,'Y-Axis',2x, & 'Frame',11x,'Multipole Moments',/) end if izaxe = zaxis(ia) ixaxe = xaxis(ia) iyaxe = yaxis(ia) if (iyaxe .lt. 0) iyaxe = -iyaxe mpl(1) = pole(1,ia) do j = 2, 4 mpl(j) = pole(j,ia) / bohr end do do j = 5, 13 mpl(j) = 3.0d0 * pole(j,ia) / bohr**2 end do if (izaxe .eq. 0) then write (iout,800) i,ia,polaxe(i), & (mpl(j),j=1,5),mpl(8),mpl(9), & (mpl(j),j=11,13) 800 format (i6,3x,i6,25x,a8,2x,f9.5,/,50x,3f9.5, & /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5) else if (ixaxe .eq. 0) then write (iout,810) i,ia,izaxe,polaxe(i), & (mpl(j),j=1,5),mpl(8),mpl(9), & (mpl(j),j=11,13) 810 format (i6,3x,i6,1x,i7,17x,a8,2x,f9.5,/,50x,3f9.5, & /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5) else if (iyaxe .eq. 0) then write (iout,820) i,ia,izaxe,ixaxe,polaxe(i), & (mpl(j),j=1,5),mpl(8),mpl(9), & (mpl(j),j=11,13) 820 format (i6,3x,i6,1x,2i7,10x,a8,2x,f9.5,/,50x,3f9.5, & /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5) else write (iout,830) i,ia,izaxe,ixaxe,iyaxe,polaxe(i), & (mpl(j),j=1,5),mpl(8),mpl(9), & (mpl(j),j=11,13) 830 format (i6,3x,i6,1x,3i7,3x,a8,2x,f9.5,/,50x,3f9.5, & /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5) end if end if end do end if c c parameters used for charge penetration damping c if (use_chgpen) then header = .true. do i = 1, npole ia = ipole(i) if (active(ia)) then if (header) then header = .false. write (iout,840) 840 format (/,' Charge Penetration Parameters :', & //,10x,'Atom Number',25x,'Core',3x,'Valence', & 6x,'Damp',/) end if write (iout,850) i,ia,pcore(ia),pval(ia),palpha(ia) 850 format (i6,3x,i6,25x,2f10.3,f10.4) end if end do end if c c parameters used for dipole polarizability c if (use_polar) then header = .true. do i = 1, npole ia = ipole(i) if (active(ia)) then if (header) then header = .false. if (use_tholed) then write (iout,860) 860 format (/,' Dipole Polarizability Parameters :', & //,10x,'Atom Number',5x,'Alpha',4x,'Thole', & 3x,'TholeD',6x,'Polarization Group',/) else if (use_thole) then write (iout,870) 870 format (/,' Dipole Polarizability Parameters :', & //,10x,'Atom Number',5x,'Alpha',4x,'Thole', & 6x,'Polarization Group',/) else write (iout,880) 880 format (/,' Dipole Polarizability Parameters :', & //,10x,'Atom Number',5x,'Alpha', & 6x,'Polarization Group',/) end if end if if (use_tholed) then write (iout,890) i,ia,polarity(ia),thole(ia), & tholed(ia),(ip11(j,ia),j=1,np11(ia)) 890 format (i6,3x,i6,6x,f10.4,2f9.3,3x,120i6) else if (use_thole) then write (iout,900) i,ia,polarity(ia),thole(ia), & (ip11(j,ia),j=1,np11(ia)) 900 format (i6,3x,i6,6x,f10.4,f9.3,3x,120i6) else write (iout,910) i,ia,polarity(ia), & (ip11(j,ia),j=1,np11(ia)) 910 format (i6,3x,i6,6x,f10.4,3x,120i6) end if end if end do end if c c parameters used for charge transfer interactions c if (use_chgtrn) then header = .true. do i = 1, npole ia = ipole(i) if (active(ia)) then if (header) then header = .false. write (iout,920) 920 format (/,' Charge Transfer Parameters :', & //,10x,'Atom Number',23x,'Charge', & 6x,'Damp',/) end if write (iout,930) i,ia,chgct(ia),dmpct(ia) 930 format (i6,3x,i6,25x,f10.3,f10.4) end if end do end if c c parameters used for bond charge flux interactions c if (use_chgflx) then k = 0 header = .true. do i = 1, nbond if (bflx(i) .ne. 0.0d0) then ia = ibnd(1,i) ib = ibnd(2,i) if (active(ia) .or. active(ib)) then if (header) then header = .false. write (iout,940) 940 format (/,' Bond Charge Flux Parameters :', & //,10x,'Atom Numbers',24x,'KCFB',/) end if k = k + 1 write (iout,950) k,ia,ib,bflx(i) 950 format (i6,3x,2i6,19x,f10.4) end if end if end do end if c c parameters used for angle charge flux interactions c if (use_chgflx) then k = 0 header = .true. do i = 1, nangle if (aflx(1,i).ne.0.0d0 .or. aflx(2,i).ne.0.0d0 .or. & abflx(1,i).ne.0.0d0 .or. abflx(2,i).ne.0.0d0) then ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) if (active(ia) .or. active(ib) .or. active(ic)) then if (header) then header = .false. write (iout,960) 960 format (/,' Angle Charge Flux Parameters :', & //,13x,'Atom Numbers',17x,'KACF1', & 5x,'KACF2',5x,'KBCF1',5x,'KBCF2',/) end if k = k + 1 write (iout,970) k,ia,ib,ic,aflx(1,i),aflx(2,i), & abflx(1,i),abflx(2,i) 970 format (i6,3x,3i6,10x,4f10.4) end if end if end do end if c c parameters used for implicit solvation models c if (use_solv) then header = .true. k = 0 do i = 1, n if (active(i)) then k = k + 1 if (header) then header = .false. if (solvtyp(1:2).eq.'GK') then write (iout,980) 980 format (/,' Implicit Solvation Parameters :', & //,10x,'Atom Number',11x,'Rsolv', & 4x,'Rdescr',5x,'S-HCT',4x,'S-Neck', & 3x,'Surface',/) else if (solvtyp(1:2).eq.'PB') then write (iout,990) 990 format (/,' Implicit Solvation Parameters :', & //,10x,'Atom Number',10x,'Radius', & 5x,'S-HCT',4x,'S-Neck',3x,'Surface',/) else write (iout,1000) 1000 format (/,' Implicit Solvation Parameters :', & //,10x,'Atom Number',10x,'Radius', & 3x,'Surface',/) end if end if if (solvtyp(1:2).eq.'GK') then write (iout,1010) k,i,rsolv(i),rdescr(i),shct(i), & sneck(i),asolv(i) 1010 format (i6,3x,i6,12x,5f10.4) else if (solvtyp(1:2).eq.'PB') then write (iout,1020) k,i,rsolv(i),shct(i),sneck(i), & asolv(i) 1020 format (i6,3x,i6,12x,4f10.4) else write (iout,1030) k,i,rsolv(i),asolv(i) 1030 format (i6,3x,i6,12x,2f10.4) end if end if end do end if c c parameters used for conjugated pisystem atoms c if (use_orbit) then header = .true. do i = 1, norbit ia = iorbit(i) j = class(ia) if (header) then header = .false. write (iout,1040) 1040 format (/,' Conjugated Pi-Atom Parameters :', & //,10x,'Atom Number',14x,'Nelect', & 6x,'Ionize',4x,'Repulsion',/) end if write (iout,1050) i,ia,electron(j),ionize(j),repulse(j) 1050 format (i6,3x,i6,17x,f8.1,3x,f10.4,2x,f10.4) end do end if c c parameters used for conjugated pibond interactions c if (use_orbit) then header = .true. do i = 1, nbpi ia = ibpi(2,i) ib = ibpi(3,i) if (header) then header = .false. write (iout,1060) 1060 format (/,' Conjugated Pi-Bond Parameters :', & //,10x,'Atom Numbers',21x,'K Slope', & 3x,'L Slope',/) end if write (iout,1070) i,ia,ib,kslope(i),lslope(i) 1070 format (i6,3x,2i6,19x,2f10.4) end do end if return end c c c ################################################################# c ## ## c ## subroutine amberyze -- parameter format for Amber setup ## c ## ## c ################################################################# c c c "amberyze" prints the force field parameters in a format needed c by the Amber setup protocol for using AMOEBA within Amber c c subroutine amberyze (active) use angang use angbnd use angpot use angtor use atomid use atoms use bitor use bndstr use iounit use ktrtor use kvdws use math use mpole use opbend use pitors use polar use polgrp use potent use strbnd use strtor use tors use tortor use units use urey use vdw use vdwpot implicit none integer i,j,k,m integer ia,ib,ic integer id,ie,ig integer itx,ity integer ixaxe integer iyaxe integer izaxe integer fold(6) real*8 bla,blc real*8 sbavg real*8 radj,rad4j real*8 ampli(6) real*8 phase(6) real*8 mpl(13) logical header logical active(*) c c c number of each type of AMOEBA interaction and site c if (n .ne. 0) then write (iout,10) 10 format (/,' Total Numbers of Atoms and Interactions :') write (iout,20) n 20 format (/,' Atoms in System',11x,i15) end if if (nbond .ne. 0) then write (iout,30) nbond 30 format (' Bond Stretches',12x,i15) end if if (nangle .ne. 0) then write (iout,40) nangle 40 format (' Angle Bends',15x,i15) end if if (nstrbnd .ne. 0) then write (iout,50) nstrbnd 50 format (' Stretch-Bends',13x,i15) end if if (nurey .ne. 0) then write (iout,60) nurey 60 format (' Urey-Bradley',14x,i15) end if if (nangang .ne. 0) then write (iout,70) nangang 70 format (' Angle-Angles',14x,i15) end if if (nopbend .ne. 0) then write (iout,80) nopbend 80 format (' Out-of-Plane Bends',8x,i15) end if if (ntors .ne. 0) then write (iout,90) ntors 90 format (' Torsional Angles',10x,i15) end if if (npitors .ne. 0) then write (iout,100) npitors 100 format (' Pi-Orbital Torsions',7x,i15) end if if (nstrtor .ne. 0) then write (iout,110) nstrtor 110 format (' Stretch-Torsions',10x,i15) end if if (nangtor .ne. 0) then write (iout,120) nangtor 120 format (' Angle-Torsions',12x,i15) end if if (ntortor .ne. 0) then write (iout,130) ntortor 130 format (' Torsion-Torsions',10x,i15) end if if (npole .ne. 0) then write (iout,140) npole 140 format (' Polarizable Multipoles',4x,i15) end if c c parameters used for molecular mechanics atom types c header = .true. do i = 1, n if (active(i)) then if (header) then header = .false. write (iout,150) 150 format (/,' Atom Definition Parameters :', & //,3x,'Atom',2x,'Symbol',2x,'Type', & 2x,'Class',2x,'Atomic',3x,'Mass', & 2x,'Valence',2x,'Description',/) end if write (iout,160) i,name(i),type(i),class(i),atomic(i), & mass(i),valnum(i),story(i) 160 format (i6,5x,a3,2i7,i6,f10.3,i5,5x,a24) end if end do c c parameters used for van der Waals interactions c if (use_vdw) then header = .true. k = 0 do i = 1, n if (active(i)) then k = k + 1 if (header) then header = .false. write (iout,170) 170 format (/,' Van der Waals Parameters :', & //,10x,'Atom Number',7x,'Radius', & 3x,'Epsilon',3x,'Rad 1-4', & 3x,'Eps 1-4',3x,'Reduction',/) end if j = class(i) if (vdwindex .eq. 'TYPE') j = type(i) if (rad(j).eq.rad4(j) .and. eps(j).eq.eps4(j)) then radj = rad(j) if (radtyp .eq. 'SIGMA') radj = radj / twosix if (reduct(j) .eq. 0.0d0) then write (iout,180) k,i,radj,eps(j) 180 format (i6,3x,i6,7x,2f10.4) else write (iout,190) k,i,radj,eps(j),reduct(j) 190 format (i6,3x,i6,7x,2f10.4,22x,f10.4) end if else radj = rad(j) rad4j = rad4(j) if (radtyp .eq. 'SIGMA') then radj = radj / twosix rad4j = rad4j / twosix end if if (reduct(j) .eq. 0.0d0) then write (iout,200) k,i,radj,eps(j),rad4j,eps4(j) 200 format (i6,3x,i6,7x,2f10.4,1x,2f10.4) else write (iout,210) k,i,radj,eps(j),rad4j, & eps4(j),reduct(j) 210 format (i6,3x,i6,7x,2f10.4,1x,2f10.4,1x,f10.4) end if end if end if end do end if c c parameters used for bond stretching interactions c if (use_bond) then header = .true. do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (active(ia) .or. active(ib)) then if (header) then header = .false. write (iout,220) 220 format (/,' Bond Stretching Parameters :', & //,10x,'Atom Numbers',25x,'KS',7x,'Length',/) end if write (iout,230) i,ia,ib,bk(i),bl(i) 230 format (i6,3x,2i6,19x,f10.3,f10.4) end if end do end if c c parameters used for angle bending interactions c if (use_angle) then header = .true. do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) if (active(ia) .or. active(ib) .or. active(ic)) then if (header) then header = .false. write (iout,240) 240 format (/,' Angle Bending Parameters :', & //,13x,'Atom Numbers',22x,'KB', & 6x,'Angle',3x,'Fold',4x,'Type',/) end if if (angtyp(i) .eq. 'HARMONIC') then write (iout,250) i,ia,ib,ic,ak(i),anat(i) 250 format (i6,3x,3i6,13x,2f10.3) else if (angtyp(i) .eq. 'IN-PLANE') then write (iout,260) i,ia,ib,ic,ak(i),anat(i) 260 format (i6,3x,3i6,13x,2f10.3,9x,'In-Plane') else if (angtyp(i) .eq. 'IN-PLANE') then write (iout,270) i,ia,ib,ic,ak(i),anat(i) 270 format (i6,3x,3i6,13x,2f10.3,9x,'Linear') else if (angtyp(i) .eq. 'FOURIER ') then write (iout,280) i,ia,ib,ic,ak(i),anat(i),afld(i) 280 format (i6,3x,3i6,13x,2f10.3,f7.1,2x,'Fourier') end if end if end do end if c c parameters used for stretch-bend interactions c if (use_strbnd) then header = .true. do i = 1, nstrbnd k = isb(1,i) ia = iang(1,k) ib = iang(2,k) ic = iang(3,k) if (active(ia) .or. active(ib) .or. active(ic)) then if (header) then header = .false. write (iout,290) 290 format (/,' Stretch-Bend Parameters :', & //,13x,'Atom Numbers',11x,'KSB', & 6x,'Angle',3x,'Length1',3x,'Length2',/) end if bla = 0.0d0 blc = 0.0d0 if (isb(2,i) .ne. 0) bla = bl(isb(2,i)) if (isb(3,i) .ne. 0) blc = bl(isb(3,i)) sbavg = (sbk(1,i)+sbk(2,i)) * 0.5d0 write (iout,300) i,ia,ib,ic,sbavg,anat(k),bla,blc 300 format (i6,3x,3i6,f13.4,3f10.4) end if end do end if c c parameters used for Urey-Bradley interactions c if (use_urey) then header = .true. do i = 1, nurey ia = iury(1,i) ic = iury(3,i) if (active(ia) .or. active(ic)) then if (header) then header = .false. write (iout,310) 310 format (/,' Urey-Bradley Parameters :', & //,10x,'Atom Numbers',24x,'KUB', & 4x,'Distance',/) end if write (iout,320) i,ia,ic,uk(i),ul(i) 320 format (i6,3x,2i6,13x,f16.4,f10.4) end if end do end if c c parameters used for out-of-plane bend interactions c if (use_opbend) then header = .true. do i = 1, nopbend k = iopb(i) ia = iang(1,k) ib = iang(2,k) ic = iang(3,k) id = iang(4,k) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,330) 330 format (/,' Out-of-Plane Bending Parameters :', & //,17x,'Atom Numbers',19x,'KOPB',/) end if opbk(i) = opbk(i) * (opbunit/0.02191418d0) write (iout,340) i,id,ib,ia,ic,opbk(i) 340 format (i6,3x,4i6,9x,f10.4) end if end do end if c c parameters used for torsional interactions c if (use_tors) then header = .true. do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,350) 350 format (/,' Torsional Angle Parameters :', & //,17x,'Atom Numbers',11x, & 'Amplitude, Phase and Periodicity',/) end if j = 0 if (tors1(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 1 ampli(j) = tors1(1,i) phase(j) = tors1(2,i) end if if (tors2(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 2 ampli(j) = tors2(1,i) phase(j) = tors2(2,i) end if if (tors3(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 3 ampli(j) = tors3(1,i) phase(j) = tors3(2,i) end if if (tors4(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 4 ampli(j) = tors4(1,i) phase(j) = tors4(2,i) end if if (tors5(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 5 ampli(j) = tors5(1,i) phase(j) = tors5(2,i) end if if (tors6(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 6 ampli(j) = tors6(1,i) phase(j) = tors6(2,i) end if if (j .eq. 0) then write (iout,360) i,ia,ib,ic,id 360 format (i6,3x,4i6) else write (iout,370) i,ia,ib,ic,id,(ampli(k), & nint(phase(k)),fold(k),k=1,j) 370 format (i6,3x,4i6,4x,6(f8.3,i4,'/',i1)) end if end if end do end if c c parameters used for pi-system torsion interactions c if (use_pitors) then header = .true. do i = 1, npitors ia = ipit(1,i) ib = ipit(2,i) ic = ipit(3,i) id = ipit(4,i) ie = ipit(5,i) ig = ipit(6,i) if (active(ia) .or. active(ib) .or. active(ic) .or. & active(id) .or. active(ie) .or. active(ig)) then if (header) then header = .false. write (iout,380) 380 format (/,' Pi-Orbital Torsion Parameters :', & //,10x,'Atom Numbers',19x,'Amplitude',/) end if write (iout,390) i,ic,id,kpit(i) 390 format (i6,3x,2i6,19x,f10.4) end if end do end if c c parameters used for stretch-torsion interactions; this is c the "old" stretch-torsion format for central bond only c if (use_strtor) then header = .true. do i = 1, nstrtor k = ist(1,i) ia = itors(1,k) ib = itors(2,k) ic = itors(3,k) id = itors(4,k) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,400) 400 format (/,' Stretch-Torsion Parameters :', & //,17x,'Atom Numbers',10x,'Length', & 5x,'Torsion Terms',/) end if j = 0 if (kst(4,i) .ne. 0.0d0) then j = j + 1 fold(j) = 1 ampli(j) = kst(4,i) phase(j) = tors1(2,k) end if if (kst(5,i) .ne. 0.0d0) then j = j + 1 fold(j) = 2 ampli(j) = kst(5,i) phase(j) = tors2(2,k) end if if (kst(6,i) .ne. 0.0d0) then j = j + 1 fold(j) = 3 ampli(j) = kst(6,i) phase(j) = tors3(2,k) end if write (iout,410) i,ia,ib,ic,id,bl(ist(3,i)), & (ampli(k),nint(phase(k)), & fold(k),k=1,j) 410 format (i6,3x,4i6,2x,f10.4,1x,3(f8.3,i4,'/',i1)) end if end do end if c c parameters used for angle-torsion interactions; this term c is currently not implemented in Amber c if (use_angtor) then header = .true. do i = 1, nangtor k = iat(1,i) ia = itors(1,k) ib = itors(2,k) ic = itors(3,k) id = itors(4,k) if (active(ia) .or. active(ib) .or. & active(ic) .or. active(id)) then if (header) then header = .false. write (iout,420) 420 format (/,' Angle-Torsion Parameters :', & //,17x,'Atom Numbers',10x,'Length', & 5x,'Torsion Terms',/) end if write (iout,430) i,ia,ib,ic,id 430 format (i6,3x,4i6) end if end do end if c c parameters used for torsion-torsion interactions c if (use_tortor) then header = .true. do i = 1, ntortor k = itt(1,i) ia = ibitor(1,k) ib = ibitor(2,k) ic = ibitor(3,k) id = ibitor(4,k) ie = ibitor(5,k) if (active(ia) .or. active(ib) .or. active(ic) .or. & active(id) .or. active(ie)) then if (header) then header = .false. write (iout,440) 440 format (/,' Torsion-Torsion Parameters :', & //,20x,'Atom Numbers',18x,'Spline Grid',/) end if j = itt(2,i) write (iout,450) i,ia,ib,ic,id,ie,tnx(j),tny(j) 450 format (i6,3x,5i6,10x,2i6) do m = 1, tnx(j)*tny(j) itx = (m-1)/tnx(j) + 1 ity = m - (itx-1)*tny(j) write (iout,460) ttx(itx,j),tty(ity,j),tbf(m,j) 460 format (9x,2f12.1,5x,f12.5) end do end if end do end if c c parameters used for atomic multipole moments c if (use_mpole) then header = .true. do i = 1, npole ia = ipole(i) if (active(ia)) then if (header) then header = .false. write (iout,470) 470 format (/,' Atomic Multipole Parameters :', & //,12x,'Atom',4x,'Coordinate Frame', & ' Definition',7x,'Multipole Moments',/) end if izaxe = zaxis(ia) ixaxe = xaxis(ia) iyaxe = yaxis(ia) if (iyaxe .lt. 0) iyaxe = -iyaxe mpl(1) = pole(1,ia) do j = 2, 4 mpl(j) = pole(j,ia) / bohr end do do j = 5, 13 mpl(j) = 3.0d0 * pole(j,ia) / bohr**2 end do if (izaxe .eq. 0) then write (iout,480) i,ia,0,0,polaxe(ia), & (mpl(j),j=1,5),mpl(8),mpl(9), & (mpl(j),j=11,13) 480 format (i6,3x,i6,1x,2i7,10x,a8,2x,f9.5,/,50x,3f9.5, & /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5) else if (ixaxe .eq. 0) then write (iout,490) i,ia,izaxe,0,polaxe(ia), & (mpl(j),j=1,5),mpl(8),mpl(9), & (mpl(j),j=11,13) 490 format (i6,3x,i6,1x,2i7,10x,a8,2x,f9.5,/,50x,3f9.5, & /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5) else if (iyaxe .eq. 0) then write (iout,500) i,ia,izaxe,ixaxe,polaxe(ia), & (mpl(j),j=1,5),mpl(8),mpl(9), & (mpl(j),j=11,13) 500 format (i6,3x,i6,1x,2i7,10x,a8,2x,f9.5,/,50x,3f9.5, & /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5) else write (iout,510) i,ia,izaxe,ixaxe,iyaxe,polaxe(ia), & (mpl(j),j=1,5),mpl(8),mpl(9), & (mpl(j),j=11,13) 510 format (i6,3x,i6,1x,3i7,3x,a8,2x,f9.5,/,50x,3f9.5, & /,50x,f9.5,/,50x,2f9.5,/,50x,3f9.5) end if end if end do end if c c parameters used for dipole polarizability c if (use_polar) then header = .true. do i = 1, npole ia = ipole(i) if (active(ia)) then if (header) then header = .false. write (iout,520) 520 format (/,' Dipole Polarizability Parameters :', & //,10x,'Atom Number',9x,'Alpha',8x, & 'Polarization Group',/) end if write (iout,530) i,ia,polarity(ia), & (ip11(j,ia),j=1,np11(ia)) 530 format (i6,3x,i6,10x,f10.4,5x,20i6) end if end do end if return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## module angang -- angle-angles in current structure ## c ## ## c ############################################################ c c c nangang total number of angle-angle interactions c iaa angle numbers used in each angle-angle term c kaa force constant for angle-angle cross terms c c module angang implicit none integer nangang integer, allocatable :: iaa(:,:) real*8, allocatable :: kaa(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module angbnd -- bond angle bends in current structure ## c ## ## c ################################################################ c c c nangle total number of angle bends in the system c iang numbers of the atoms in each angle bend c ak harmonic angle force constant (kcal/mole/rad**2) c anat ideal bond angle or phase shift angle (degrees) c afld periodicity for Fourier angle bending term c c module angbnd implicit none integer nangle integer, allocatable :: iang(:,:) real*8, allocatable :: ak(:) real*8, allocatable :: anat(:) real*8, allocatable :: afld(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################### c ## ## c ## subroutine angles -- locate and store bond angles ## c ## ## c ########################################################### c c c "angles" finds the total number of bond angles and stores c the atom numbers of the atoms defining each angle; for c each angle to a trivalent central atom, the third bonded c atom is stored for use in out-of-plane bending c c subroutine angles use angbnd use atmlst use atoms use couple implicit none integer i,j,k,m integer ia,ib,ic c c c initial count of the total number of bond angles c nangle = 0 do i = 1, n m = 0 do j = 1, n12(i)-1 do k = j+1, n12(i) nangle = nangle + 1 end do end do end do c c perform dynamic allocation of some global arrays c if (allocated(iang)) deallocate (iang) if (allocated(balist)) deallocate (balist) if (allocated(anglist)) deallocate (anglist) allocate (iang(4,nangle)) allocate (balist(2,nangle)) allocate (anglist(maxval*(maxval-1)/2,n)) c c store the list of atoms involved in each bond angle c nangle = 0 do i = 1, n m = 0 do j = 1, n12(i)-1 do k = j+1, n12(i) nangle = nangle + 1 m = m + 1 anglist(m,i) = nangle iang(1,nangle) = i12(j,i) iang(2,nangle) = i iang(3,nangle) = i12(k,i) iang(4,nangle) = 0 end do end do c c set the out-of-plane atom for angles at trivalent centers c if (n12(i) .eq. 3) then iang(4,nangle) = i12(1,i) iang(4,nangle-1) = i12(2,i) iang(4,nangle-2) = i12(3,i) end if end do c c store the numbers of the bonds comprising each bond angle c do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) do k = 1, n12(ib) if (i12(k,ib) .eq. ia) balist(1,i) = bndlist(k,ib) if (i12(k,ib) .eq. ic) balist(2,i) = bndlist(k,ib) end do end do return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## module angpot -- angle bend functional form details ## c ## ## c ############################################################# c c c angunit convert angle bending energy to kcal/mole c stbnunit convert stretch-bend energy to kcal/mole c aaunit convert angle-angle energy to kcal/mole c opbunit convert out-of-plane bend energy to kcal/mole c opdunit convert out-of-plane distance energy to kcal/mole c cang cubic coefficient in angle bending potential c qang quartic coefficient in angle bending potential c pang quintic coefficient in angle bending potential c sang sextic coefficient in angle bending potential c copb cubic coefficient in out-of-plane bend potential c qopb quartic coefficient in out-of-plane bend potential c popb quintic coefficient in out-of-plane bend potential c sopb sextic coefficient in out-of-plane bend potential c copd cubic coefficient in out-of-plane distance potential c qopd quartic coefficient in out-of-plane distance potential c popd quintic coefficient in out-of-plane distance potential c sopd sextic coefficient in out-of-plane distance potential c opbtyp type of out-of-plane bend potential energy function c angtyp type of angle bending function for each bond angle c c module angpot implicit none real*8 angunit,stbnunit real*8 aaunit,opbunit real*8 opdunit real*8 cang,qang real*8 pang,sang real*8 copb,qopb real*8 popb,sopb real*8 copd,qopd real*8 popd,sopd character*8 opbtyp character*8, allocatable :: angtyp(:) save end c c c ########################################################## c ## COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder ## c ## All Rights Reserved ## c ########################################################## c c ############################################################## c ## ## c ## module angtor -- angle-torsions in current structure ## c ## ## c ############################################################## c c c nangtor total number of angle-torsion interactions c iat torsion and angle numbers used in angle-torsion c kant 1-, 2- and 3-fold angle-torsion force constants c c module angtor implicit none integer nangtor integer, allocatable :: iat(:,:) real*8, allocatable :: kant(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1996 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## program anneal -- molecular dynamics simulated annealing ## c ## ## c ################################################################## c c c "anneal" performs a simulated annealing protocol by means of c variable temperature molecular dynamics using either linear, c exponential or sigmoidal cooling schedules c c program anneal use atomid use atoms use bath use bndstr use bound use inform use iounit use mdstuf use potent use solute use usage use warp implicit none integer i,next,nequil integer istep,nstep real*8 logmass,factor real*8 ratio,sigmoid real*8 dt,dtsave real*8 hot,cold real*8 fuzzy,sharp real*8 loose,tight logical exist character*1 answer character*8 cooltyp character*240 record character*240 string c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c get choice of statistical ensemble for periodic system c hot = -1.0d0 cold = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) hot call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) cold 10 continue do while (hot.lt.0.0d0 .or. cold.lt.0.0d0) hot = -1.0d0 cold = -1.0d0 write (iout,20) 20 format (/,' Enter the Initial and Final Temperatures in', & ' Degrees K [1000,0] : ',$) read (input,30) record 30 format (a240) read (record,*,err=40,end=40) hot,cold 40 continue if (hot .le. 0.0d0) hot = 1000.0d0 if (cold .le. 0.0d0) cold = 0.0d0 end do c c set the number of steps of initial equilibration c nequil = -1 call nextarg (string,exist) if (exist) read (string,*,err=50,end=50) nequil 50 continue do while (nequil .lt. 0) write (iout,60) 60 format (/,' Enter the Number of Equilibration Steps [0] : ',$) read (input,70,err=80) nequil 70 format (i10) if (nequil .lt. 0) nequil = 0 80 continue end do c c set the number of dynamics steps for the cooling protocol c nstep = -1 call nextarg (string,exist) if (exist) read (string,*,err=90,end=90) nstep 90 continue do while (nstep .lt. 0) write (iout,100) 100 format (/,' Enter the Number of Cooling Protocol Steps', & ' [2000] : ',$) read (input,110,err=120) nstep 110 format (i10) if (nstep .lt. 0) nstep = 2000 120 continue end do c c decide which annealing cooling protocol to use c cooltyp = 'LINEAR' call nextarg (answer,exist) if (.not. exist) then write (iout,130) 130 format (/,' Use Linear, Sigmoidal or Exponential Cooling', & ' Protocol ([L], S or E) : ',$) read (input,140) record 140 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'S') cooltyp = 'SIGMOID' if (answer .eq. 'E') cooltyp = 'EXPONENT' c c get the length of the dynamics time step in picoseconds c dt = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=150,end=150) dt 150 continue do while (dt .lt. 0.0d0) write (iout,160) 160 format (/,' Enter the Time Step Length in Femtoseconds', & ' [1.0] : ',$) read (input,170,err=180) dt 170 format (f20.0) if (dt .le. 0.0d0) dt = 1.0d0 180 continue end do dt = 0.001d0 * dt c c set the time between trajectory snapshot coordinate saves c dtsave = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=190,end=190) dtsave 190 continue do while (dtsave .lt. 0.0d0) write (iout,200) 200 format (/,' Enter Time between Saves in Picoseconds', & ' [0.1] : ',$) read (input,210,err=220) dtsave 210 format (f20.0) if (dtsave .le. 0.0d0) dtsave = 0.1d0 220 continue end do iwrite = nint(dtsave/dt) c c get factor by which atomic weights are to be increased c logmass = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=230,end=230) logmass 230 continue do while (logmass .lt. 0.0d0) write (iout,240) 240 format (/,' Increase Atomic Weights by a Factor of', & ' 10^x [x=0.0] : ',$) read (input,250,err=260) logmass 250 format (f20.0) if (logmass .le. 0.0d0) logmass = 0.0d0 260 continue end do if (logmass .gt. 0.0d0) then factor = 10.0d0**(logmass) do i = 1, n mass(i) = mass(i) * factor end do end if c c rate of deformation change for potential surface smoothing c if (use_smooth) then sharp = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=270,end=270) sharp 270 continue do while (sharp .lt. 0.0d0) write (iout,280) 280 format (/,' Enter Final Desired Deformation Parameter', & ' [0.0] : ',$) read (input,290,err=300) sharp 290 format (f20.0) if (sharp .le. 0.0d0) sharp = 0.0d0 300 continue end do fuzzy = deform - sharp if (fuzzy .le. 0.0d0) fuzzy = 0.0d0 end if c c set values for temperature, pressure and coupling baths c isothermal = .true. isobaric = .false. loose = 100.0d0 * dt tight = 10.0d0 * dt kelvin = hot tautemp = loose c c perform the setup functions needed to run dynamics c call mdinit (dt) c c print out a header lines for the equilibration phase c if (nequil .ne. 0) then write (iout,310) 310 format (/,' Simulated Annealing Equilibration Phase') write (iout,320) nequil,dt,logmass,hot,hot 320 format (/,' Steps:',i6,3x,'Time/Step:',f6.3,' ps',3x, & 'LogMass:',f5.2,3x,'Temp:',f7.1,' to',f7.1) flush (iout) end if c c take the dynamics steps for the equilibration phase c do istep = 1, nequil if (integrate .eq. 'VERLET') then call verlet (istep,dt) else if (integrate .eq. 'BEEMAN') then call beeman (istep,dt) else if (integrate .eq. 'BUSSI') then call bussi (istep,dt) else if (integrate .eq. 'NOSE-HOOVER') then call nose (istep,dt) else if (integrate .eq. 'STOCHASTIC') then call sdstep (istep,dt) else if (integrate .eq. 'GHMC') then call ghmcstep (istep,dt) else if (integrate .eq. 'RIGIDBODY') then call rgdstep (istep,dt) else if (integrate .eq. 'RESPA') then call respa (istep,dt) else call beeman (istep,dt) end if end do c c start the cooling phase from the end of equilibration phase c if (nequil .ne. 0) call mdinit (dt) c c print out a header lines for the cooling protocol c write (iout,330) 330 format (/,' Simulated Annealing Cooling Protocol') write (iout,340) nstep,dt,logmass,hot,cold 340 format (/,' Steps:',i6,3x,'Time/Step:',f6.3,' ps',3x, & 'LogMass:',f5.2,3x,'Temp:',f7.1,' to',f7.1) flush (iout) c c set target temperature using the desired cooling protocol c do istep = 1, nstep ratio = dble(istep) / dble(nstep) if (cooltyp .eq. 'SIGMOID') then ratio = sigmoid (3.5d0,ratio) else if (cooltyp .eq. 'EXPONENT') then ratio = 1.0d0 - exp(-5.0d0*ratio) end if kelvin = hot*(1.0d0-ratio) + cold*ratio tautemp = loose*(1.0d0-ratio) + tight*ratio c c set the deformation value if potential smoothing is used c if (use_smooth) then ratio = (1.0d0-dble(istep)/dble(nstep))**3 deform = sharp + ratio*fuzzy end if c c integrate equations of motion to take a time step c if (integrate .eq. 'VERLET') then call verlet (istep,dt) else if (integrate .eq. 'BEEMAN') then call beeman (istep,dt) else if (integrate .eq. 'BAOAB') then call baoab (istep,dt) else if (integrate .eq. 'BUSSI') then call bussi (istep,dt) else if (integrate .eq. 'NOSE-HOOVER') then call nose (istep,dt) else if (integrate .eq. 'STOCHASTIC') then call sdstep (istep,dt) else if (integrate .eq. 'GHMC') then call ghmcstep (istep,dt) else if (integrate .eq. 'RIGIDBODY') then call rgdstep (istep,dt) else if (integrate .eq. 'RESPA') then call respa (istep,dt) else call beeman (istep,dt) end if end do c c perform any final tasks before program exit c call final end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## program arcedit -- create or extract from an archive ## c ## ## c ############################################################## c c c "arcedit" is a utility program for coordinate files which c concatenates multiple coordinate sets into a new archive or c performs any of several manipulations on an existing archive c c program arcedit use atoms use bound use files use inform use iounit use output use usage implicit none integer i,j,k,nask integer iarc,ixyz,idcd integer start,stop integer step,size integer nmode,mode integer leng1,leng2 integer lext,now integer freeunit integer, allocatable :: list(:) real*8 xr,yr,zr real*8, allocatable :: xold(:) real*8, allocatable :: yold(:) real*8, allocatable :: zold(:) logical exist,query logical first,opened character*1 letter character*7 ext,modtyp character*240 arcfile character*240 dcdfile character*240 xyzfile character*240 record character*240 string c c c initialization and set number of archive modifications c call initial nmode = 8 c c try to get a filename from the command line arguments c call nextarg (arcfile,exist) if (exist) then call basefile (arcfile) call suffix (arcfile,'arc','old') inquire (file=arcfile,exist=exist) end if c c ask for the user specified input archive filename c nask = 0 do while (.not.exist .and. nask.lt.maxask) nask = nask + 1 write (iout,10) 10 format (/,' Enter Coordinate Archive File Name : ',$) read (input,20) arcfile 20 format (a240) call basefile (arcfile) call suffix (arcfile,'arc','old') inquire (file=arcfile,exist=exist) end do if (.not. exist) call fatal c c open the file and get format by inspecting first character c coordtype = 'CARTESIAN' iarc = freeunit () open (unit=iarc,file=arcfile,status='old') rewind (unit=iarc) read (iarc,30) letter 30 format (a1) archive = .false. if (letter .eq. ' ') archive = .true. if (letter.ge.'0' .and. letter.le.'9') archive = .true. binary = (.not. archive) close (unit=iarc) c c find out which archive modification to perform c mode = -1 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=40,end=40) mode if (mode.ge.0 .and. mode.le.nmode) query = .false. end if 40 continue if (query) then write (iout,50) 50 format (/,' The Tinker Archive File Utility Can :', & //,4x,'(1) Create an Archive from Individual Frames', & /,4x,'(2) Extract Individual Frames from an Archive', & /,4x,'(3) Trim an Archive to Remove Atoms or Frames', & /,4x,'(4) Enforce Periodic Boundaries for a Trajectory' & /,4x,'(5) Unfold Periodic Boundaries for a Trajectory', & /,4x,'(6) Remove Periodic Box Size from a Trajectory', & /,4x,'(7) Convert Tinker Archive to Binary DCD File', & /,4x,'(8) Convert Binary DCD File to Tinker Archive') do while (mode.lt.0 .or. mode.gt.nmode) mode = -1 write (iout,60) 60 format (/,' Enter the Number of the Desired Choice : ',$) read (input,70,err=80,end=80) mode 70 format (i10) 80 continue end do end if c c set code for the type of procedure to be performed c if (mode .eq. 0) modtyp = 'EXIT' if (mode .eq. 1) modtyp = 'CREATE' if (mode .eq. 2) modtyp = 'EXTRACT' if (mode .eq. 3) modtyp = 'TRIM' if (mode .eq. 4) modtyp = 'FOLD' if (mode .eq. 5) modtyp = 'UNFOLD' if (mode .eq. 6) modtyp = 'UNBOUND' if (mode .eq. 7) modtyp = 'ARCDCD' if (mode .eq. 8) modtyp = 'DCDARC' c c create and open a new Tinker formatted archive file c if (modtyp .eq. 'CREATE') then iarc = freeunit () call basefile (arcfile) call suffix (arcfile,'arc','new') open (unit=iarc,file=arcfile,status='new') c c open an existing Tinker archive file for processing c else if (archive) then iarc = freeunit () call basefile (arcfile) call suffix (arcfile,'arc','old') inquire (file=arcfile,exist=exist) do while (.not. exist) write (iout,90) 90 format (/,' Enter Coordinate Archive File Name : ',$) read (input,100) arcfile 100 format (a240) call basefile (arcfile) call suffix (arcfile,'arc','old') inquire (file=arcfile,exist=exist) end do open (unit=iarc,file=arcfile,status='old') rewind (unit=iarc) call readxyz (iarc) rewind (unit=iarc) c c open an existing binary DCD trajectory file for processing c else if (binary) then idcd = freeunit () dcdfile = arcfile call basefile (dcdfile) call suffix (dcdfile,'dcd','old') inquire (file=dcdfile,exist=exist) do while (.not. exist) write (iout,110) 110 format (/,' Enter DCD Binary Archive File Name : ',$) read (input,120) dcdfile 120 format (a240) call basefile (dcdfile) call suffix (dcdfile,'dcd','old') inquire (file=dcdfile,exist=exist) end do call nextarg (xyzfile,exist) if (exist) then call basefile (xyzfile) call suffix (xyzfile,'xyz','old') inquire (file=xyzfile,exist=exist) end if nask = 0 do while (.not.exist .and. nask.lt.maxask) nask = nask + 1 write (iout,130) 130 format (/,' Enter Formatted Coordinate File Name : ',$) read (input,140) xyzfile 140 format (a240) call basefile (xyzfile) call suffix (xyzfile,'xyz','old') inquire (file=xyzfile,exist=exist) end do if (.not. exist) call fatal ixyz = freeunit () open (unit=ixyz,file=xyzfile,status='old') rewind (unit=ixyz) call readxyz (ixyz) close (unit=ixyz) open (unit=idcd,file=dcdfile,form='unformatted',status='old') rewind (unit=idcd) first = .true. call readdcd (idcd,first) rewind (unit=idcd) first = .true. end if c c perform dynamic allocation of some global arrays c if (allocated(iuse)) deallocate (iuse) if (allocated(use)) deallocate (use) allocate (iuse(n)) allocate (use(0:n)) c c set all atoms in the system to be treated as active c nuse = n do i = 1, n iuse(i) = i use(i) = .true. end do c c combine individual files into a single archive file c if (modtyp .eq. 'CREATE') then modtyp = 'EXIT' start = 0 stop = 0 step = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=150,end=150) start query = .false. end if call nextarg (string,exist) if (exist) read (string,*,err=150,end=150) stop call nextarg (string,exist) if (exist) read (string,*,err=150,end=150) step 150 continue if (query) then write (iout,160) 160 format (/,' Numbers of First & Last File and Step', & ' Increment : ',$) read (input,170) record 170 format (a240) read (record,*,err=180,end=180) start,stop,step 180 continue end if if (stop .eq. 0) stop = start if (step .eq. 0) step = 1 c c cycle over the user specified coordinate files c i = start do while (i.ge.start .and. i.le.stop) ixyz = freeunit () lext = 3 call numeral (i,ext,lext) xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'old') inquire (file=xyzfile,exist=exist) if (.not.exist .and. i.lt.100) then lext = 2 call numeral (i,ext,lext) xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'old') inquire (file=xyzfile,exist=exist) end if if (.not.exist .and. i.lt.10) then lext = 1 call numeral (i,ext,lext) xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'old') inquire (file=xyzfile,exist=exist) end if if (exist) then open (unit=ixyz,file=xyzfile,status='old') rewind (unit=ixyz) call readxyz (ixyz) close (unit=ixyz) nuse = n do j = 1, n use(j) = .true. end do first = .true. call prtarc (iarc,first) end if i = i + step end do end if c c perform dynamic allocation of some local arrays c if (modtyp .eq. 'TRIM') then size = 40 allocate (list(size)) end if c c decide whether atoms are to be removed from each frame c if (modtyp .eq. 'TRIM') then call active if (nuse .eq. n) then do i = 1, size list(i) = 0 end do i = 1 query = .true. call nextarg (string,exist) if (exist) then do while (i .le. size) read (string,*,err=190,end=190) list(i) if (list(i) .eq. 0) goto 190 i = i + 1 call nextarg (string,exist) end do 190 continue query = .false. end if if (query) then write (iout,200) 200 format (/,' Numbers of the Atoms to be Removed : ',$) read (input,210) record 210 format (a240) read (record,*,err=220,end=220) (list(i),i=1,size) 220 continue end if i = 1 do while (list(i) .ne. 0) list(i) = max(-n,min(n,list(i))) if (list(i) .gt. 0) then k = list(i) if (use(k)) then use(k) = .false. nuse = nuse - 1 end if i = i + 1 else list(i+1) = max(-n,min(n,list(i+1))) do k = abs(list(i)), abs(list(i+1)) if (use(k)) then use(k) = .false. nuse = nuse - 1 end if end do i = i + 2 end if end do c c store index to use in renumbering the untrimmed atoms c k = 0 do i = 1, n iuse(i) = 0 if (use(i)) then k = k + 1 iuse(i) = k end if end do end if c c perform deallocation of some local arrays c deallocate (list) end if c c convert Tinker archive to binary DCD trajectory file c if (modtyp .eq. 'ARCDCD') then modtyp = 'EXIT' archive = .false. binary = .true. first = .true. idcd = freeunit () dcdfile = filename(1:leng)//'.dcd' call version (dcdfile,'new') open (unit=idcd,file=dcdfile,form='unformatted',status='new') do while (.true.) call readxyz (iarc) if (abort) goto 230 call prtarc (idcd,first) end do 230 continue close (unit=idcd) end if c c convert binary DCD trajectory file to Tinker archive c if (modtyp .eq. 'DCDARC') then modtyp = 'EXIT' archive = .true. binary = .false. first = .true. iarc = freeunit () arcfile = filename(1:leng)//'.arc' call version (arcfile,'new') open (unit=iarc,file=arcfile,status='new') do while (.true.) call readdcd (idcd,first) if (abort) goto 240 call prtarc (iarc,first) end do 240 continue close (unit=iarc) end if c c perform dynamic allocation of some local arrays c if (modtyp .ne. 'EXIT') then allocate (xold(n)) allocate (yold(n)) allocate (zold(n)) end if c c get the initial and final coordinate frames to process c if (modtyp .ne. 'EXIT') then now = 1 leng1 = 1 leng2 = leng do i = 1, leng if (filename(i:i) .eq. '/') leng1 = i+1 if (filename(i:i) .eq. ']') leng1 = i+1 if (filename(i:i) .eq. ':') leng1 = i+1 end do do i = leng, leng1, -1 if (filename(i:i) .eq. '.') leng2 = i-1 end do leng = leng2 - leng1 + 1 filename(1:leng) = filename(leng1:leng2) start = 0 stop = 0 step = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=250,end=250) start query = .false. end if call nextarg (string,exist) if (exist) read (string,*,err=250,end=250) stop call nextarg (string,exist) if (exist) read (string,*,err=250,end=250) step 250 continue if (query) then write (iout,260) 260 format (/,' Numbers of First & Last File and Step', & ' [=Exit] : ',$) read (input,270) record 270 format (a240) read (record,*,err=280,end=280) start,stop,step 280 continue end if if (stop .eq. 0) stop = start if (step .eq. 0) step = 1 c c loop over the individual coordinate files to be extracted c do while (start .ne. 0) if (start .le. now) then now = 1 first = .true. if (archive) rewind (unit=iarc) if (binary) rewind (unit=idcd) end if do k = 1, start-now call readcart (iarc,first) end do i = start if (modtyp .eq. 'EXTRACT') then do while (i.ge.start .and. i.le.stop) lext = 3 call numeral (i,ext,lext) call readcart (iarc,first) if (abort) goto 290 nuse = n do j = 1, n use(j) = .true. end do ixyz = freeunit () xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'new') if (archive) then open (unit=ixyz,file=xyzfile,status='new') else if (binary) then open (unit=ixyz,file=xyzfile,form='unformatted', & status='new') end if first = .true. call prtarc (ixyz,first) close (unit=ixyz) i = i + step do k = 1, step-1 call readcart (iarc,first) end do end do else ixyz = freeunit () xyzfile = filename(1:leng) call suffix (xyzfile,'arc','new') if (archive) then open (unit=ixyz,file=xyzfile,status='new') else if (binary) then open (unit=ixyz,file=xyzfile,form='unformatted', & status='new') end if do while (i.ge.start .and. i.le.stop) if (modtyp .eq. 'UNBOUND') use_bounds = .true. call readcart (iarc,first) if (abort) goto 290 if (modtyp .eq. 'FOLD') then call unitcell if (use_bounds) then call lattice call molecule call bounds end if else if (modtyp .eq. 'UNFOLD') then nuse = n do j = 1, n use(j) = .true. end do if (i .eq. start) then call unitcell do j = 1, n xold(j) = x(j) yold(j) = y(j) zold(j) = z(j) end do end if call lattice do j = 1, n xr = x(j) - xold(j) yr = y(j) - yold(j) zr = z(j) - zold(j) if (use_bounds) call image (xr,yr,zr) x(j) = xold(j) + xr y(j) = yold(j) + yr z(j) = zold(j) + zr xold(j) = x(j) yold(j) = y(j) zold(j) = z(j) end do end if if (i .eq. start) first = .true. if (modtyp .eq. 'UNBOUND') use_bounds = .false. call prtarc (ixyz,first) i = i + step do k = 1, step-1 call readcart (iarc,first) end do end do close (unit=ixyz) end if 290 continue now = stop start = 0 stop = 0 step = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=300,end=300) start query = .false. end if call nextarg (string,exist) if (exist) read (string,*,err=300,end=300) stop call nextarg (string,exist) if (exist) read (string,*,err=300,end=300) step 300 continue if (query) then write (iout,310) 310 format (/,' Numbers of First & Last File and Step', & ' [=Exit] : ',$) read (input,320) record 320 format (a240) read (record,*,err=330,end=330) start,stop,step 330 continue end if if (stop .eq. 0) stop = start if (step .eq. 0) step = 1 end do c c perform deallocation of some local arrays c deallocate (xold) deallocate (yold) deallocate (zold) end if c c perform any final tasks before program exit c inquire (unit=iarc,opened=opened) if (opened) close (unit=iarc) inquire (unit=idcd,opened=opened) if (opened) close (unit=idcd) call final end c c c ################################################### c ## COPYRIGHT (C) 1995 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## module argue -- command line arguments at run time ## c ## ## c ############################################################ c c c maxarg maximum number of command line arguments c c narg number of command line arguments to the program c listarg flag to mark available command line arguments c arg strings containing the command line arguments c c module argue implicit none integer maxarg parameter (maxarg=20) integer narg logical listarg(0:maxarg) character*240 arg(0:maxarg) save end c c c ################################################### c ## COPYRIGHT (C) 2004 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module ascii -- selected ASCII character code values ## c ## ## c ############################################################## c c c null decimal value of ASCII code for null (0) c tab decimal value of ASCII code for tab (9) c linefeed decimal value of ASCII code for linefeed (10) c formfeed decimal value of ASCII code for formfeed (12) c carriage decimal value of ASCII code for carriage return (13) c escape decimal value of ASCII code for escape (27) c space decimal value of ASCII code for blank space (32) c exclamation decimal value of ASCII code for exclamation (33) c quote decimal value of ASCII code for double quote (34) c pound decimal value of ASCII code for pound sign (35) c dollar decimal value of ASCII code for dollar sign (36) c percent decimal value of ASCII code for percent sign (37) c ampersand decimal value of ASCII code for ampersand (38) c apostrophe decimal value of ASCII code for single quote (39) c asterisk decimal value of ASCII code for asterisk (42) c plus decimal value of ASCII code for plus sign (43) c comma decimal value of ASCII code for comma (44) c minus decimal value of ASCII code for minus/dash sign (45) c dash decimal value of ASCII code for minus/dash sign (45) c period decimal value of ASCII code for period (46) c frontslash decimal value of ASCII codd for frontslash (47) c colon decimal value of ASCII code for colon (58) c semicolon decimal value of ASCII code for semicolon (59) c equal decimal value of ASCII code for equal sign (61) c question decimal value of ASCII code for question mark (63) c atsign decimal value of ASCII code for at sign (64) c backslash decimal value of ASCII code for backslash (92) c caret decimal value of ASCII code for caret (94) c underbar decimal value of ASCII code for underbar (95) c vertical decimal value of ASCII code for vertical bar (124) c tilde decimal value of ASCII code for tilde (126) c nbsp decimal value of ASCII code for nobreak space (255) c c module ascii implicit none integer null,tab integer linefeed,formfeed integer carriage,escape integer space,exclamation integer quote,pound integer dollar,percent integer ampersand integer apostrophe integer asterisk,plus integer comma,minus integer dash,period integer frontslash,colon integer semicolon,equal integer question,atsign integer backslash,caret integer underbar,vertical integer tilde,nbsp parameter (null=0) parameter (tab=9) parameter (linefeed=10) parameter (formfeed=12) parameter (carriage=13) parameter (escape=27) parameter (space=32) parameter (exclamation=33) parameter (quote=34) parameter (pound=35) parameter (dollar=36) parameter (percent=37) parameter (ampersand=38) parameter (apostrophe=39) parameter (asterisk=42) parameter (plus=43) parameter (comma=44) parameter (minus=45) parameter (dash=45) parameter (period=46) parameter (frontslash=47) parameter (colon=58) parameter (semicolon=59) parameter (equal=61) parameter (question=63) parameter (atsign=64) parameter (backslash=92) parameter (caret=94) parameter (underbar=95) parameter (vertical=124) parameter (tilde=126) parameter (nbsp=255) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module atmlst -- bond and angle local geometry indices ## c ## ## c ################################################################ c c c bndlist numbers of the bonds involving each atom c anglist numbers of the angles centered on each atom c balist numbers of the bonds comprising each angle c c module atmlst implicit none integer, allocatable :: bndlist(:,:) integer, allocatable :: anglist(:,:) integer, allocatable :: balist(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module atomid -- atomic properties for current atoms ## c ## ## c ############################################################## c c c tag integer atom labels from input coordinates file c class atom class number for each atom in the system c atomic atomic number for each atom in the system c valnum expected valence for each atom in the system c mass atomic weight for each atom in the system c name atom name for each atom in the system c tier tier name (residue, motif, etc.) for each atom c story descriptive type for each atom in the system c c module atomid use sizes implicit none integer tag(maxatm) integer class(maxatm) integer atomic(maxatm) integer valnum(maxatm) real*8 mass(maxatm) character*3 name(maxatm) character*3 tier(maxatm) character*24 story(maxatm) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## module atoms -- number, position and type of atoms ## c ## ## c ############################################################ c c c n total number of atoms in the current system c type atom type number for each atom in the system c x current x-coordinate for each atom in the system c y current y-coordinate for each atom in the system c z current z-coordinate for each atom in the system c c module atoms use sizes implicit none integer n integer type(maxatm) real*8 x(maxatm) real*8 y(maxatm) real*8 z(maxatm) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################### c ## ## c ## subroutine attach -- setup of connectivity arrays ## c ## ## c ########################################################### c c c "attach" generates lists of 1-3, 1-4 and 1-5 connectivities c starting from the previously determined list of attached c atoms (ie, 1-2 connectivity) c c subroutine attach use atoms use couple use iounit implicit none integer i,j,k,m integer jj,kk integer maxn13 integer maxn14 integer maxn15 c c c perform dynamic allocation of some global arrays c maxn13 = 3 * maxval maxn14 = 9 * maxval maxn15 = 27 * maxval if (allocated(n13)) deallocate (n13) if (allocated(n14)) deallocate (n14) if (allocated(n15)) deallocate (n15) if (allocated(i13)) deallocate (i13) if (allocated(i14)) deallocate (i14) if (allocated(i15)) deallocate (i15) allocate (n13(n)) allocate (n14(n)) allocate (n15(n)) allocate (i13(maxn13,n)) allocate (i14(maxn14,n)) allocate (i15(maxn15,n)) c c loop over all atoms finding all the 1-3 relationships; c note "n12" and "i12" have already been setup elsewhere c do i = 1, n n13(i) = 0 do j = 1, n12(i) jj = i12(j,i) do k = 1, n12(jj) kk = i12(k,jj) if (kk .eq. i) goto 10 do m = 1, n12(i) if (kk .eq. i12(m,i)) goto 10 end do n13(i) = n13(i) + 1 i13(n13(i),i) = kk 10 continue end do end do if (n13(i) .gt. maxn13) then write (iout,20) i 20 format (/,' ATTACH -- Too many 1-3 Connected Atoms', & ' Attached to Atom',i6) call fatal end if call sort8 (n13(i),i13(1,i)) end do c c loop over all atoms finding all the 1-4 relationships c do i = 1, n n14(i) = 0 do j = 1, n13(i) jj = i13(j,i) do k = 1, n12(jj) kk = i12(k,jj) if (kk .eq. i) goto 30 do m = 1, n12(i) if (kk .eq. i12(m,i)) goto 30 end do do m = 1, n13(i) if (kk .eq. i13(m,i)) goto 30 end do n14(i) = n14(i) + 1 i14(n14(i),i) = kk 30 continue end do end do if (n14(i) .gt. maxn14) then write (iout,40) i 40 format (/,' ATTACH -- Too many 1-4 Connected Atoms', & ' Attached to Atom',i6) call fatal end if call sort8 (n14(i),i14(1,i)) end do c c loop over all atoms finding all the 1-5 relationships c do i = 1, n n15(i) = 0 do j = 1, n14(i) jj = i14(j,i) do k = 1, n12(jj) kk = i12(k,jj) if (kk .eq. i) goto 50 do m = 1, n12(i) if (kk .eq. i12(m,i)) goto 50 end do do m = 1, n13(i) if (kk .eq. i13(m,i)) goto 50 end do do m = 1, n14(i) if (kk .eq. i14(m,i)) goto 50 end do n15(i) = n15(i) + 1 i15(n15(i),i) = kk 50 continue end do end do if (n15(i) .gt. maxn15) then write (iout,60) i 60 format (/,' ATTACH -- Too many 1-5 Connected Atoms', & ' Attached to Atom',i6) call fatal end if call sort8 (n15(i),i15(1,i)) end do return end c c c ############################################################### c ## COPYRIGHT (C) 2016 by Charles Matthews & Ben Leimkuhler ## c ## All Rights Reserved ## c ############################################################### c c ############################################################ c ## ## c ## subroutine baoab -- BAOAB stochastic dynamics step ## c ## ## c ############################################################ c c c "baoab" implements a constrained stochastic dynamics time c step using the geodesic BAOAB scheme c c literature reference: c c B. Leimkuhler and C. Matthews, "Efficient Molecular Dynamics c Using Geodesic Integration and Solvent-Solute Splitting", c Proceedings of the Royal Society A, 472, 20160138 (2016) c c subroutine baoab (istep,dt) use atomid use atoms use freeze use mdstuf use moldyn use units use usage use virial use limits use potent implicit none integer i,j,k integer istep integer nrattle real*8 dt,dtr real*8 dt_2,dt_4 real*8 etot,epot real*8 eksum real*8 temp,pres real*8 ekin(3,3) real*8 stress(3,3) real*8, allocatable :: xold(:) real*8, allocatable :: yold(:) real*8, allocatable :: zold(:) real*8, allocatable :: vfric(:) real*8, allocatable :: vrand(:,:) real*8, allocatable :: derivs(:,:) c c c set some time values for the dynamics integration c dt_2 = 0.5d0 * dt dt_4 = 0.25d0 * dt nrattle = 1 dtr = dt_2 / dble(nrattle) c c make half-step temperature and pressure corrections c call temper (dt,eksum,ekin,temp) c c perform dynamic allocation of some local arrays c allocate (xold(n)) allocate (yold(n)) allocate (zold(n)) allocate (derivs(3,n)) allocate (vfric(n)) allocate (vrand(3,n)) c c find half-step velocities via the Verlet recursion c do i = 1, nuse k = iuse(i) do j = 1, 3 v(j,k) = v(j,k) + a(j,k)*dt_2 end do end do c c find the constraint-corrected full-step velocities c if (use_rattle) call rattle2 (dt) c c take first A step according to the BAOAB sequence c do j = 1, nrattle do i = 1, nuse k = iuse(i) xold(k) = x(k) yold(k) = y(k) zold(k) = z(k) x(k) = x(k) + v(1,k)*dtr y(k) = y(k) + v(2,k)*dtr z(k) = z(k) + v(3,k)*dtr end do if (use_rattle) call rattle (dtr,xold,yold,zold) if (use_rattle) call rattle2 (dtr) end do c c find the constraint-corrected full-step velocities c if (use_rattle) call rattle2 (dt) c c update velocities with frictional and random components c call oprep (dt,vfric,vrand) do i = 1, nuse k = iuse(i) do j = 1, 3 v(j,k) = v(j,k)*vfric(k) + vrand(j,k) end do end do if (use_rattle) call rattle2 (dt) c c take second A step according to the BAOAB sequence c do j = 1, nrattle do i = 1, nuse k = iuse(i) xold(k) = x(k) yold(k) = y(k) zold(k) = z(k) x(k) = x(k) + v(1,k)*dtr y(k) = y(k) + v(2,k)*dtr z(k) = z(k) + v(3,k)*dtr end do if (use_rattle) call rattle (dtr,xold,yold,zold) if (use_rattle) call rattle2 (dtr) end do c c get the potential energy and atomic forces c call gradient (epot,derivs) c c use Newton's second law to get the next accelerations; c find the full-step velocities using the Verlet recursion c do i = 1, nuse k = iuse(i) do j = 1, 3 a(j,k) = -ekcal * derivs(j,k) / mass(k) v(j,k) = v(j,k) + a(j,k)*dt_2 end do end do c c perform deallocation of some local arrays c deallocate (xold) deallocate (yold) deallocate (zold) deallocate (derivs) deallocate (vfric) deallocate (vrand) c c find the constraint-corrected full-step velocities c if (use_rattle) call rattle2 (dt) c c compute and control the temperature and pressure c call kinetic (eksum,ekin,temp) temp = 2.0d0 * eksum / (dble(nfree) * gasconst) call pressure (dt,epot,ekin,temp,pres,stress) c c total energy is sum of kinetic and potential energies c etot = eksum + epot c c compute statistics and save trajectory for this step c call mdstat (istep,dt,etot,epot,eksum,temp,pres) call mdsave (istep,dt,epot,eksum) call mdrest (istep) return end c c c ################################################################# c ## ## c ## subroutine oprep -- frictional & random terms for BAOAB ## c ## ## c ################################################################# c c c "oprep" sets up the frictional and random terms needed to c update positions and velocities for the BAOAB integrator c c subroutine oprep (dt,vfric,vrand) use atoms use atomid use bath use stodyn use units use usage implicit none integer i,j,k real*8 dt,ktm real*8 egdt,normal real*8 vsig,vnorm real*8 vfric(*) real*8 vrand(3,*) logical first save first data first / .true. / c c c set the atomic friction coefficients to the global value c if (first) then first = .false. if (.not. allocated(fgamma)) allocate (fgamma(n)) do i = 1, n fgamma(i) = friction end do end if c c get the frictional and random terms for a BAOAB step c egdt = exp(-(friction * dt)) do i = 1, nuse k = iuse(i) vfric(k) = egdt ktm = boltzmann * kelvin / mass(k) vsig = sqrt(ktm*(1.0-egdt*egdt)) do j = 1, 3 vnorm = normal () vrand(j,k) = vsig * vnorm end do end do return end c c c ################################################### c ## COPYRIGHT (C) 2013 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## program bar -- thermodynamic values from simulation data ## c ## ## c ################################################################## c c c "bar" computes the free energy, enthalpy and entropy difference c between two states via Zwanzig free energy perturbation (FEP) c and Bennett acceptance ratio (BAR) methods c c note in mode 1 the code takes as input trajectory archives A c and B, originally generated for states 0 and 1, respectively; c it then finds the total potential energy for all frames of both c trajectories under control of key files for both states 0 and 1; c in mode 2, the FEP and BAR algorithms are used to compute the c free energy for state 0 --> state 1, and similar estimators c provide the enthalpy and entropy for state 0 --> state 1 c c modifications for NPT simulations by Chengwen Liu, University c of Texas at Austin, October 2015; enthalpy and entropy methods c by Aaron Gordon, Washington University, December 2016 c c literature references: c c C. H. Bennett, "Efficient Estimation of Free Energy Differences c from Monte Carlo Data", Journal of Computational Physics, 22, c 245-268 (1976) c c K. B. Daly, J. B. Benziger, P. G. Debenedetti and c A. Z. Panagiotopoulos, "Massively Parallel Chemical Potential c Calculation on Graphics Processing Units", Computer Physics c Communications, 183, 2054-2062 (2012) [modification for NPT] c c M. A. Wyczalkowski, A. Vitalis and R. V. Pappu, "New Estimators c for Calculating Solvation Entropy and Enthalpy and Comparative c Assessments of Their Accuracy and Precision, Journal of Physical c Chemistry, 114, 8166-8180 (2010) [entropy and enthalpy] c c program bar use iounit implicit none integer mode logical exist,query character*240 string c c c find thermodynamic perturbation procedure to perform c call initial mode = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) mode query = .false. end if 10 continue if (query) then write (iout,20) 20 format (/,' The Tinker Thermodynamic Perturbation Utility', & ' Can :', & //,4x,'(1) Create BAR File with Perturbed Potential', & ' Energies', & /,4x,'(2) Compute Thermodynamic Values from Tinker', & ' BAR File') do while (mode.lt.1 .or. mode.gt.2) mode = 0 write (iout,30) 30 format (/,' Enter the Number of the Desired Choice : ',$) read (input,40,err=50,end=50) mode 40 format (i10) 50 continue end do end if c c create Tinker BAR file or compute thermodynamic values c if (mode .eq. 1) call makebar if (mode .eq. 2) call barcalc call final end c c c ################################################################# c ## ## c ## subroutine makebar -- store trajectory potential energy ## c ## ## c ################################################################# c c subroutine makebar use boxes use files use inform use iounit use keys use output use titles implicit none integer i,next integer ibar,iarc integer ilog,imod integer lenga,lengb integer ltitlea,ltitleb integer nkey0,nkey1 integer nfrma,nfrmb integer maxframe integer freeunit integer trimtext real*8 energy real*8 tempa,tempb real*8, allocatable :: ua0(:) real*8, allocatable :: ua1(:) real*8, allocatable :: ub0(:) real*8, allocatable :: ub1(:) real*8, allocatable :: vola(:) real*8, allocatable :: volb(:) logical exist,first logical recompute logical use_log character*1 answer character*240 filea character*240 fileb character*240 titlea character*240 titleb character*240 barfile character*240 arcfile character*240 logfile character*240 record character*240 string character*240, allocatable :: keys0(:) character*240, allocatable :: keys1(:) c c c get trajectory A and setup mechanics calculation c call initial call getarc (iarc) close (unit=iarc) call mechanic c c store the filename for trajectory A c filea = filename lenga = leng titlea = title ltitlea = ltitle c c perform dynamic allocation of some local arrays c allocate (keys0(nkey)) c c store the keyword values for state 0 c nkey0 = nkey do i = 1, nkey0 keys0(i) = keyline(i) end do c c find the original temperature value for trajectory A c tempa = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) tempa 10 continue do while (tempa .lt. 0.0d0) write (iout,20) 20 format (/,' Enter Trajectory A Temperature in Degrees', & ' K [298] : ',$) read (input,30,err=40) tempa 30 format (f20.0) if (tempa .le. 0.0d0) tempa = 298.0d0 40 continue end do c c get trajectory B and setup mechanics calculation c call getarc (iarc) close (unit=iarc) call mechanic silent = .true. c c store the filename for trajectory B c fileb = filename lengb = leng titleb = title ltitleb = ltitle c c perform dynamic allocation of some local arrays c allocate (keys1(nkey)) c c store the keyword values for state 1 c nkey1 = nkey do i = 1, nkey1 keys1(i) = keyline(i) end do c c find the original temperature value for trajectory B c tempb = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=50,end=50) tempb 50 continue do while (tempb .lt. 0.0d0) write (iout,60) 60 format (/,' Enter Trajectory B Temperature in Degrees', & ' K [298] : ',$) read (input,70,err=80) tempb 70 format (f20.0) if (tempb .le. 0.0d0) tempb = 298.0d0 80 continue end do c c decide whether to use energies from trajectory log files c recompute = .true. answer = ' ' call nextarg (string,exist) if (exist) read (string,*,err=90,end=90) answer 90 continue if (answer .eq. ' ') then answer = 'N' write (iout,100) 100 format (/,' Obtain Energies from Trajectory Logs if', & ' Available [N] : ',$) read (input,110) record 110 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') recompute = .false. c c perform dynamic allocation of some local arrays c maxframe = 1000000 allocate (ua0(maxframe)) allocate (ua1(maxframe)) allocate (ub0(maxframe)) allocate (ub1(maxframe)) allocate (vola(maxframe)) allocate (volb(maxframe)) c c reopen the file corresponding to trajectory A c iarc = freeunit () arcfile = filea call suffix (arcfile,'arc','old') if (archive) then open (unit=iarc,file=arcfile,status ='old') else if (binary) then open (unit=iarc,file=arcfile,form='unformatted',status ='old') end if c c check for log with energies of trajectory A in state 0 c use_log = .false. if (.not. recompute) then logfile = filea(1:lenga) call suffix (logfile,'log','old') inquire (file=logfile,exist=exist) if (exist) then use_log = .true. ilog = freeunit () open (unit=ilog,file=logfile,status='old') end if end if c c reset trajectory A using the parameters for state 0 c if (.not. use_log) then rewind (unit=iarc) first = .true. call readcart (iarc,first) nkey = nkey0 do i = 1, nkey keyline(i) = keys0(i) end do call mechanic end if c c find potential energies for trajectory A in state 0 c write (iout,120) 120 format (/,' Initial Processing for Trajectory A :',/) i = 0 do while (.not. abort) i = i + 1 if (use_log) then abort = .true. do while (abort) read (ilog,130,err=150,end=150) record 130 format (a240) if (record(1:18) .eq. ' Current Potential') then string = record(19:240) read (string,*,err=140,end=140) ua0(i) abort = .false. end if 140 continue end do 150 continue if (abort) i = i - 1 else call cutoffs ua0(i) = energy () call readcart (iarc,first) end if imod = mod(i,100) if ((.not.abort.and.imod.eq.0) .or. (abort.and.imod.ne.0)) then write (iout,160) i 160 format (7x,'Completed',i8,' Coordinate Frames') flush (iout) end if if (i .ge. maxframe) abort = .true. end do c c reset trajectory A using the parameters for state 1 c rewind (unit=iarc) first = .true. call readcart (iarc,first) nkey = nkey1 do i = 1, nkey keyline(i) = keys1(i) end do call mechanic c c find potential energies for trajectory A in state 1 c if (verbose) then write (iout,170) 170 format (/,' Potential Energy Values for Trajectory A :', & //,7x,'Frame',9x,'State 0',9x,'State 1',12x,'Delta',/) end if i = 0 do while (.not. abort) i = i + 1 call cutoffs ua1(i) = energy () vola(i) = volbox if (verbose) then write (iout,180) i,ua0(i),ua1(i),ua1(i)-ua0(i) 180 format (i11,2x,3f16.4) end if call readcart (iarc,first) if (i .ge. maxframe) abort = .true. end do nfrma = i close (unit=iarc) c c save potential energies and volumes for trajectory A c ibar = freeunit () barfile = filea(1:lenga)//'.bar' call version (barfile,'new') open (unit=ibar,file=barfile,status ='new') if (ltitlea .eq. 0) then write (ibar,190) nfrma,tempa 190 format (i8,f10.2) else write (ibar,200) nfrma,tempa,titlea(1:ltitlea) 200 format (i8,f10.2,2x,a) end if do i = 1, nfrma if (vola(i) .eq. 0.0d0) then write (ibar,210) i,ua0(i),ua1(i) 210 format (i8,2x,2f18.4) else write (ibar,220) i,ua0(i),ua1(i),vola(i) 220 format (i8,2x,3f18.4) end if end do flush (ibar) c c reopen the file corresponding to trajectory B c iarc = freeunit () arcfile = fileb call suffix (arcfile,'arc','old') if (archive) then open (unit=iarc,file=arcfile,status ='old') else if (binary) then open (unit=iarc,file=arcfile,form='unformatted',status ='old') end if c c check for log with energies of trajectory B in state 1 c use_log = .false. if (.not. recompute) then logfile = fileb(1:lengb) call suffix (logfile,'log','old') inquire (file=logfile,exist=exist) if (exist) then use_log = .true. ilog = freeunit () open (unit=ilog,file=logfile,status='old') end if end if c c reset trajectory B using the parameters for state 1 c rewind (unit=iarc) first = .true. call readcart (iarc,first) nkey = nkey1 do i = 1, nkey keyline(i) = keys1(i) end do call mechanic c c find potential energies for trajectory B in state 1 c write (iout,230) 230 format (/,' Initial Processing for Trajectory B :',/) i = 0 do while (.not. abort) i = i + 1 if (use_log) then abort = .true. do while (abort) read (ilog,240,err=260,end=260) record 240 format (a240) if (record(1:18) .eq. ' Current Potential') then string = record(19:240) read (string,*,err=250,end=250) ub1(i) abort = .false. end if 250 continue end do 260 continue if (abort) i = i - 1 else call cutoffs ub1(i) = energy () call readcart (iarc,first) end if imod = mod(i,100) if ((.not.abort.and.imod.eq.0) .or. (abort.and.imod.ne.0)) then write (iout,270) i 270 format (7x,'Completed',i8,' Coordinate Frames') flush (iout) end if if (i .ge. maxframe) abort = .true. end do c c reset trajectory B using the parameters for state 0 c rewind (unit=iarc) first = .true. call readcart (iarc,first) nkey = nkey0 do i = 1, nkey keyline(i) = keys0(i) end do call mechanic c c find potential energies for trajectory B in state 0 c if (verbose) then write (iout,280) 280 format (/,' Potential Energy Values for Trajectory B :', & //,7x,'Frame',9x,'State 0',9x,'State 1',12x,'Delta',/) end if i = 0 do while (.not. abort) i = i + 1 call cutoffs ub0(i) = energy () volb(i) = volbox if (verbose) then write (iout,290) i,ub0(i),ub1(i),ub0(i)-ub1(i) 290 format (i11,2x,3f16.4) end if call readcart (iarc,first) if (i .ge. maxframe) abort = .true. end do nfrmb = i close (unit=iarc) c c save potential energies and volumes for trajectory B c if (ltitleb .eq. 0) then write (ibar,300) nfrmb,tempb 300 format (i8,f10.2) else write (ibar,310) nfrmb,tempb,titleb(1:ltitleb) 310 format (i8,f10.2,2x,a) end if do i = 1, nfrmb if (volb(i) .eq. 0.0d0) then write (ibar,320) i,ub0(i),ub1(i) 320 format (i8,2x,2f18.4) else write (ibar,330) i,ub0(i),ub1(i),volb(i) 330 format (i8,2x,3f18.4) end if end do close (unit=ibar) write (iout,340) barfile(1:trimtext(barfile)) 340 format (/,' Potential Energy Values Written To : ',a) c c perform deallocation of some local arrays c deallocate (keys0) deallocate (keys1) c c perform deallocation of some local arrays c deallocate (ua0) deallocate (ua1) deallocate (ub0) deallocate (ub1) deallocate (vola) deallocate (volb) return end c c c ################################################################ c ## ## c ## subroutine barcalc -- get thermodynamics via FEP & BAR ## c ## ## c ################################################################ c c subroutine barcalc use files use inform use iounit use titles use units implicit none integer i,j,k,ibar integer size,next integer iter,maxiter integer ltitlea,ltitleb integer nfrma,nfrmb integer nfrm,nbst integer starta,startb integer stopa,stopb integer stepa,stepb integer maxframe integer freeunit integer trimtext integer, allocatable :: bsta(:) integer, allocatable :: bstb(:) real*8 rt,term real*8 rta,rtb real*8 delta,eps real*8 frma,frmb real*8 tempa,tempb real*8 cold,cnew real*8 top,top2 real*8 bot,bot2 real*8 fterm,rfrm real*8 sum,sum2,bst real*8 vavea,vaveb real*8 vstda,vstdb real*8 vasum,vbsum real*8 vasum2,vbsum2 real*8 stdev,patm real*8 random,ratio real*8 cfore,cback real*8 cfsum,cbsum real*8 cfsum2,cbsum2 real*8 stdcf,stdcb real*8 uave0,uave1 real*8 u0sum,u1sum real*8 u0sum2,u1sum2 real*8 stdev0,stdev1 real*8 hfore,hback real*8 sfore,sback real*8 hfsum,hbsum real*8 hfsum2,hbsum2 real*8 stdhf,stdhb real*8 fore,back real*8 epv,stdpv real*8 hdir,hbar real*8 hsum,hsum2 real*8 sbar,tsbar real*8 fsum,bsum real*8 fvsum,bvsum real*8 fbvsum,vsum real*8 fbsum0,fbsum1 real*8 alpha0,alpha1 real*8, allocatable :: ua0(:) real*8, allocatable :: ua1(:) real*8, allocatable :: ub0(:) real*8, allocatable :: ub1(:) real*8, allocatable :: vola(:) real*8, allocatable :: volb(:) real*8, allocatable :: vloga(:) real*8, allocatable :: vlogb(:) logical exist,query,done character*240 record character*240 string character*240 titlea character*240 titleb character*240 barfile external random c c c ask the user for file with potential energies and volumes c call nextarg (barfile,exist) if (exist) then call basefile (barfile) call suffix (barfile,'bar','old') inquire (file=barfile,exist=exist) end if do while (.not. exist) write (iout,10) 10 format (/,' Enter Potential Energy BAR File Name : ',$) read (input,20) barfile 20 format (a240) call basefile (barfile) call suffix (barfile,'bar','old') inquire (file=barfile,exist=exist) end do c c perform dynamic allocation of some local arrays c maxframe = 1000000 allocate (ua0(maxframe)) allocate (ua1(maxframe)) allocate (ub0(maxframe)) allocate (ub1(maxframe)) allocate (vola(maxframe)) allocate (volb(maxframe)) allocate (vloga(maxframe)) allocate (vlogb(maxframe)) c c set beginning and ending frame for trajectory A c starta = 0 stopa = 0 stepa = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=30,end=30) starta query = .false. end if call nextarg (string,exist) if (exist) read (string,*,err=30,end=30) stopa call nextarg (string,exist) if (exist) read (string,*,err=30,end=30) stepa 30 continue if (query) then write (iout,40) 40 format (/,' First & Last Frame and Step Increment', & ' for Trajectory A : ',$) read (input,50) record 50 format (a120) read (record,*,err=60,end=60) starta,stopa,stepa 60 continue end if if (starta .eq. 0) starta = 1 if (stopa .eq. 0) stopa = maxframe if (stepa .eq. 0) stepa = 1 c c set beginning and ending frame for trajectory B c startb = 0 stopb = 0 stepb = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=70,end=70) startb query = .false. end if call nextarg (string,exist) if (exist) read (string,*,err=70,end=70) stopb call nextarg (string,exist) if (exist) read (string,*,err=70,end=70) stepb 70 continue if (query) then write (iout,80) 80 format (/,' First & Last Frame and Step Increment', & ' for Trajectory B : ',$) read (input,90) record 90 format (a120) read (record,*,err=100,end=100) startb,stopb,stepb 100 continue end if if (startb .eq. 0) startb = 1 if (stopb .eq. 0) stopb = maxframe if (stepb .eq. 0) stepb = 1 c c read potential energies and volumes for trajectory A c ibar = freeunit () open (unit=ibar,file=barfile,status='old') rewind (unit=ibar) nfrma = 0 tempa = 0.0d0 next = 1 read (ibar,110,err=250,end=250) record 110 format (a240) size = trimtext (record) call gettext (record,string,next) read (string,*,err=250,end=250) nfrma call gettext (record,string,next) read (string,*,err=250,end=250) tempa titlea = record(next:trimtext(record)) call trimhead (titlea) ltitlea = trimtext(titlea) do i = 1, starta-1 read (ibar,120,err=160,end=160) 120 format () end do j = 0 stopa = (min(stopa,nfrma)-starta+1)/stepa do i = 1, stopa read (ibar,130,err=160,end=160) record 130 format (a240) j = j + 1 ua0(j) = 0.0d0 ua1(j) = 0.0d0 vola(j) = 0.0d0 read (record,*,err=140,end=140) k,ua0(j),ua1(j),vola(j) 140 continue do k = 1, stepa-1 read (ibar,150,err=160,end=160) 150 format () end do end do 160 continue nfrma = j c c reset the file position to the beginning of trajectory B c rewind (unit=ibar) next = 1 read (ibar,170,err=190,end=190) record 170 format (a240) size = trimtext (record) call gettext (record,string,next) read (string,*,err=190,end=190) k do i = 1, k read (ibar,180,err=190,end=190) 180 format () end do 190 continue c c read potential energies and volumes for trajectory B c nfrmb = 0 tempb = 0.0d0 next = 1 read (ibar,200,err=250,end=250) record 200 format (a240) size = trimtext (record) call gettext (record,string,next) read (string,*,err=250,end=250) nfrmb call gettext (record,string,next) read (string,*,err=250,end=250) tempb titleb = record(next:trimtext(record)) call trimhead (titleb) ltitleb = trimtext(titleb) do i = 1, startb-1 read (ibar,210,err=250,end=250) 210 format () end do j = 0 stopb = (min(stopb,nfrmb)-startb+1)/stepb do i = 1, stopb read (ibar,220,err=250,end=250) record 220 format (a240) j = j + 1 ub0(j) = 0.0d0 ub1(j) = 0.0d0 volb(j) = 0.0d0 read (record,*,err=230,end=230) k,ub0(j),ub1(j),volb(j) 230 continue do k = 1, stepb-1 read (ibar,240,err=250,end=250) 240 format () end do end do 250 continue nfrmb = j close (unit=ibar) c c provide info about trajectories and number of frames c write (iout,260) 260 format (/,' Simulation Trajectory A and Thermodynamic', & ' State 0 : ',/) if (ltitlea .ne. 0) then write (iout,270) titlea(1:ltitlea) 270 format (' ',a) end if write (iout,280) nfrma,tempa 280 format (' Number of Frames :',4x,i8,/,' Temperature :',7x,f10.2) write (iout,290) 290 format (/,' Simulation Trajectory B and Thermodynamic', & ' State 1 : ',/) if (ltitleb .ne. 0) then write (iout,300) titleb(1:ltitleb) 300 format (' ',a) end if write (iout,310) nfrmb,tempb 310 format (' Number of Frames :',4x,i8,/,' Temperature :',7x,f10.2) c c set the frame ratio, temperature and Boltzmann factor c frma = dble(nfrma) frmb = dble(nfrmb) rfrm = frma / frmb rta = gasconst * tempa rtb = gasconst * tempb rt = 0.5d0 * (rta+rtb) c c set the number of bootstrap trials to be generated c nfrm = max(nfrma,nfrmb) nbst = min(100000,nint(1.0d8/dble(nfrm))) bst = dble(nbst) ratio = bst / (bst-1.0d0) c c find average volumes and corrections for both trajectories c vasum = 0.0d0 vasum2 = 0.0d0 vbsum = 0.0d0 vbsum2 = 0.0d0 do k = 1, nbst sum = 0.0d0 do i = 1, nfrma j = int(frma*random()) + 1 sum = sum + vola(j) end do vavea = sum / frma vasum = vasum + vavea vasum2 = vasum2 + vavea*vavea sum = 0.0d0 do i = 1, nfrmb j = int(frmb*random()) + 1 sum = sum + volb(j) end do vaveb = sum / frmb vbsum = vbsum + vaveb vbsum2 = vbsum2 + vaveb*vaveb end do vavea = vasum / bst vstda = sqrt(ratio*(vasum2/bst-vavea*vavea)) vaveb = vbsum / bst vstdb = sqrt(ratio*(vbsum2/bst-vaveb*vaveb)) if (vavea .ne. 0.0d0) then do i = 1, nfrma if (vola(i) .ne. 0.0d0) & vloga(i) = -rta * log(vola(i)/vavea) end do end if if (vaveb .ne. 0.0d0) then do i = 1, nfrmb if (volb(i) .ne. 0.0d0) & vlogb(i) = -rtb * log(volb(i)/vaveb) end do end if c c get the free energy change via thermodynamic perturbation c write (iout,320) 320 format (/,' Free Energy Difference via FEP Method :',/) cfsum = 0.0d0 cfsum2 = 0.0d0 cbsum = 0.0d0 cbsum2 = 0.0d0 do k = 1, nbst sum = 0.0d0 do i = 1, nfrma j = int(frma*random()) + 1 sum = sum + exp((ua0(j)-ua1(j)+vloga(j))/rta) end do cfore = -rta * log(sum/frma) cfsum = cfsum + cfore cfsum2 = cfsum2 + cfore*cfore sum = 0.0d0 do i = 1, nfrmb j = int(frmb*random()) + 1 sum = sum + exp((ub1(j)-ub0(j)+vlogb(j))/rtb) end do cback = rtb * log(sum/frmb) cbsum = cbsum + cback cbsum2 = cbsum2 + cback*cback end do cfore = cfsum / bst stdcf = sqrt(ratio*(cfsum2/bst-cfore*cfore)) cback = cbsum / bst stdcb = sqrt(ratio*(cbsum2/bst-cback*cback)) write (iout,330) cfore,stdcf 330 format (' Free Energy via Forward FEP',9x,f12.4, & ' +/-',f9.4,' Kcal/mol') write (iout,340) cback,stdcb 340 format (' Free Energy via Backward FEP',8x,f12.4, & ' +/-',f9.4,' Kcal/mol') c c determine the initial free energy via the BAR method c write (iout,350) 350 format (/,' Free Energy Difference via BAR Method :',/) maxiter = 100 eps = 0.0001d0 done = .false. iter = 0 cold = 0.0d0 top = 0.0d0 top2 = 0.0d0 do i = 1, nfrmb fterm = 1.0d0 / (1.0d0+exp((ub0(i)-ub1(i)+vlogb(i)+cold)/rtb)) top = top + fterm top2 = top2 + fterm*fterm end do bot = 0.0d0 bot2 = 0.0d0 do i = 1, nfrma fterm = 1.0d0 / (1.0d0+exp((ua1(i)-ua0(i)+vloga(i)-cold)/rta)) bot = bot + fterm bot2 = bot2 + fterm*fterm end do cnew = rt*log(rfrm*top/bot) + cold stdev = sqrt((bot2-bot*bot/frma)/(bot*bot) & + (top2-top*top/frmb)/(top*top)) delta = abs(cnew-cold) write (iout,360) iter,cnew 360 format (' BAR Iteration',i4,19x,f12.4,' Kcal/mol') if (delta .lt. eps) then done = .true. write (iout,370) cnew,stdev 370 format (' BAR Free Energy Estimate',8x,f12.4, & ' +/-',f9.4,' Kcal/mol') end if c c iterate the BAR equation to converge the free energy c do while (.not. done) iter = iter + 1 cold = cnew top = 0.0d0 top2 = 0.0d0 do i = 1, nfrmb fterm = 1.0d0 / (1.0d0+exp((ub0(i)-ub1(i)+vlogb(i) & +cold)/rtb)) top = top + fterm top2 = top2 + fterm*fterm end do bot = 0.0d0 bot2 = 0.0d0 do i = 1, nfrma fterm = 1.0d0 / (1.0d0+exp((ua1(i)-ua0(i)+vloga(i) & -cold)/rta)) bot = bot + fterm bot2 = bot2 + fterm*fterm end do cnew = rt*log(rfrm*top/bot) + cold stdev = sqrt((bot2-bot*bot/frma)/(bot*bot) & + (top2-top*top/frmb)/(top*top)) delta = abs(cnew-cold) write (iout,380) iter,cnew 380 format (' BAR Iteration',i4,19x,f12.4,' Kcal/mol') if (delta .lt. eps) then done = .true. write (iout,390) cnew,stdev 390 format (/,' Free Energy via BAR Estimate',8x,f12.4, & ' +/-',f9.4,' Kcal/mol') end if if (iter.ge.maxiter .and. .not.done) then done = .true. write (iout,400) maxiter 400 format (/,' BAR Free Energy Estimate not Converged', & ' after',i4,' Iterations') call fatal end if end do c c perform dynamic allocation of some local arrays c allocate (bsta(nfrm)) allocate (bstb(nfrm)) c c use bootstrap analysis to estimate statistical error c sum = 0.0d0 sum2 = 0.0d0 do k = 1, nbst done = .false. iter = 0 cold = 0.0d0 top = 0.0d0 do i = 1, nfrmb j = int(frmb*random()) + 1 bstb(i) = j top = top + 1.0d0/(1.0d0+exp((ub0(j)-ub1(j) & +vlogb(i)+cold)/rtb)) end do bot = 0.0d0 do i = 1, nfrma j = int(frma*random()) + 1 bsta(i) = j bot = bot + 1.0d0/(1.0d0+exp((ua1(j)-ua0(j) & +vloga(i)-cold)/rta)) end do cnew = rt*log(rfrm*top/bot) + cold delta = abs(cnew-cold) do while (.not. done) iter = iter + 1 cold = cnew top = 0.0d0 do i = 1, nfrmb j = bstb(i) top = top + 1.0d0/(1.0d0+exp((ub0(j)-ub1(j) & +vlogb(i)+cold)/rtb)) end do bot = 0.0d0 do i = 1, nfrma j = bsta(i) bot = bot + 1.0d0/(1.0d0+exp((ua1(j)-ua0(j) & +vloga(i)-cold)/rta)) end do cnew = rt*log(rfrm*top/bot) + cold delta = abs(cnew-cold) if (delta .lt. eps) then done = .true. sum = sum + cnew sum2 = sum2 + cnew*cnew end if end do end do cnew = sum / bst ratio = bst / (bst-1.0d0) stdev = sqrt(ratio*(sum2/bst-cnew*cnew)) write (iout,410) cnew,stdev 410 format (' Free Energy via BAR Bootstrap',7x,f12.4, & ' +/-',f9.4,' Kcal/mol') c c perform deallocation of some local arrays c deallocate (bsta) deallocate (bstb) c c find the enthalpy directly via average potential energy c write (iout,420) 420 format (/,' Enthalpy from Potential Energy Averages :',/) patm = 1.0d0 epv = (vaveb-vavea) * patm / prescon stdpv = (vstda+vstdb) * patm / prescon u0sum = 0.0d0 u0sum2 = 0.0d0 u1sum = 0.0d0 u1sum2 = 0.0d0 hsum = 0.0d0 hsum2 = 0.0d0 do k = 1, nbst uave0 = 0.0d0 uave1 = 0.0d0 do i = 1, nfrma j = int(frma*random()) + 1 uave0 = uave0 + ua0(j) end do do i = 1, nfrmb j = int(frmb*random()) + 1 uave1 = uave1 + ub1(j) end do uave0 = uave0 / frma uave1 = uave1 / frmb u0sum = u0sum + uave0 u0sum2 = u0sum2 + uave0*uave0 u1sum = u1sum + uave1 u1sum2 = u1sum2 + uave1*uave1 hdir = uave1 - uave0 + epv hsum = hsum + hdir hsum2 = hsum2 + hdir*hdir end do uave0 = u0sum / bst stdev0 = sqrt(ratio*(u0sum2/bst-uave0*uave0)) uave1 = u1sum / bst stdev1 = sqrt(ratio*(u1sum2/bst-uave1*uave1)) hdir = hsum / bst stdev = sqrt(ratio*(hsum2/bst-hdir*hdir)) write (iout,430) uave0,stdev0 430 format (' Average Energy for State 0',10x,f12.4, & ' +/-',f9.4,' Kcal/mol') write (iout,440) uave1,stdev1 440 format (' Average Energy for State 1',10x,f12.4, & ' +/-',f9.4,' Kcal/mol') if (epv .ne. 0.0d0) then write (iout,450) epv,stdpv 450 format (' PdV Work Term for 1 Atm',13x,f12.4, & ' +/-',f9.4,' Kcal/mol') end if write (iout,460) hdir,stdev 460 format (' Enthalpy via Direct Estimate',8x,f12.4, & ' +/-',f9.4,' Kcal/mol') c c calculate the enthalpy via thermodynamic perturbation c write (iout,470) 470 format (/,' Enthalpy and Entropy via FEP Method :',/) hfsum = 0.0d0 hfsum2 = 0.0d0 hbsum = 0.0d0 hbsum2 = 0.0d0 do k = 1, nbst top = 0.0d0 bot = 0.0d0 do i = 1, nfrma j = int(frma*random()) + 1 term = exp((ua0(j)-ua1(j)+vloga(j))/rta) top = top + ua1(j)*term bot = bot + term end do hfore = (top/bot) - uave0 hfsum = hfsum + hfore hfsum2 = hfsum2 + hfore*hfore top = 0.0d0 bot = 0.0d0 do i = 1, nfrmb j = int(frmb*random()) + 1 term = exp((ub1(j)-ub0(j)+vlogb(j))/rtb) top = top + ub0(j)*term bot = bot + term end do hback = -(top/bot) + uave1 hbsum = hbsum + hback hbsum2 = hbsum2 + hback*hback end do hfore = hfsum / bst stdhf = sqrt(ratio*(hfsum2/bst-hfore*hfore)) stdhf = stdhf + stdev0 sfore = (hfore-cfore) / tempa hback = hbsum / bst stdhb = sqrt(ratio*(hbsum2/bst-hback*hback)) stdhb = stdhb + stdev1 sback = (hback-cback) / tempb write (iout,480) hfore,stdhf 480 format (' Enthalpy via Forward FEP',12x,f12.4, & ' +/-',f9.4,' Kcal/mol') write (iout,490) sfore 490 format (' Entropy via Forward FEP',13x,f12.6,' Kcal/mol/K') write (iout,500) -tempa*sfore 500 format (' Forward FEP -T*dS Value',13x,f12.4,' Kcal/mol') write (iout,510) hback,stdhb 510 format (/,' Enthalpy via Backward FEP',11x,f12.4, & ' +/-',f9.4,' Kcal/mol') write (iout,520) sback 520 format (' Entropy via Backward FEP',12x,f12.6,' Kcal/mol/K') write (iout,530) -tempb*sback 530 format (' Backward FEP -T*dS Value',12x,f12.4,' Kcal/mol') c c determine the enthalpy and entropy via the BAR method c write (iout,540) 540 format (/,' Enthalpy and Entropy via BAR Method :',/) hsum = 0.0d0 hsum2 = 0.0d0 do k = 1, nbst fsum = 0.0d0 fvsum = 0.0d0 fbvsum = 0.0d0 vsum = 0.0d0 fbsum0 = 0.0d0 do i = 1, nfrma j = int(frma*random()) + 1 fore = 1.0d0/(1.0d0+exp((ua1(j)-ua0(j)+vloga(j)-cnew)/rta)) back = 1.0d0/(1.0d0+exp((ua0(j)-ua1(j)+vloga(j)+cnew)/rta)) fsum = fsum + fore fvsum = fvsum + fore*ua0(j) fbvsum = fbvsum + fore*back*(ua1(j)-ua0(j)+vloga(j)) vsum = vsum + ua0(j) fbsum0 = fbsum0 + fore*back end do alpha0 = fvsum - fsum*(vsum/frma) + fbvsum bsum = 0.0d0 bvsum = 0.0d0 fbvsum = 0.0d0 vsum = 0.0d0 fbsum1 = 0.0d0 do i = 1, nfrmb j = int(frmb*random()) + 1 fore = 1.0d0/(1.0d0+exp((ub1(j)-ub0(j)+vlogb(j)-cnew)/rtb)) back = 1.0d0/(1.0d0+exp((ub0(j)-ub1(j)+vlogb(j)+cnew)/rtb)) bsum = bsum + back bvsum = bvsum + back*ub1(j) fbvsum = fbvsum + fore*back*(ub1(j)-ub0(j)+vlogb(j)) vsum = vsum + ub1(j) fbsum1 = fbsum1 + fore*back end do alpha1 = bvsum - bsum*(vsum/frmb) - fbvsum hbar = (alpha0-alpha1) / (fbsum0+fbsum1) hsum = hsum + hbar hsum2 = hsum2 + hbar*hbar end do hbar = hsum / bst stdev = sqrt(ratio*(hsum2/bst-hbar*hbar)) tsbar = hbar - cnew sbar = tsbar / (0.5d0*(tempa+tempb)) write (iout,550) hbar,stdev 550 format (' Enthalpy via BAR Estimate',11x,f12.4 & ' +/-',f9.4,' Kcal/mol') write (iout,560) sbar 560 format (' Entropy via BAR Estimate',12x,f12.6,' Kcal/mol/K') write (iout,570) -tsbar 570 format (' BAR Estimate -T*dS Value',12x,f12.4,' Kcal/mol') c c perform deallocation of some local arrays c deallocate (ua0) deallocate (ua1) deallocate (ub0) deallocate (ub1) deallocate (vola) deallocate (volb) deallocate (vloga) deallocate (vlogb) return end c c c ################################################### c ## COPYRIGHT (C) 1996 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine basefile -- get base prefix from a filename ## c ## ## c ################################################################ c c c "basefile" extracts from an input filename the portion c consisting of any directory name and the base filename; c also reads any keyfile and sets information level values c c subroutine basefile (string) use ascii use files implicit none integer i,k,trimtext character*1 letter character*240 prefix character*(*) string c c c account for home directory abbreviation in filename c if (string(1:2) .eq. '~/') then call getenv ('HOME',prefix) string = prefix(1:trimtext(prefix))// & string(2:trimtext(string)) end if c c store the input filename and find its full length c filename = string leng = trimtext (string) c c count the number of characters prior to any extension c k = leng do i = 1, leng letter = string(i:i) if (letter .eq. '/') k = leng c if (letter .eq. '\') k = leng if (ichar(letter) .eq. backslash) k = leng if (letter .eq. ']') k = leng if (letter .eq. ':') k = leng if (letter .eq. '~') k = leng if (letter .eq. '.') k = i - 1 end do c c set the length of the base file name without extension c leng = min(leng,k) c c find the length of any directory name prefix c k = 0 do i = leng, 1, -1 letter = string(i:i) if (letter .eq. '/') k = i c if (letter .eq. '\') k = i if (ichar(letter) .eq. backslash) k = i if (letter .eq. ']') k = i if (letter .eq. ':') k = i if (letter .eq. '~') k = i c if (letter .eq. '.') k = i if (k .ne. 0) goto 10 end do 10 continue ldir = k c c read and store the keywords from the keyfile c call getkey c c get the information level and output style c call control return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module bath -- thermostat and barostat control values ## c ## ## c ############################################################### c c c maxnose maximum length of Nose-Hoover thermostat chain c c voltrial mean number of steps between Monte Carlo moves c kelvin target value for the system temperature (K) c atmsph target value for the system pressure (atm) c tautemp time constant for Berendsen thermostat (psec) c taupres time constant for Berendsen barostat (psec) c compress isothermal compressibility of medium (atm-1) c collide collision frequency for Andersen thermostat c eta velocity value for Bussi-Parrinello barostat c volmove maximum volume move for Monte Carlo barostat (Ang**3) c vbar velocity of log volume for Nose-Hoover barostat c qbar mass of the volume for Nose-Hoover barostat c gbar force for the volume for Nose-Hoover barostat c vnh velocity of each chained Nose-Hoover thermostat c qnh mass for each chained Nose-Hoover thermostat c gnh force for each chained Nose-Hoover thermostat c isothermal logical flag governing use of temperature control c isobaric logical flag governing use of pressure control c anisotrop logical flag governing use of anisotropic pressure c thermostat choice of temperature control method to be used c barostat choice of pressure control method to be used c volscale choice of scaling method for Monte Carlo barostat c c module bath implicit none integer maxnose parameter (maxnose=4) integer voltrial real*8 kelvin,atmsph real*8 tautemp,taupres real*8 compress,collide real*8 eta,volmove real*8 vbar,qbar,gbar real*8 vnh(maxnose) real*8 qnh(maxnose) real*8 gnh(maxnose) logical isothermal logical isobaric logical anisotrop character*9 volscale character*11 barostat character*11 thermostat save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine beeman -- Beeman molecular dynamics step ## c ## ## c ############################################################# c c c "beeman" performs a single molecular dynamics time step c via the Beeman multistep recursion formula; uses original c coefficients or Bernie Brooks' "Better Beeman" values c c literature references: c c D. Beeman, "Some Multistep Methods for Use in Molecular c Dynamics Calculations", Journal of Computational Physics, c 20, 130-139 (1976) c c B. R. Brooks, "Algorithms for Molecular Dynamics at Constant c Temperature and Pressure", DCRT Report, NIH, April 1988 c c subroutine beeman (istep,dt) use atomid use atoms use freeze use ielscf use mdstuf use moldyn use polar use units use usage implicit none integer i,j,k integer istep real*8 dt,dt_x,factor real*8 etot,eksum,epot real*8 temp,pres real*8 part1,part2 real*8 dt_2,term real*8 ekin(3,3) real*8 stress(3,3) real*8, allocatable :: xold(:) real*8, allocatable :: yold(:) real*8, allocatable :: zold(:) real*8, allocatable :: derivs(:,:) c c c set time values and coefficients for Beeman integration c factor = dble(bmnmix) dt_x = dt / factor part1 = 0.5d0*factor + 1.0d0 part2 = part1 - 2.0d0 c c perform dynamic allocation of some local arrays c allocate (xold(n)) allocate (yold(n)) allocate (zold(n)) allocate (derivs(3,n)) c c store the current atom positions, then find half-step c velocities and full-step positions via Beeman recursion c do i = 1, nuse k = iuse(i) do j = 1, 3 v(j,k) = v(j,k) + (part1*a(j,k)-aalt(j,k))*dt_x end do xold(k) = x(k) yold(k) = y(k) zold(k) = z(k) x(k) = x(k) + v(1,k)*dt y(k) = y(k) + v(2,k)*dt z(k) = z(k) + v(3,k)*dt end do c c apply Verlet half-step updates for any auxiliary dipoles c if (use_ielscf) then dt_2 = 0.5d0 * dt do i = 1, nuse k = iuse(i) do j = 1, 3 vaux(j,k) = vaux(j,k) + aaux(j,k)*dt_2 vpaux(j,k) = vpaux(j,k) + apaux(j,k)*dt_2 uaux(j,k) = uaux(j,k) + vaux(j,k)*dt upaux(j,k) = upaux(j,k) + vpaux(j,k)*dt end do end do end if c c get constraint-corrected positions and half-step velocities c if (use_rattle) call rattle (dt,xold,yold,zold) c c get the potential energy and atomic forces c call gradient (epot,derivs) c c make half-step temperature and pressure corrections c call temper2 (dt,temp) call pressure2 (epot,temp) c c use Newton's second law to get the next accelerations; c find the full-step velocities using the Beeman recursion c do i = 1, nuse k = iuse(i) do j = 1, 3 aalt(j,k) = a(j,k) a(j,k) = -ekcal * derivs(j,k) / mass(k) v(j,k) = v(j,k) + (part2*a(j,k)+aalt(j,k))*dt_x end do end do c c apply Verlet full-step updates for any auxiliary dipoles c if (use_ielscf) then term = 2.0d0 / (dt*dt) do i = 1, nuse k = iuse(i) do j = 1, 3 aaux(j,k) = term * (uind(j,k)-uaux(j,k)) apaux(j,k) = term * (uinp(j,k)-upaux(j,k)) vaux(j,k) = vaux(j,k) + aaux(j,k)*dt_2 vpaux(j,k) = vpaux(j,k) + apaux(j,k)*dt_2 end do end do end if c c perform deallocation of some local arrays c deallocate (xold) deallocate (yold) deallocate (zold) deallocate (derivs) c c find the constraint-corrected full-step velocities c if (use_rattle) call rattle2 (dt) c c make full-step temperature and pressure corrections c call temper (dt,eksum,ekin,temp) call pressure (dt,epot,ekin,temp,pres,stress) c c total energy is sum of kinetic and potential energies c etot = eksum + epot c c compute statistics and save trajectory for this step c call mdstat (istep,dt,etot,epot,eksum,temp,pres) call mdsave (istep,dt,epot,eksum) call mdrest (istep) return end c c c ################################################### c ## COPYRIGHT (C) 2003 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine bcuint -- bicubic interpolation of function ## c ## ## c ################################################################ c c c "bcuint" performs a bicubic interpolation of the function c value on a 2D spline grid c c subroutine bcuint (y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy) implicit none integer i real*8 x1,x1l,x1u real*8 x2,x2l,x2u real*8 t,u,ansy real*8 y(4),y12(4) real*8 y1(4),y2(4) real*8 c(4,4) c c c get coefficients, then perform bicubic interpolation c call bcucof (y,y1,y2,y12,x1u-x1l,x2u-x2l,c) t = (x1-x1l) / (x1u-x1l) u = (x2-x2l) / (x2u-x2l) ansy = 0.0d0 do i = 4, 1, -1 ansy = t*ansy + ((c(i,4)*u+c(i,3))*u+c(i,2))*u + c(i,1) end do return end c c c ################################################################# c ## ## c ## subroutine bcuint1 -- bicubic interpolation of gradient ## c ## ## c ################################################################# c c c "bcuint1" performs a bicubic interpolation of the function c value and gradient along the directions of a 2D spline grid c c literature reference: c c W. H. Press, S. A. Teukolsky, W. T. Vetterling and B. P. c Flannery, Numerical Recipes (Fortran), 2nd Ed., Cambridge c University Press, 1992, Section 3.6 c c subroutine bcuint1 (y,y1,y2,y12,x1l,x1u,x2l,x2u, & x1,x2,ansy,ansy1,ansy2) implicit none integer i real*8 x1,x1l,x1u real*8 x2,x2l,x2u real*8 t,u,ansy real*8 ansy1,ansy2 real*8 y(4),y12(4) real*8 y1(4),y2(4) real*8 c(4,4) c c c get coefficients, then perform bicubic interpolation c call bcucof (y,y1,y2,y12,x1u-x1l,x2u-x2l,c) t = (x1-x1l) / (x1u-x1l) u = (x2-x2l) / (x2u-x2l) ansy = 0.0d0 ansy1 = 0.0d0 ansy2 = 0.0d0 do i = 4, 1, -1 ansy = t*ansy + ((c(i,4)*u+c(i,3))*u+c(i,2))*u + c(i,1) ansy1 = u*ansy1 + (3.0d0*c(4,i)*t+2.0d0*c(3,i))*t + c(2,i) ansy2 = t*ansy2 + (3.0d0*c(i,4)*u+2.0d0*c(i,3))*u + c(i,2) end do ansy1 = ansy1 / (x1u-x1l) ansy2 = ansy2 / (x2u-x2l) return end c c c ################################################################ c ## ## c ## subroutine bcuint2 -- bicubic interpolation of Hessian ## c ## ## c ################################################################ c c c "bcuint2" performs a bicubic interpolation of the function value, c gradient and Hessian along the directions of a 2D spline grid c c subroutine bcuint2 (y,y1,y2,y12,x1l,x1u,x2l,x2u,x1,x2,ansy, & ansy1,ansy2,ansy12,ansy11,ansy22) implicit none integer i real*8 x1,x1l,x1u,x2,x2l,x2u real*8 ansy,ansy1,ansy2 real*8 ansy11,ansy22,ansy12 real*8 y(4),y1(4),y2(4),y12(4) real*8 t,u,c(4,4) c c c get coefficients, then perform bicubic interpolation c call bcucof (y,y1,y2,y12,x1u-x1l,x2u-x2l,c) t = (x1-x1l) / (x1u-x1l) u = (x2-x2l) / (x2u-x2l) ansy = 0.0d0 ansy1 = 0.0d0 ansy2 = 0.0d0 ansy11 = 0.0d0 ansy22 = 0.0d0 do i = 4, 1, -1 ansy = t*ansy + ((c(i,4)*u+c(i,3))*u+c(i,2))*u + c(i,1) ansy1 = u*ansy1 + (3.0d0*c(4,i)*t+2.0d0*c(3,i))*t + c(2,i) ansy2 = t*ansy2 + (3.0d0*c(i,4)*u+2.0d0*c(i,3))*u + c(i,2) ansy11 = u*ansy11 + 6.0d0*c(4,i)*t + 2.0d0*c(3,i) ansy22 = t*ansy22 + 6.0d0*c(i,4)*u + 2.0d0*c(i,3) end do ansy12 = 3.0d0*t*t*((3.0d0*c(4,4)*u+2.0d0*c(4,3))*u+c(4,2)) & + 2.0d0*t*((3.0d0*c(3,4)*u+2.0d0*c(3,3))*u+c(3,2)) & + (3.0d0*c(2,4)*u+2.0d0*c(2,3))*u + c(2,2) ansy1 = ansy1 / (x1u-x1l) ansy2 = ansy2 / (x2u-x2l) ansy11 = ansy11 / ((x1u-x1l)*(x1u-x1l)) ansy22 = ansy22 / ((x2u-x2l)*(x2u-x2l)) ansy12 = ansy12 / ((x1u-x1l)*(x2u-x2l)) return end c c c ################################################################# c ## ## c ## subroutine bcucof -- bicubic interpolation coefficients ## c ## ## c ################################################################# c c c "bcucof" determines the coefficient matrix needed for bicubic c interpolation of a function, gradients and cross derivatives c c literature reference: c c W. H. Press, S. A. Teukolsky, W. T. Vetterling and B. P. c Flannery, Numerical Recipes (Fortran), 2nd Ed., Cambridge c University Press, 1992, Section 3.6 c c subroutine bcucof (y,y1,y2,y12,d1,d2,c) implicit none integer i,j,k real*8 xx,d1,d2,d1d2 real*8 y(4),y12(4) real*8 y1(4),y2(4) real*8 x(16),cl(16) real*8 c(4,4) real*8 wt(16,16) save wt data wt / 1.0d0, 0.0d0,-3.0d0, 2.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & -3.0d0, 0.0d0, 9.0d0,-6.0d0, 2.0d0, 0.0d0,-6.0d0, 4.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & 3.0d0, 0.0d0,-9.0d0, 6.0d0,-2.0d0, 0.0d0, 6.0d0,-4.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0, 0.0d0, 9.0d0,-6.0d0, 0.0d0, 0.0d0,-6.0d0, 4.0d0, & 0.0d0, 0.0d0, 3.0d0,-2.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0, 0.0d0,-9.0d0, 6.0d0, 0.0d0, 0.0d0, 6.0d0,-4.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1.0d0, 0.0d0,-3.0d0, 2.0d0, & -2.0d0, 0.0d0, 6.0d0,-4.0d0, 1.0d0, 0.0d0,-3.0d0, 2.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & -1.0d0, 0.0d0, 3.0d0,-2.0d0, 1.0d0, 0.0d0,-3.0d0, 2.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0, 0.0d0,-3.0d0, 2.0d0, 0.0d0, 0.0d0, 3.0d0,-2.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 3.0d0,-2.0d0, & 0.0d0, 0.0d0,-6.0d0, 4.0d0, 0.0d0, 0.0d0, 3.0d0,-2.0d0, & 0.0d0, 1.0d0,-2.0d0, 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0,-3.0d0, 6.0d0,-3.0d0, 0.0d0, 2.0d0,-4.0d0, 2.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0, 3.0d0,-6.0d0, 3.0d0, 0.0d0,-2.0d0, 4.0d0,-2.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0, 0.0d0,-3.0d0, 3.0d0, 0.0d0, 0.0d0, 2.0d0,-2.0d0, & 0.0d0, 0.0d0,-1.0d0, 1.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0, 0.0d0, 3.0d0,-3.0d0, 0.0d0, 0.0d0,-2.0d0, 2.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 1.0d0,-2.0d0, 1.0d0, & 0.0d0,-2.0d0, 4.0d0,-2.0d0, 0.0d0, 1.0d0,-2.0d0, 1.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0,-1.0d0, 2.0d0,-1.0d0, 0.0d0, 1.0d0,-2.0d0, 1.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, & 0.0d0, 0.0d0, 1.0d0,-1.0d0, 0.0d0, 0.0d0,-1.0d0, 1.0d0, & 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,-1.0d0, 1.0d0, & 0.0d0, 0.0d0, 2.0d0,-2.0d0, 0.0d0, 0.0d0,-1.0d0, 1.0d0 / c c c pack a temporary vector of corner values c d1d2 = d1 * d2 do i = 1, 4 x(i) = y(i) x(i+4) = y1(i) * d1 x(i+8) = y2(i) * d2 x(i+12) = y12(i) * d1d2 end do c c matrix multiply by the stored weight table c do i = 1, 16 xx = 0.0d0 do k = 1, 16 xx = xx + wt(i,k)*x(k) end do cl(i) = xx end do c c unpack the result into the coefficient table c j = 0 do i = 1, 4 do k = 1, 4 j = j + 1 c(i,k) = cl(j) end do end do return end c c c ################################################### c ## COPYRIGHT (C) 2003 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## module bitor -- bitorsions in the current structure ## c ## ## c ############################################################# c c c nbitor total number of bitorsions in the system c ibitor numbers of the atoms in each bitorsion c c module bitor implicit none integer nbitor integer, allocatable :: ibitor(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 2003 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################## c ## ## c ## subroutine bitors -- locate and store bitorsions ## c ## ## c ########################################################## c c c "bitors" finds the total number of bitorsions as pairs c of adjacent torsional angles, and the numbers of the five c atoms defining each bitorsion c c subroutine bitors use angbnd use atoms use bitor use couple implicit none integer i,j,k integer ia,ib,ic,id,ie c c c initial count of the total number of bitorsions c nbitor = 0 do i = 1, nangle ib = iang(1,i) ic = iang(2,i) id = iang(3,i) do j = 1, n12(ib) ia = i12(j,ib) if (ia.ne.ic .and. ia.ne.id) then do k = 1, n12(id) ie = i12(k,id) if (ie.ne.ic .and. ie.ne.ib .and. ie.ne.ia) then nbitor = nbitor + 1 end if end do end if end do end do c c perform dynamic allocation of some global arrays c if (allocated(ibitor)) deallocate (ibitor) allocate (ibitor(5,nbitor)) c c store the list of atoms involved in each bitorsion c nbitor = 0 do i = 1, nangle ib = iang(1,i) ic = iang(2,i) id = iang(3,i) do j = 1, n12(ib) ia = i12(j,ib) if (ia.ne.ic .and. ia.ne.id) then do k = 1, n12(id) ie = i12(k,id) if (ie.ne.ic .and. ie.ne.ib .and. ie.ne.ia) then nbitor = nbitor + 1 ibitor(1,nbitor) = ia ibitor(2,nbitor) = ib ibitor(3,nbitor) = ic ibitor(4,nbitor) = id ibitor(5,nbitor) = ie end if end do end if end do end do return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module bndpot -- bond stretch functional form details ## c ## ## c ############################################################### c c c cbnd cubic coefficient in bond stretch potential c qbnd quartic coefficient in bond stretch potential c bndunit convert bond stretch energy to kcal/mole c bndtyp type of bond stretch potential energy function c c module bndpot implicit none real*8 cbnd real*8 qbnd real*8 bndunit character*8 bndtyp save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module bndstr -- bond stretches in the current structure ## c ## ## c ################################################################## c c c nbond total number of bond stretches in the system c ibnd numbers of the atoms in each bond stretch c bk bond stretch force constants (kcal/mole/Ang**2) c bl ideal bond length values in Angstroms c c module bndstr implicit none integer nbond integer, allocatable :: ibnd(:,:) real*8, allocatable :: bk(:) real*8, allocatable :: bl(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine bonds -- locate and store covalent bonds ## c ## ## c ############################################################# c c c "bonds" finds the total number of covalent bonds and c stores the atom numbers of the atoms defining each bond c c subroutine bonds use atmlst use atoms use bndstr use couple implicit none integer i,j,k,m c c c initial count of the total number of bonds c nbond = 0 do i = 1, n do j = 1, n12(i) k = i12(j,i) if (i .lt. k) then nbond = nbond + 1 end if end do end do c c perform dynamic allocation of some global arrays c if (allocated(ibnd)) deallocate (ibnd) if (allocated(bndlist)) deallocate (bndlist) allocate (ibnd(2,nbond)) allocate (bndlist(maxval,n)) c c store the list of atoms involved in each bond c nbond = 0 do i = 1, n do j = 1, n12(i) k = i12(j,i) if (i .lt. k) then nbond = nbond + 1 ibnd(1,nbond) = i ibnd(2,nbond) = k c c store the numbers of the bonds involving each atom c bndlist(j,i) = nbond do m = 1, n12(k) if (i .eq. i12(m,k)) then bndlist(m,k) = nbond goto 10 end if end do 10 continue end if end do end do return end c c c ########################################################## c ## COPYRIGHT (C) 2023 by Rae Corrigan & Jay W. Ponder ## c ## All Rights Reserved ## c ########################################################## c c ############################################################## c ## ## c ## subroutine born -- Born radii for implicit solvation ## c ## ## c ############################################################## c c c "born" computes the Born radius of each atom for use with c the various implicit solvation models c c literature references: c c W. C. Still, A. Tempczyk, R. C. Hawley and T. Hendrickson, c "A Semianalytical Treatment of Solvation for Molecular c Mechanics and Dynamics", J. Amer. Chem. Soc., 112, 6127-6129 c (1990) ("Onion" Method; see supplimentary material) c c D. Qiu, P. S. Shenkin, F. P. Hollinger and W. C. Still, "The c GB/SA Continuum Model for Solvation. A Fast Analytical Method c for the Calculation of Approximate Radii", J. Phys. Chem. A, c 101, 3005-3014 (1997) (Analytical Still Method) c c G. D. Hawkins, C. J. Cramer and D. G. Truhlar, "Parametrized c Models of Aqueous Free Energies of Solvation Based on Pairwise c Descreening of Solute Atomic Charges from a Dielectric Medium", c J. Phys. Chem., 100, 19824-19839 (1996) (HCT Method) c c A. Onufriev, D. Bashford and D. A. Case, "Exploring Protein c Native States and Large-Scale Conformational Changes with a c Modified Generalized Born Model", PROTEINS, 55, 383-394 (2004) c (OBC Method) c c T. Grycuk, "Deficiency of the Coulomb-field Approximation c in the Generalized Born Model: An Improved Formula for Born c Radii Evaluation", J. Chem. Phys., 119, 4817-4826 (2003) c (Grycuk Method) c c M. Schaefer, C. Bartels and M. Karplus, "Solution Conformations c and Thermodynamics of Structured Peptides: Molecular Dynamics c Simulation with an Implicit Solvation Model", J. Mol. Biol., c 284, 835-848 (1998) (ACE Method) c c subroutine born use atomid use atoms use bath use chgpot use couple use inform use iounit use math use mpole use mutant use pbstuf use solpot use solute implicit none integer i,j,k integer it,kt integer ii,kk integer, allocatable :: skip(:) real*8 area,rold,t real*8 shell,fraction real*8 inner,outer,tinit real*8 ratio,total real*8 xi,yi,zi,ri real*8 rk,sk,sk2 real*8 lik,lik2 real*8 uik,uik2 real*8 tsum,tchain real*8 sum,sum2,sum3 real*8 soluteint real*8 alpha,beta,gamma real*8 xr,yr,zr,rvdw real*8 r,r2,r3,r4 real*8 gpi,pip5,p5inv real*8 theta,term,ccf real*8 l2,l4,lr,l4r real*8 u2,u4,ur,u4r real*8 expterm,rmu real*8 b0,gself,pi43 real*8 bornmax real*8 pair,pbtotal real*8 probe,areatotal real*8 mixsn,neckval real*8, allocatable :: roff(:) real*8, allocatable :: weight(:) real*8, allocatable :: garea(:) real*8, allocatable :: pos(:,:) real*8, allocatable :: pbpole(:,:) real*8, allocatable :: pbself(:) real*8, allocatable :: pbpair(:) logical done c c c perform dynamic allocation of some local arrays c if (borntyp .eq. 'STILL') allocate (skip(n)) allocate (roff(n)) allocate (weight(n)) allocate (garea(n)) if (borntyp .eq. 'PERFECT') then allocate (pos(3,n)) allocate (pbpole(13,n)) allocate (pbself(n)) allocate (pbpair(n)) end if c c perform dynamic allocation of some global arrays c if (borntyp .eq. 'PERFECT') then if (.not. allocated(apbe)) allocate (apbe(n)) if (.not. allocated(pbep)) allocate (pbep(3,n)) if (.not. allocated(pbfp)) allocate (pbfp(3,n)) if (.not. allocated(pbtp)) allocate (pbtp(3,n)) end if c c set offset modified radii and OBC chain rule factor c do i = 1, n roff(i) = rsolv(i) - doffset drobc(i) = 1.0d0 end do c c get the Born radii via the numerical "Onion" method c if (borntyp .eq. 'ONION') then tinit = 0.1d0 ratio = 1.5d0 do i = 1, n t = tinit rold = roff(i) total = 0.0d0 done = .false. do while (.not. done) roff(i) = roff(i) + 0.5d0*t call surfatom (i,area,roff) fraction = area / (4.0d0*pi*roff(i)**2) if (fraction .lt. 0.99d0) then inner = roff(i) - 0.5d0*t outer = inner + t shell = 1.0d0/inner - 1.0d0/outer total = total + fraction*shell roff(i) = roff(i) + 0.5d0*t t = ratio * t else inner = roff(i) - 0.5d0*t total = total + 1.0d0/inner done = .true. end if end do rborn(i) = 1.0d0 / total roff(i) = rold end do c c get the Born radii via "Onion" method and Grycuk integral c else if (borntyp .eq. 'GONION') then tinit = 0.1d0 ratio = 1.5d0 probe = onipr do i = 1, n weight(i) = 1.0d0 end do do i = 1, n t = tinit rold = roff(i) total = 0.0d0 done = .false. do while (.not. done) roff(i) = roff(i) + 0.5d0*t call surface (roff,weight,probe,areatotal,garea) fraction = garea(i) / (4.0d0*pi*(roff(i)+probe)**2) if (fraction .lt. 0.99d0) then inner = roff(i) - 0.5d0*t outer = inner + t shell = 1.0d0/(inner**3) - 1.0d0/(outer**3) shell = shell/3.0d0 total = total + fraction*shell roff(i) = roff(i) + 0.5d0*t t = ratio * t else inner = roff(i) - 0.5d0*t total = total + 1.0d0/(3.0d0*(inner**3)) done = .true. end if end do rborn(i) = 1.0d0/((3.0d0*total)**third) roff(i) = rold end do c c get the Born radii via the analytical Still method; c note this code only loops over the variable parts c else if (borntyp .eq. 'STILL') then do i = 1, n skip(i) = 0 end do p5inv = 1.0d0 / p5 pip5 = pi * p5 do i = 1, n xi = x(i) yi = y(i) zi = z(i) gpi = gpol(i) skip(i) = i do j = 1, n12(i) skip(i12(j,i)) = i end do do j = 1, n13(i) skip(i13(j,i)) = i end do do k = 1, n if (skip(k) .ne. i) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi r2 = xr**2 + yr**2 + zr**2 r4 = r2 * r2 rvdw = rsolv(i) + rsolv(k) ratio = r2 / (rvdw*rvdw) if (ratio .gt. p5inv) then ccf = 1.0d0 else theta = ratio * pip5 term = 0.5d0 * (1.0d0-cos(theta)) ccf = term * term end if gpi = gpi + p4*ccf*vsolv(k)/r4 end if end do rborn(i) = -0.5d0 * electric / gpi end do c c get the Born radii via the Hawkins-Cramer-Truhlar method c else if (borntyp .eq. 'HCT') then do i = 1, n xi = x(i) yi = y(i) zi = z(i) ri = roff(i) sum = 1.0d0 / ri do k = 1, n if (i .ne. k) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi r2 = xr**2 + yr**2 + zr**2 r = sqrt(r2) rk = roff(k) sk = rk * shct(k) if (ri .lt. r+sk) then sk2 = sk * sk lik = 1.0d0 / max(ri,abs(r-sk)) uik = 1.0d0 / (r+sk) lik2 = lik * lik uik2 = uik * uik term = lik - uik + 0.25d0*r*(uik2-lik2) & + (0.5d0/r)*log(uik/lik) & + (0.25d0*sk2/r)*(lik2-uik2) if (ri .lt. sk-r) then term = term + 2.0d0*(1.0d0/ri-lik) end if sum = sum - 0.5d0*term end if end if end do rborn(i) = 1.0d0 / sum end do c c get the Born radii via the Onufriev-Bashford-Case method c else if (borntyp .eq. 'OBC') then do i = 1, n xi = x(i) yi = y(i) zi = z(i) ri = roff(i) sum = 0.0d0 do k = 1, n if (i .ne. k) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi r2 = xr**2 + yr**2 + zr**2 r = sqrt(r2) rk = roff(k) sk = rk * shct(k) if (ri .lt. r+sk) then sk2 = sk * sk lik = 1.0d0 / max(ri,abs(r-sk)) uik = 1.0d0 / (r+sk) lik2 = lik * lik uik2 = uik * uik term = lik - uik + 0.25d0*r*(uik2-lik2) & + (0.5d0/r)*log(uik/lik) & + (0.25d0*sk2/r)*(lik2-uik2) if (ri .lt. sk-r) then term = term + 2.0d0*(1.0d0/ri-lik) end if sum = sum + 0.5d0*term end if end if end do alpha = aobc(i) beta = bobc(i) gamma = gobc(i) sum = ri * sum sum2 = sum * sum sum3 = sum * sum2 tsum = tanh(alpha*sum - beta*sum2 + gamma*sum3) rborn(i) = 1.0d0/ri - tsum/rsolv(i) rborn(i) = 1.0d0 / rborn(i) tchain = ri * (alpha-2.0d0*beta*sum+3.0d0*gamma*sum2) drobc(i) = (1.0d0-tsum*tsum) * tchain / rsolv(i) end do c c get the Born radii via Grycuk modified HCT method c else if (borntyp .eq. 'GRYCUK') then pi43 = 4.0d0 * third * pi do i = 1, n rborn(i) = 0.0d0 ri = rsolv(i) if (ri .gt. 0.0d0) then xi = x(i) yi = y(i) zi = z(i) sum = pi43 / ri**3 soluteint = 0.0d0 ri = max(rsolv(i),rdescr(i)) + descoff do k = 1, n rk = rdescr(k) mixsn = 0.5d0 * (sneck(i)+sneck(k)) if (mut(k)) mixsn = mixsn * elambda if (i.ne.k .and. rk.gt.0.0d0) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi r2 = xr**2 + yr**2 + zr**2 r = sqrt(r2) sk = rk * shct(k) if (sk .gt. 0.0d0) then if (ri .lt. r+sk) then sk2 = sk * sk if (ri+r .lt. sk) then lik = ri uik = sk - r soluteint = soluteint + pi43*(1.0d0/uik**3 & -1.0d0/lik**3) end if uik = r + sk if (ri+r .lt. sk) then lik = sk - r else if (r .lt. ri+sk) then lik = ri else lik = r - sk end if l2 = lik * lik l4 = l2 * l2 lr = lik * r l4r = l4 * r u2 = uik * uik u4 = u2 * u2 ur = uik * r u4r = u4 * r term = (3.0d0*(r2-sk2)+6.0d0*u2-8.0d0*ur)/u4r & - (3.0d0*(r2-sk2)+6.0d0*l2 & -8.0d0*lr)/l4r soluteint = soluteint - pi*term/12.0d0 end if if (useneck) then call neck (r,ri,rk,mixsn,neckval) soluteint = soluteint - neckval end if end if end if end do if (usetanh) then bornint(i) = soluteint call tanhrsc (soluteint,rsolv(i)) end if sum = sum + soluteint rborn(i) = (sum/pi43)**third if (rborn(i) .le. 0.0d0) rborn(i) = 0.0001d0 rborn(i) = 1.0d0 / rborn(i) end if end do c c get the Born radii via analytical continuum electrostatics c else if (borntyp .eq. 'ACE') then b0 = 0.0d0 do i = 1, n b0 = b0 + vsolv(i) end do b0 = (0.75d0*b0/pi)**third do i = 1, n xi = x(i) yi = y(i) zi = z(i) ri = rsolv(i) it = class(i) gself = 1.0d0/ri + 2.0d0*wace(it,it) do k = 1, n if (k .ne. i) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi kt = class(k) r2 = xr**2 + yr**2 + zr**2 r3 = r2 * sqrt(r2) r4 = r2 * r2 expterm = wace(it,kt) * exp(-r2/s2ace(it,kt)) rmu = r4 + uace(it,kt)**4 term = (vsolv(k)/(8.0d0*pi)) * (r3/rmu)**4 gself = gself - 2.0d0*(expterm+term) end if end do if (gself .ge. 0.5d0/b0) then rborn(i) = 1.0d0 / gself else rborn(i) = 2.0d0 * b0 * (1.0d0+b0*gself) end if end do c c get the "perfect" Born radii via Poisson-Boltzmann c else if (borntyp .eq. 'PERFECT') then do i = 1, n pos(1,i) = x(i) pos(2,i) = y(i) pos(3,i) = z(i) do j = 1, 13 pbpole(j,i) = 0.0d0 end do end do term = -0.5d0 * electric * (1.0d0-1.0d0/sdie) c c find the perfect radii and optional self-energies c if (debug) then call chkpole call rotpole ('MPOLE') write (iout,10) 10 format (/,' Perfect Self Energy Values :',/) end if do ii = 1, npole i = ipole(ii) pbpole(1,i) = 1.0d0 call apbsempole (n,pos,rsolv,pbpole,pbe, & apbe,pbep,pbfp,pbtp) pbpole(1,i) = 0.0d0 rborn(i) = term / pbe if (debug) then pbpole(1,i) = rpole(1,i) do j = 2, 4 pbpole(j,i) = rpole(j,i) end do do j = 5, 13 pbpole(j,i) = 3.0d0 * rpole(j,i) end do call apbsempole (n,pos,rsolv,pbpole,pbe, & apbe,pbep,pbfp,pbtp) do j = 1, 13 pbpole(j,i) = 0.0d0 end do pbself(i) = pbe pbtotal = pbtotal + pbe write (iout,20) i,pbe 20 format (i8,5x,f12.4) end if end do c c find the perfect permanent pair energy values c if (debug) then write (iout,30) 30 format (/,' Perfect Pair Energy Values :',/) do ii = 1, npole i = ipole(ii) pbpole(1,i) = rpole(1,i) do j = 2, 4 pbpole(j,i) = rpole(j,i) end do do j = 5, 13 pbpole(j,i) = 3.0d0 * rpole(j,i) end do do kk = ii+1, npole k = ipole(kk) pbpole(1,k) = rpole(1,k) do j = 2, 4 pbpole(j,k) = rpole(j,k) end do do j = 5, 13 pbpole(j,k) = 3.0d0 * rpole(j,k) end do call apbsempole (n,pos,rsolv,pbpole,pbe, & apbe,pbep,pbfp,pbtp) pair = pbe - pbself(i) - pbself(k) write (iout,40) i,k,pair 40 format (5x,2i8,f12.4) pbtotal = pbtotal + pair pbpair(i) = pbpair(i) + 0.5d0 * pair pbpair(k) = pbpair(k) + 0.5d0 * pair do j = 1, 13 pbpole(j,k) = 0.0d0 end do end do do j = 1, 13 pbpole(j,i) = 0.0d0 end do end do do ii = 1, npole i = ipole(ii) pbpole(1,i) = rpole(1,i) do j = 2, 4 pbpole(j,i) = rpole(j,i) end do do j = 5, 13 pbpole(j,i) = 3.0d0 * rpole(j,i) end do end do call apbsempole (n,pos,rsolv,pbpole,pbe, & apbe,pbep,pbfp,pbtp) write(iout,50) pbe 50 format (/,' Single PB Calculation : ',f12.4) write(iout,60) pbtotal 60 format (' Sum of Self and Pairs : ',f12.4) end if c c print the perfect self-energies and cross-energies c write (iout,70) 70 format (/,' Perfect Self-Energies and Cross-Energies :', & //,' Type',12x,'Atom Name',24x,'Self',7x,'Cross',/) do ii = 1, npole i = ipole(ii) write (iout,80) i,name(i),pbself(i),pbpair(i) 80 format (' PB-Perfect',2x,i8,'-',a3,17x,2f12.4) end do end if c c perform deallocation of some local arrays c if (borntyp .eq. 'STILL') deallocate (skip) deallocate (roff) deallocate (weight) deallocate (garea) if (borntyp .eq. 'PERFECT') then deallocate (pos) deallocate (pbpole) deallocate (pbself) deallocate (pbpair) end if c c make sure the final values are in a reasonable range c bornmax = 500.0d0 do i = 1, n if (rborn(i).lt.0.0d0 .or. rborn(i).gt.bornmax) & rborn(i) = bornmax end do c c write out the final Born radius value for each atom c if (debug) then write (iout,90) 90 format (/,' Born Radii for Individual Atoms :',/) k = 1 do while (k .le. n) write (iout,100) (i,rborn(i),i=k,min(k+4,n)) 100 format (1x,5(i7,f8.3)) k = k + 5 end do end if return end c c c ############################################################### c ## ## c ## subroutine born1 -- Born radii chain rule derivatives ## c ## ## c ############################################################### c c c "born1" computes derivatives of the Born radii with respect c to atomic coordinates and increments total energy derivatives c and virial components for potentials involving Born radii c c subroutine born1 use atomid use atoms use chgpot use couple use deriv use math use mutant use solpot use solute use virial implicit none integer i,j,k integer it,kt integer, allocatable :: skip(:) real*8 xi,yi,zi real*8 xr,yr,zr real*8 de,de1,de2 real*8 r,r2,r3,r4,r6 real*8 p5inv,pip5 real*8 gpi,vk,ratio real*8 ccf,cosq,dccf real*8 sinq,theta real*8 factor,term real*8 rb2,ri,rk real*8 sk,sk2 real*8 lik,lik2,lik3 real*8 uik,uik2,uik3 real*8 dlik,duik real*8 t1,t2,t3 real*8 rbi,rbi2,vi real*8 ws2,s2ik,uik4 real*8 mixsn,neckderi,tcr real*8 dbr,dborn,pi43 real*8 expterm,rusum real*8 dedx,dedy,dedz real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: roff(:) logical use_gk c c c perform dynamic allocation of some local arrays c if (borntyp .eq. 'STILL') allocate (skip(n)) allocate (roff(n)) c c compute atomic radii modified by the dielectric offset c do i = 1, n roff(i) = rsolv(i) - doffset end do c c set flag for use of generalized Kirkwood solvation model c use_gk = .false. if (solvtyp(1:2) .eq. 'GK') use_gk = .true. c c get Born radius chain rule components for the Still method c if (borntyp .eq. 'STILL') then p5inv = 1.0d0 / p5 pip5 = pi * p5 do i = 1, n skip(i) = 0 end do do i = 1, n xi = x(i) yi = y(i) zi = z(i) skip(i) = i do j = 1, n12(i) skip(i12(j,i)) = i end do do j = 1, n13(i) skip(i13(j,i)) = i end do gpi = 2.0d0 * rborn(i)**2 / electric do k = 1, n if (skip(k) .ne. i) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi vk = vsolv(k) r2 = xr**2 + yr**2 + zr**2 r = sqrt(r2) r6 = r2 * r2 * r2 ratio = r2 / (rsolv(i)+rsolv(k))**2 if (ratio .gt. p5inv) then ccf = 1.0d0 dccf = 0.0d0 else theta = ratio * pip5 cosq = cos(theta) term = 0.5d0 * (1.0d0-cosq) ccf = term * term sinq = sin(theta) dccf = 2.0d0 * term * sinq * pip5 * ratio end if dborn = drb(i) if (use_gk) dborn = dborn + drbp(i) de = dborn * p4 * gpi * vk * (4.0d0*ccf-dccf)/r6 c c increment the overall implicit solvation derivatives c dedx = de * xr dedy = de * yr dedz = de * zr des(1,i) = des(1,i) + dedx des(2,i) = des(2,i) + dedy des(3,i) = des(3,i) + dedz des(1,k) = des(1,k) - dedx des(2,k) = des(2,k) - dedy des(3,k) = des(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 get Born radius chain rule components for the HCT method c else if (borntyp .eq. 'HCT') then do i = 1, n xi = x(i) yi = y(i) zi = z(i) ri = roff(i) rb2 = rborn(i) * rborn(i) do k = 1, n if (k .ne. i) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi r2 = xr**2 + yr**2 + zr**2 r = sqrt(r2) rk = roff(k) sk = rk * shct(k) if (ri .lt. r+sk) then sk2 = sk * sk lik = 1.0d0 / max(ri,abs(r-sk)) uik = 1.0d0 / (r+sk) lik2 = lik * lik uik2 = uik * uik lik3 = lik * lik2 uik3 = uik * uik2 dlik = 1.0d0 if (ri .ge. r-sk) dlik = 0.0d0 duik = 1.0d0 t1 = 0.5d0*lik2 + 0.25d0*sk2*lik3/r & - 0.25d0*(lik/r+lik3*r) t2 = -0.5d0*uik2 - 0.25d0*sk2*uik3/r & + 0.25d0*(uik/r+uik3*r) t3 = 0.125d0*(1.0d0+sk2/r2)*(lik2-uik2) & + 0.25d0*log(uik/lik)/r2 dborn = drb(i) if (use_gk) dborn = dborn + drbp(i) de = dborn * rb2 * (dlik*t1+duik*t2+t3) / r c c increment the overall implicit solvation derivatives c dedx = de * xr dedy = de * yr dedz = de * zr des(1,i) = des(1,i) + dedx des(2,i) = des(2,i) + dedy des(3,i) = des(3,i) + dedz des(1,k) = des(1,k) - dedx des(2,k) = des(2,k) - dedy des(3,k) = des(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do end do c c get Born radius chain rule components for the OBC method c else if (borntyp .eq. 'OBC') then do i = 1, n xi = x(i) yi = y(i) zi = z(i) ri = roff(i) rb2 = rborn(i) * rborn(i) * drobc(i) do k = 1, n if (k .ne. i) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi r2 = xr**2 + yr**2 + zr**2 r = sqrt(r2) rk = roff(k) sk = rk * shct(k) if (ri .lt. r+sk) then sk2 = sk * sk lik = 1.0d0 / max(ri,abs(r-sk)) uik = 1.0d0 / (r+sk) lik2 = lik * lik uik2 = uik * uik lik3 = lik * lik2 uik3 = uik * uik2 dlik = 1.0d0 if (ri .ge. r-sk) dlik = 0.0d0 duik = 1.0d0 t1 = 0.5d0*lik2 + 0.25d0*sk2*lik3/r & - 0.25d0*(lik/r+lik3*r) t2 = -0.5d0*uik2 - 0.25d0*sk2*uik3/r & + 0.25d0*(uik/r+uik3*r) t3 = 0.125d0*(1.0d0+sk2/r2)*(lik2-uik2) & + 0.25d0*log(uik/lik)/r2 dborn = drb(i) if (use_gk) dborn = dborn + drbp(i) de = dborn * rb2 * (dlik*t1+duik*t2+t3) / r c c increment the overall permanent solvation derivatives c dedx = de * xr dedy = de * yr dedz = de * zr des(1,i) = des(1,i) + dedx des(2,i) = des(2,i) + dedy des(3,i) = des(3,i) + dedz des(1,k) = des(1,k) - dedx des(2,k) = des(2,k) - dedy des(3,k) = des(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do end do c c get Born radius chain rule components for Grycuk HCT method c else if (borntyp .eq. 'GRYCUK') then pi43 = 4.0d0 * third * pi factor = -(pi**third) * 6.0d0**(2.0d0*third) / 9.0d0 do i = 1, n ri = rsolv(i) if (ri .gt. 0.0d0) then xi = x(i) yi = y(i) zi = z(i) term = pi43 / rborn(i)**3.0d0 term = factor / term**(4.0d0*third) ri = max(rsolv(i),rdescr(i)) + descoff if (usetanh) then call tanhrscchr (bornint(i),rsolv(i),tcr) term = term * tcr end if do k = 1, n rk = rdescr(k) mixsn = 0.5d0 * (sneck(i)+sneck(k)) if (mut(k)) mixsn = mixsn * elambda if (k.ne.i .and. rk.gt.0.0d0) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi r2 = xr**2 + yr**2 + zr**2 r = sqrt(r2) sk = rk * shct(k) if (sk .gt. 0.0d0) then if (ri .lt. r+sk) then sk2 = sk * sk de = 0.0d0 if (ri+r .lt. sk) then uik = sk - r de = -4.0d0 * pi / uik**4 end if if (ri+r .lt. sk) then lik = sk - r de = de + 0.25d0*pi*(sk2-4.0d0*sk*r & +17.0d0*r2) / (r2*lik**4) else if (r .lt. ri+sk) then lik = ri de = de + 0.25d0*pi*(2.0d0*ri*ri-sk2-r2) & / (r2*lik**4) else lik = r - sk de = de + 0.25d0*pi*(sk2-4.0d0*sk*r+r2) & / (r2*lik**4) end if uik = r + sk de = de - 0.25d0*pi*(sk2+4.0d0*sk*r+r2) & / (r2*uik**4) if (useneck) then call neckder (r,ri,rk,mixsn,neckderi) de = de + neckderi end if dbr = term * de/r dborn = drb(i) if (use_gk) dborn = dborn + drbp(i) de = dbr * dborn dedx = de * xr dedy = de * yr dedz = de * zr des(1,i) = des(1,i) + dedx des(2,i) = des(2,i) + dedy des(3,i) = des(3,i) + dedz des(1,k) = des(1,k) - dedx des(2,k) = des(2,k) - dedy des(3,k) = des(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end if end do end if end do c c get Born radius chain rule components for the ACE method c else if (borntyp .eq. 'ACE') then do i = 1, n xi = x(i) yi = y(i) zi = z(i) it = class(i) vi = vsolv(i) rbi = rborn(i) rbi2 = rbi * rbi do k = 1, n if (k .ne. i) then xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) kt = class(k) vk = vsolv(k) s2ik = 1.0d0 / s2ace(it,kt) ws2 = wace(it,kt) * s2ik uik4 = uace(it,kt)**4 r2 = xr**2 + yr**2 + zr**2 r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r6 = r2 * r4 rusum = r4 + uik4 ratio = r3 / rusum expterm = exp(-r2*s2ik) de1 = -4.0d0 * r * ws2 * expterm de2 = 3.0d0*r2/rusum - 4.0d0*r6/rusum**2 dborn = drb(i) if (use_gk) dborn = dborn + drbp(i) de = dborn * rbi2 * (de1+vk*ratio**3*de2/pi) / r c c increment the overall implicit solvation derivatives c dedx = de * xr dedy = de * yr dedz = de * zr des(1,i) = des(1,i) + dedx des(2,i) = des(2,i) + dedy des(3,i) = des(3,i) + dedz des(1,k) = des(1,k) - dedx des(2,k) = des(2,k) - dedy des(3,k) = des(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 end if c c perform deallocation of some local arrays c if (borntyp .eq. 'STILL') deallocate (skip) deallocate (roff) return end c c c ################################################################# c ## ## c ## subroutine tanhrsc -- tanh rescaling of effective radii ## c ## ## c ################################################################# c c c "tanhrsc" calculates the rescaled descreening correction for c effective Born radius calculations c c literature references: c c A. Onufriev, D. Bashford, and D. Case, "Exploring Protein Native c States and Large-Scale Conformational Changes with a Modified c Generalized Born Model", Proteins 55, 383-394 (2004) c c B. Aguilar, R. Shadrach, and A. V. Onufriev, "Reducing the c Secondary Structure Bias in the Generalized Born Model via c R6 Effective Radii", Journal of Chemical Theory and Computation, c 6, 3613-3630, (2010) c c variables and parameters: c c ii total integral of 1/r^6 over atoms and pairwise necks c rhoi base radius for the atom being descreened c c subroutine tanhrsc (ii,rhoi) use math use solute implicit none real*8 ii,rhoi real*8 maxborn real*8 recipmaxborn3 real*8 b0,b1,b2,pi43 real*8 rho3,rho3psi,rho6psi2 real*8 rho9psi3,tanhconst c c c assign constants c pi43 = 4.0d0 * third * pi maxborn = 30.0d0 recipmaxborn3 = maxborn**(-3.0d0) b0 = 0.9563d0 b1 = 0.2578d0 b2 = 0.0810d0 c c calculate tanh components c rho3 = rhoi * rhoi * rhoi rho3psi = rho3 * (-1.0d0*ii) rho6psi2 = rho3psi * rho3psi rho9psi3 = rho6psi2 * rho3psi c c if tanh function is 1, then effective radius is max radius c tanhconst = pi43 * ((1.0d0/rho3)-recipmaxborn3) ii = -tanhconst * tanh(b0*rho3psi-b1*rho6psi2+b2*rho9psi3) return end c c c ################################################################# c ## ## c ## subroutine tanhrscchr -- get tanh rescaling derivatives ## c ## ## c ################################################################# c c c "tanhrscchr" returns the derivative of the tanh rescaling c for the Born radius chain rule term c c variables and parameters: c c ii total integral of 1/r^6 over atoms and pairwise necks c rhoi base radius for the atom being descreened c derival tanh chain rule derivative term c c subroutine tanhrscchr (ii,rhoi,derival) use math use solute implicit none real*8 ii,rhoi real*8 maxborn real*8 recipmaxborn3 real*8 b0,b1,b2,pi43 real*8 rho3,rho3psi,rho6psi2 real*8 rho9psi3,rho6psi,rho9psi2 real*8 tanhconst,tanhterm,tanh2 real*8 chainrule,derival c c c assign the constant values c pi43 = 4.0d0 * third * pi maxborn = 30.0d0 recipmaxborn3 = maxborn**(-3.0d0) b0 = 0.9563d0 b1 = 0.2578d0 b2 = 0.0810d0 c c calculate tanh chain rule components c rho3 = rhoi * rhoi * rhoi rho3psi = rho3 * (-1.0d0*ii) rho6psi2 = rho3psi * rho3psi rho9psi3 = rho6psi2 * rho3psi rho6psi = rho3 * rho3 * (-1.0d0*ii) rho9psi2 = rho6psi2 * rho3 tanhterm = tanh(b0*rho3psi-b1*rho6psi2+b2*rho9psi3) tanh2 = tanhterm * tanhterm chainrule = b0*rho3 - 2.0d0*b1*rho6psi + 3.0d0*b2*rho9psi2 tanhconst = pi43 * ((1.0d0/rho3)-recipmaxborn3) derival = tanhconst * chainrule * (1.0d0-tanh2) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module bound -- periodic boundary condition controls ## c ## ## c ############################################################## c c c polycut cutoff distance for infinite polymer nonbonds c polycut2 square of infinite polymer nonbond cutoff c use_bounds flag to use periodic boundary conditions c use_replica flag to use replicates for periodic system c use_polymer flag to mark presence of infinite polymer c use_wrap flag to wrap coordinates in output files c c module bound implicit none real*8 polycut real*8 polycut2 logical use_bounds logical use_replica logical use_polymer logical use_wrap save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine bounds -- check periodic boundary conditions ## c ## ## c ################################################################# c c c "bounds" finds the center of mass of each molecule and c translates any stray molecules back into the periodic box c c subroutine bounds use atomid use atoms use boxes use math use molcul implicit none integer i,j,k integer init,stop real*8 weigh,corr real*8 xmid,ymid,zmid real*8 xfrac,yfrac,zfrac real*8 xcom,ycom,zcom c c c locate the center of mass of each molecule c do i = 1, nmol init = imol(1,i) stop = imol(2,i) xmid = 0.0d0 ymid = 0.0d0 zmid = 0.0d0 do j = init, stop k = kmol(j) weigh = mass(k) xmid = xmid + x(k)*weigh ymid = ymid + y(k)*weigh zmid = zmid + z(k)*weigh end do weigh = molmass(i) xmid = xmid / weigh ymid = ymid / weigh zmid = zmid / weigh c c get fractional coordinates of center of mass c if (triclinic) then zfrac = zmid / gamma_term yfrac = (ymid - zfrac*beta_term) / gamma_sin xfrac = xmid - yfrac*gamma_cos - zfrac*beta_cos else if (monoclinic) then zfrac = zmid / beta_sin yfrac = ymid xfrac = xmid - zfrac*beta_cos else zfrac = zmid yfrac = ymid xfrac = xmid end if c c translate center of mass into the periodic box c if (dodecadron) then xfrac = xfrac - xbox*nint(xfrac/xbox) yfrac = yfrac - ybox*nint(yfrac/ybox) zfrac = zfrac - root2*zbox*nint(zfrac/(zbox*root2)) corr = xbox2 * int(abs(xfrac/xbox)+abs(yfrac/ybox) & +abs(root2*zfrac/zbox)) xfrac = xfrac - sign(corr,xfrac) yfrac = yfrac - sign(corr,yfrac) zfrac = zfrac - sign(corr,zfrac)*root2 else if (octahedron) then xfrac = xfrac - xbox*nint(xfrac/xbox) yfrac = yfrac - ybox*nint(yfrac/ybox) zfrac = zfrac - zbox*nint(zfrac/zbox) if (abs(xfrac)+abs(yfrac)+abs(zfrac) .gt. box34) then xfrac = xfrac - sign(xbox2,xfrac) yfrac = yfrac - sign(ybox2,yfrac) zfrac = zfrac - sign(zbox2,zfrac) end if else xfrac = xfrac - xbox*nint(xfrac/xbox) yfrac = yfrac - ybox*nint(yfrac/ybox) zfrac = zfrac - zbox*nint(zfrac/zbox) end if c c convert translated fractional center of mass to Cartesian c if (triclinic) then xcom = xfrac + yfrac*gamma_cos + zfrac*beta_cos ycom = yfrac*gamma_sin + zfrac*beta_term zcom = zfrac * gamma_term else if (monoclinic) then xcom = xfrac + zfrac*beta_cos ycom = yfrac zcom = zfrac * beta_sin else xcom = xfrac ycom = yfrac zcom = zfrac end if c c translate coordinates via offset from center of mass c do j = init, stop k = kmol(j) x(k) = x(k) - xmid + xcom y(k) = y(k) - ymid + ycom z(k) = z(k) - zmid + zcom end do end do return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module boxes -- periodic boundary condition parameters ## c ## ## c ################################################################ c c c xbox length of a-axis of periodic box in Angstroms c ybox length of b-axis of periodic box in Angstroms c zbox length of c-axis of periodic box in Angstroms c alpha angle between b- and c-axes of box in degrees c beta angle between a- and c-axes of box in degrees c gamma angle between a- and b-axes of box in degrees c xbox2 half of the a-axis length of periodic box c ybox2 half of the b-axis length of periodic box c zbox2 half of the c-axis length of periodic box c box34 three-fourths axis length of truncated octahedron c volbox volume in Ang**3 of the periodic box c alpha_sin sine of the alpha periodic box angle c alpha_cos cosine of the alpha periodic box angle c beta_sin sine of the beta periodic box angle c beta_cos cosine of the beta periodic box angle c gamma_sin sine of the gamma periodic box angle c gamma_cos cosine of the gamma periodic box angle c beta_term term used in generating triclinic box c gamma_term term used in generating triclinic box c lvec real space lattice vectors as matrix rows c recip reciprocal lattice vectors as matrix columns c orthogonal flag to mark periodic box as orthogonal c monoclinic flag to mark periodic box as monoclinic c triclinic flag to mark periodic box as triclinic c octahedron flag to mark box as truncated octahedron c dodecadron flag to mark box as rhombic dodecahedron c nonprism flag to mark octahedron or dodecahedron c nosymm flag to mark use or lack of lattice symmetry c spacegrp space group symbol for the unit cell type c c module boxes implicit none real*8 xbox,ybox,zbox real*8 alpha,beta,gamma real*8 xbox2,ybox2,zbox2 real*8 box34,volbox real*8 alpha_sin real*8 alpha_cos real*8 beta_sin real*8 beta_cos real*8 gamma_sin real*8 gamma_cos real*8 beta_term real*8 gamma_term real*8 lvec(3,3) real*8 recip(3,3) logical orthogonal logical monoclinic logical triclinic logical octahedron logical dodecadron logical nonprism logical nosymm character*10 spacegrp save end c c c ################################################################ c ## COPYRIGHT (C) 2010 by Teresa Head-Gordon & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ############################################################### c ## ## c ## subroutine bussi -- Bussi NPT molecular dynamics step ## c ## ## c ############################################################### c c c "bussi" performs a single molecular dynamics time step via c the Bussi-Parrinello isothermal-isobaric algorithm c c literature reference: c c G. Bussi, T. Zykova-Timan and M. Parrinello, "Isothermal-Isobaric c Molecular Dynamics using Stochastic Velocity Rescaling", Journal c of Chemical Physics, 130, 074101 (2009) c c original version written by Teresa Head-Gordon, October 2010 c c subroutine bussi (istep,dt) use atomid use atoms use bath use boxes use freeze use ielscf use mdstuf use moldyn use polar use units use usage implicit none integer i,j,k integer istep real*8 dt,dt_2,dt_x real*8 dt2_2,dt3_2 real*8 epot,etot,eksum real*8 expterm,sinhterm real*8 kt,w,temp,pres real*8 part1,part2 real*8 factor,term real*8 ekin(3,3) real*8 stress(3,3) real*8, allocatable :: xold(:) real*8, allocatable :: yold(:) real*8, allocatable :: zold(:) real*8, allocatable :: derivs(:,:) c c c set some time values, constants and barostat mass c dt_2 = 0.5d0 * dt dt2_2 = dt_2 * dt_2 dt3_2 = dt2_2 * dt_2 kt = boltzmann * kelvin w = dble(nfree) * kt * taupres * taupres c c get Beeman integration coefficients for velocity updates c factor = dble(bmnmix) dt_x = dt / factor part1 = 0.5d0*factor + 1.0d0 part2 = part1 - 2.0d0 c c make half-step temperature correction and get pressure c call temper (dt_2,eksum,ekin,temp) call pressure (dt,epot,ekin,temp,pres,stress) c c get half-step Beeman velocities and update barostat velocity c eta = eta + 3.0d0*(volbox*(pres-atmsph)*ekcal/prescon & + 2.0*kt)*dt_2/w do i = 1, nuse k = iuse(i) do j = 1, 3 eta = eta + mass(k)*a(j,k)*v(j,k)*dt2_2/w & + mass(k)*a(j,k)*a(j,k)*dt3_2/(3.0d0*w) v(j,k) = v(j,k) + (part1*a(j,k)-aalt(j,k))*dt_x end do end do c c perform dynamic allocation of some local arrays c allocate (xold(n)) allocate (yold(n)) allocate (zold(n)) allocate (derivs(3,n)) c c store the current atom positions, then alter positions c and velocities via coupling to the barostat c term = eta * dt expterm = exp(term) sinhterm = sinh(term) do i = 1, nuse k = iuse(i) xold(k) = x(k) yold(k) = y(k) zold(k) = z(k) x(k) = x(k)*expterm + v(1,k)*sinhterm/eta y(k) = y(k)*expterm + v(2,k)*sinhterm/eta z(k) = z(k)*expterm + v(3,k)*sinhterm/eta do j = 1, 3 v(j,k) = v(j,k) / expterm end do end do c c set the new box dimensions and other lattice values; c current version assumes isotropic pressure c xbox = xbox * expterm ybox = ybox * expterm zbox = zbox * expterm call lattice c c apply Verlet half-step updates for any auxiliary dipoles c if (use_ielscf) then do i = 1, nuse k = iuse(i) do j = 1, 3 vaux(j,k) = vaux(j,k) + aaux(j,k)*dt_2 vpaux(j,k) = vpaux(j,k) + apaux(j,k)*dt_2 uaux(j,k) = uaux(j,k) + vaux(j,k)*dt upaux(j,k) = upaux(j,k) + vpaux(j,k)*dt end do end do call temper2 (dt,temp) end if c c get constraint-corrected positions and half-step velocities c if (use_rattle) call rattle (dt,xold,yold,zold) c c get the potential energy and atomic forces c call gradient (epot,derivs) c c use Newton's second law to get the next accelerations c do i = 1, nuse k = iuse(i) do j = 1, 3 aalt(j,k) = a(j,k) a(j,k) = -ekcal * derivs(j,k) / mass(k) end do end do c c perform deallocation of some local arrays c deallocate (xold) deallocate (yold) deallocate (zold) deallocate (derivs) c c get full-step Beeman velocities and update barostat velocity c eta = eta + 3.0d0*(volbox*(pres-atmsph)*ekcal/prescon & + 2.0*kt)*dt_2/w do i = 1, nuse k = iuse(i) do j = 1, 3 eta = eta + mass(k)*a(j,k)*v(j,k)*dt2_2/w & + mass(k)*a(j,k)*a(j,k)*dt3_2/(3.0d0*w) v(j,k) = v(j,k) + (part2*a(j,k)+aalt(j,k))*dt_x end do end do c c apply Verlet full-step updates for any auxiliary dipoles c if (use_ielscf) then term = 2.0d0 / (dt*dt) do i = 1, nuse k = iuse(i) do j = 1, 3 aaux(j,k) = term * (uind(j,k)-uaux(j,k)) apaux(j,k) = term * (uinp(j,k)-upaux(j,k)) vaux(j,k) = vaux(j,k) + aaux(j,k)*dt_2 vpaux(j,k) = vpaux(j,k) + apaux(j,k)*dt_2 end do end do end if c c find the constraint-corrected full-step velocities c if (use_rattle) call rattle2 (dt) c c make full-step temperature correction and get pressure c call temper (dt_2,eksum,ekin,temp) call pressure (dt,epot,ekin,temp,pres,stress) c c total energy is sum of kinetic and potential energies c etot = eksum + epot c c compute statistics and save trajectory for this step c call mdstat (istep,dt,etot,epot,eksum,temp,pres) call mdsave (istep,dt,epot,eksum) call mdrest (istep) return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine calendar -- find the current date and time ## c ## ## c ############################################################### c c c "calendar" returns the current time as a set of integer values c representing the year, month, day, hour, minute and second c c note only one of the various implementations below should c be activated by removing comment characters c c subroutine calendar (year,month,day,hour,minute,second) implicit none integer year,month integer day,hour integer minute,second c c c use the standard "date_and_time" intrinsic function c integer values(8) character*5 zone character*8 date character*10 time call date_and_time (date,time,zone,values) year = values(1) month = values(2) day = values(3) hour = values(5) minute = values(6) second = values(7) c c use the obsolete "itime" and "idate" intrinsic functions c c integer hms(3) c call itime (hms) c hour = hms(1) c minute = hms(2) c second = hms(3) c call idate (month,day,year) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## module cell -- replicated cell periodic boundaries ## c ## ## c ############################################################ c c c ncell total number of cell replicates for periodic boundaries c icell offset along axes for each replicate periodic cell c xcell length of the a-axis of the complete replicated cell c ycell length of the b-axis of the complete replicated cell c zcell length of the c-axis of the complete replicated cell c xcell2 half the length of the a-axis of the replicated cell c ycell2 half the length of the b-axis of the replicated cell c zcell2 half the length of the c-axis of the replicated cell c c module cell implicit none integer ncell integer, allocatable :: icell(:,:) real*8 xcell real*8 ycell real*8 zcell real*8 xcell2 real*8 ycell2 real*8 zcell2 save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine center -- superimpose structure centroids ## c ## ## c ############################################################## c c c "center" moves the weighted centroid of each coordinate c set to the origin during least squares superposition c c subroutine center (n1,x1,y1,z1,n2,x2,y2,z2,xmid,ymid,zmid) use align implicit none integer i,k,n1,n2 real*8 weigh,norm real*8 xmid,ymid,zmid real*8 x1(*),x2(*) real*8 y1(*),y2(*) real*8 z1(*),z2(*) c c c find the weighted centroid of the second c structure and translate it to the origin c xmid = 0.0d0 ymid = 0.0d0 zmid = 0.0d0 norm = 0.0d0 do i = 1, nfit k = ifit(2,i) weigh = wfit(i) xmid = xmid + x2(k)*weigh ymid = ymid + y2(k)*weigh zmid = zmid + z2(k)*weigh norm = norm + weigh end do xmid = xmid / norm ymid = ymid / norm zmid = zmid / norm do i = 1, n2 x2(i) = x2(i) - xmid y2(i) = y2(i) - ymid z2(i) = z2(i) - zmid end do c c now repeat for the first structure, note c that this centroid position gets returned c xmid = 0.0d0 ymid = 0.0d0 zmid = 0.0d0 norm = 0.0d0 do i = 1, nfit k = ifit(1,i) weigh = wfit(i) xmid = xmid + x1(k)*weigh ymid = ymid + y1(k)*weigh zmid = zmid + z1(k)*weigh norm = norm + weigh end do xmid = xmid / norm ymid = ymid / norm zmid = zmid / norm do i = 1, n1 x1(i) = x1(i) - xmid y1(i) = y1(i) - ymid z1(i) = z1(i) - zmid end do return end c c c ########################################################## c ## COPYRIGHT (C) 2020 by Chengwen Liu & Jay W. Ponder ## c ## All Rights Reserved ## c ########################################################## c c ################################################################ c ## ## c ## module cflux -- charge flux terms in current structure ## c ## ## c ################################################################ c c c nbflx total number of bond charge flux interactions c naflx total number of angle charge flux interactions c bflx bond stretching charge flux constant (electrons/Ang) c aflx angle bending charge flux constant (electrons/radian) c abflx asymmetric stretch charge flux constant (electrons/Ang) c c module cflux implicit none integer nbflx integer naflx real*8, allocatable :: bflx(:) real*8, allocatable :: aflx(:,:) real*8, allocatable :: abflx(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module charge -- partial charges in current structure ## c ## ## c ############################################################### c c c nion total number of partial charge sites in the system c iion number of the atom for each partial charge site c jion neighbor generation site to use for each atom c kion cutoff switching site to use for each atom c pchg current partial charge value for each atom (e-) c pchg0 original partial charge values for charge flux c c module charge implicit none integer nion integer, allocatable :: iion(:) integer, allocatable :: jion(:) integer, allocatable :: kion(:) real*8, allocatable :: pchg(:) real*8, allocatable :: pchg0(:) save end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################## c ## ## c ## module chgpen -- charge penetration in current structure ## c ## ## c ################################################################## c c c ncp total number of charge penetration sites in system c pcore number of core electrons assigned to each atom c pval number of valence electrons assigned to each atom c pval0 original number of valence electrons for charge flux c palpha charge penetration damping value at each atom c c module chgpen implicit none integer ncp real*8, allocatable :: pcore(:) real*8, allocatable :: pval(:) real*8, allocatable :: pval0(:) real*8, allocatable :: palpha(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module chgpot -- charge-charge functional form details ## c ## ## c ################################################################ c c c electric energy factor in kcal/mole for current force field c dielec dielectric constant for electrostatic interactions c ebuffer electrostatic buffering constant added to distance c c1scale factor by which 1-1 charge interactions are scaled c c2scale factor by which 1-2 charge interactions are scaled c c3scale factor by which 1-3 charge interactions are scaled c c4scale factor by which 1-4 charge interactions are scaled c c5scale factor by which 1-5 charge interactions are scaled c neutnbr logical flag governing use of neutral group neighbors c neutcut logical flag governing use of neutral group cutoffs c c module chgpot implicit none real*8 electric real*8 dielec,ebuffer real*8 c1scale,c2scale real*8 c3scale,c4scale real*8 c5scale logical neutnbr,neutcut save end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ############################################################### c ## ## c ## module chgtrn -- charge transfer in current structure ## c ## ## c ############################################################### c c c nct total number of dispersion sites in the system c chgct charge for charge transfer at each multipole site c dmpct charge transfer damping factor at each multipole site c c module chgtrn implicit none integer nct real*8, allocatable :: chgct(:) real*8, allocatable :: dmpct(:) save end c c c ################################################### c ## COPYRIGHT (C) 2003 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine chkpole -- check multipoles at chiral sites ## c ## ## c ################################################################ c c c "chkpole" inverts multipole moments as necessary at atoms c with chiral local reference frame definitions c c subroutine chkpole use atoms use mpole use repel implicit none integer i,k integer ia,ib,ic,id real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 c1,c2,c3,vol logical dopol,dorep logical check c c c loop over multipoles and test for chirality inversion c do i = 1, n dopol = .false. dorep = .false. if (allocated(pollist)) then if (pollist(i) .ne. 0) dopol = .true. end if if (allocated(replist)) then if (replist(i) .ne. 0) dorep = .true. end if if (dopol .or. dorep) then check = .true. if (polaxe(i) .ne. 'Z-then-X') check = .false. if (yaxis(i) .eq. 0) check = .false. if (check) then k = yaxis(i) ia = i ib = zaxis(i) ic = xaxis(i) id = abs(k) c c compute the signed parallelpiped volume at chiral site c xad = x(ia) - x(id) yad = y(ia) - y(id) zad = z(ia) - z(id) xbd = x(ib) - x(id) ybd = y(ib) - y(id) zbd = z(ib) - z(id) xcd = x(ic) - x(id) ycd = y(ic) - y(id) zcd = z(ic) - z(id) c1 = ybd*zcd - zbd*ycd c2 = ycd*zad - zcd*yad c3 = yad*zbd - zad*ybd vol = xad*c1 + xbd*c2 + xcd*c3 c c invert the multipole components involving the y-axis c if ((k.lt.0.and.vol.gt.0.0d0) .or. & (k.gt.0.and.vol.lt.0.0d0)) then yaxis(i) = -k if (dopol) then pole(3,i) = -pole(3,i) pole(6,i) = -pole(6,i) pole(8,i) = -pole(8,i) pole(10,i) = -pole(10,i) pole(12,i) = -pole(12,i) end if if (dorep) then repole(3,i) = -repole(3,i) repole(6,i) = -repole(6,i) repole(8,i) = -repole(8,i) repole(10,i) = -repole(10,i) repole(12,i) = -repole(12,i) end if end if end if end if end do return end c c c ################################################### c ## COPYRIGHT (C) 2004 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine chkring -- check atom set for small rings ## c ## ## c ############################################################## c c c "chkring" tests an atom or a set of connected atoms for c their presence within a single 3- to 6-membered ring c c subroutine chkring (iring,ia,ib,ic,id) use couple implicit none integer i,j,k,m,p,q,r integer ia,ib,ic,id integer iring,nset c c c initialize the ring size and number of atoms to test c iring = 0 nset = 0 if (ia .gt. 0) nset = 1 if (ib .gt. 0) nset = 2 if (ic .gt. 0) nset = 3 if (id .gt. 0) nset = 4 c c cannot be in a ring if the terminal atoms are univalent c if (nset .eq. 1) then if (n12(ia) .le. 1) nset = 0 else if (nset .eq. 2) then if (min(n12(ia),n12(ib)) .le. 1) nset = 0 else if (nset .eq. 3) then if (min(n12(ia),n12(ic)) .le. 1) nset = 0 else if (nset .eq. 4) then if (min(n12(ia),n12(id)) .le. 1) nset = 0 end if c c check the input atoms for sequential connectivity c if (nset .gt. 1) then do j = 1, n12(ia) i = i12(j,ia) if (ib .eq. i) then if (nset .eq. 2) goto 10 do k = 1, n12(ib) m = i12(k,ib) if (ic .eq. m) then if (nset .eq. 3) goto 10 do p = 1, n12(ic) q = i12(p,ic) if (id .eq. q) goto 10 end do end if end do end if end do nset = 0 10 continue end if c c check for an atom contained inside a small ring c if (nset .eq. 1) then do j = 1, n12(ia)-1 i = i12(j,ia) do k = j+1, n12(ia) m = i12(k,ia) do p = 1, n12(i) if (m .eq. i12(p,i)) then iring = 3 goto 20 end if end do end do end do do j = 1, n12(ia)-1 i = i12(j,ia) do k = j+1, n12(ia) m = i12(k,ia) do p = 1, n12(i) r = i12(p,i) if (r .ne. ia) then do q = 1, n12(m) if (r .eq. i12(q,m)) then iring = 4 goto 20 end if end do end if end do end do end do do j = 1, n13(ia)-1 i = i13(j,ia) do k = j+1, n13(ia) m = i13(k,ia) do p = 1, n12(i) if (m .eq. i12(p,i)) then iring = 5 goto 20 end if end do do p = 1, n13(i) if (m .eq. i13(p,i)) then iring = 6 goto 20 end if end do end do end do 20 continue c c check for a bond contained inside a small ring c else if (nset .eq. 2) then do j = 1, n12(ia) i = i12(j,ia) do k = 1, n12(ib) if (i .eq. i12(k,ib)) then iring = 3 goto 30 end if end do end do do j = 1, n12(ia) i = i12(j,ia) if (ib .ne. i) then do k = 1, n12(ib) m = i12(k,ib) if (ia .ne. m) then do p = 1, n12(i) if (m .eq. i12(p,i)) then iring = 4 goto 30 end if end do end if end do end if end do do j = 1, n13(ia) i = i13(j,ia) do k = 1, n13(ib) if (i .eq. i13(k,ib)) then iring = 5 goto 30 end if end do end do do j = 1, n12(ia) i = i12(j,ia) if (ib .ne. i) then do k = 1, n13(ib) m = i13(k,ib) do p = 1, n13(i) if (m .eq. i13(p,i)) then iring = 6 do q = 1, n12(ia) if (m .eq. i12(q,ia)) iring = 0 end do if (iring .eq. 6) goto 30 end if end do end do end if end do 30 continue c c check for an angle contained inside a small ring c else if (nset .eq. 3) then do j = 1, n12(ia) if (ic .eq. i12(j,ia)) then iring = 3 goto 40 end if end do do j = 1, n12(ia) i = i12(j,ia) if (ib .ne. i) then do k = 1, n12(ic) if (i .eq. i12(k,ic)) then iring = 4 goto 40 end if end do end if end do do j = 1, n12(ia) i = i12(j,ia) if (ib .ne. i) then do k = 1, n13(ic) if (i .eq. i13(k,ic)) then iring = 5 goto 40 end if end do end if end do do j = 1, n13(ia) i = i13(j,ia) if (ic .ne. i) then do k = 1, n13(ic) if (i .eq. i13(k,ic)) then iring = 6 goto 40 end if end do end if end do 40 continue c c check for a torsion contained inside a small ring c else if (nset .eq. 4) then do j = 1, n12(ia) if (id .eq. i12(j,ia)) then iring = 4 goto 50 end if end do do j = 1, n12(ia) i = i12(j,ia) if (ib .ne. i) then do k = 1, n12(id) if (i .eq. i12(k,id)) then iring = 5 goto 50 end if end do end if end do do j = 1, n12(ia) i = i12(j,ia) if (ib .ne. i) then do k = 1, n13(id) if (i .eq. i13(k,id)) then iring = 6 goto 50 end if end do end if end do 50 continue end if return end c c c ################################################### c ## COPYRIGHT (C) 2024 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine chksymm -- test for 1D, 2D & other symmetry ## c ## ## c ################################################################ c c c "chksymm" examines the current coordinates for linearity, c planarity, internal mirror planes or a center of inversion c c subroutine chksymm (symmtyp) use atoms implicit none integer i,nave real*8 eps real*8 xave,yave,zave logical xnul,ynul,znul character*6 symmtyp c c c copy current coordinates into a reference storage area c call makeref (1) c c move the atomic coordinates into the inertial frame c call inertia (2) c c test maximal coordinates for linearity and planarity c eps = 0.001d0 symmtyp = 'NONE' xnul = .true. ynul = .true. znul = .true. do i = 1, n if (abs(x(i)) .gt. eps) xnul = .false. if (abs(y(i)) .gt. eps) ynul = .false. if (abs(z(i)) .gt. eps) znul = .false. end do if (n .eq. 3) symmtyp = 'PLANAR' if (xnul) symmtyp = 'PLANAR' if (ynul) symmtyp = 'PLANAR' if (znul) symmtyp = 'PLANAR' if (n .eq. 2) symmtyp = 'LINEAR' if (xnul .and. ynul) symmtyp = 'LINEAR' if (xnul .and. znul) symmtyp = 'LINEAR' if (ynul .and. znul) symmtyp = 'LINEAR' if (n .eq. 1) symmtyp = 'SINGLE' c c test mean coords for mirror plane and inversion center c if (symmtyp .eq. 'NONE') then xave = 0.0d0 yave = 0.0d0 zave = 0.0d0 do i = 1, n xave = xave + x(i) yave = yave + y(i) zave = zave + z(i) end do xave = abs(xave) / dble(n) yave = abs(yave) / dble(n) zave = abs(zave) / dble(n) nave = 0 if (xave .lt. eps) nave = nave + 1 if (yave .lt. eps) nave = nave + 1 if (zave .lt. eps) nave = nave + 1 if (nave .ne. 0) symmtyp = 'MIRROR' if (nave .eq. 3) symmtyp = 'CENTER' end if c c move original coordinates back into current structure c call getref (1) return end c c c ################################################### c ## COPYRIGHT (C) 2000 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine chkxyz -- check for coincident coordinates ## c ## ## c ############################################################### c c c "chkxyz" finds any pairs of atoms with identical Cartesian c coordinates, and prints a warning message c c subroutine chkxyz (clash) use atoms use iounit implicit none integer i,j real*8 xi,yi,zi real*8 eps,r2 logical clash logical header c c c initialize distance tolerance and atom collision flag c eps = 0.000001d0 clash = .false. header = .true. c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(n,x,y,z,eps,clash,header) !$OMP DO schedule(guided) c c loop over atom pairs testing for identical coordinates c do i = 1, n-1 xi = x(i) yi = y(i) zi = z(i) do j = i+1, n r2 = (x(j)-xi)**2 + (y(j)-yi)**2 + (z(j)-zi)**2 if (r2 .lt. eps) then clash = .true. if (header) then header = .false. write (iout,10) 10 format () end if write (iout,20) i,j 20 format (' CHKXYZ -- Warning, Atoms',i6,' and',i6, & ' have Identical Coordinates') end if end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine cholesky -- modified Cholesky linear solver ## c ## ## c ################################################################ c c c "cholesky" uses a modified Cholesky method to solve the linear c system Ax = b, returning "x" in "b"; "A" must be a real symmetric c positive definite matrix with its upper triangle including the c diagonal stored by rows c c literature reference: c c R. S. Martin, G. Peters and J. H. Wilkinson, "Symmetric c Decomposition of a Positive Definite Matrix", Numerische c Mathematik, 7, 362-383 (1965) c c subroutine cholesky (nvar,a,b) implicit none integer i,j,k,nvar integer ii,ij,ik,ki,kk integer im,jk,jm real*8 r,s,t real*8 a(*) real*8 b(*) c c c Cholesky factorization to reduce "A" to (L)(D)(L transpose) c "L" has a unit diagonal; store 1.0/D on the diagonal of "A" c ii = 1 do i = 1, nvar im = i - 1 if (i .ne. 1) then ij = i do j = 1, im r = a(ij) if (j .ne. 1) then ik = i jk = j jm = j - 1 do k = 1, jm r = r - a(ik)*a(jk) ik = nvar - k + ik jk = nvar - k + jk end do end if a(ij) = r ij = nvar - j + ij end do end if r = a(ii) if (i .ne. 1) then kk = 1 ik = i do k = 1, im s = a(ik) t = s * a(kk) a(ik) = t r = r - s*t ik = nvar - k + ik kk = nvar - k + 1 + kk end do end if a(ii) = 1.0d0 / r ii = nvar - i + 1 + ii end do c c solve linear equations; first solve Ly = b for y c do i = 1, nvar if (i .ne. 1) then ik = i im = i - 1 r = b(i) do k = 1, im r = r - b(k)*a(ik) ik = nvar - k + ik end do b(i) = r end if end do c c finally, solve (D)(L transpose)(x) = y for x c ii = nvar * (nvar+1) / 2 do j = 1, nvar i = nvar + 1 - j r = b(i) * a(ii) if (j .ne. 1) then im = i + 1 ki = ii + 1 do k = im, nvar r = r - a(ki)*b(k) ki = ki + 1 end do end if b(i) = r ii = ii - j - 1 end do return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module chrono -- clock time values for current program ## c ## ## c ################################################################ c c c twall current processor wall clock time in seconds c tcpu elapsed cpu time from start of program in seconds c c module chrono implicit none real*8 twall real*8 tcpu save end c c c ################################################### c ## COPYRIGHT (C) 2010 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module chunks -- PME grid spatial decomposition values ## c ## ## c ################################################################ c c c nchunk total number of spatial regions for PME grid c nchk1 number of spatial regions along the a-axis c nchk2 number of spatial regions along the b-axis c nchk3 number of spatial regions along the c-axis c ngrd1 number of grid points per region along a-axis c ngrd2 number of grid points per region along b-axis c ngrd3 number of grid points per region along c-axis c nlpts PME grid points to the left of center point c nrpts PME grid points to the right of center point c grdoff offset for index into B-spline coefficients c pmetable PME grid spatial regions involved for each site c c module chunks implicit none integer nchunk integer nchk1,nchk2,nchk3 integer ngrd1,ngrd2,ngrd3 integer nlpts,nrpts,grdoff integer, allocatable :: pmetable(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 2010 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine settime -- initialize wall clock and CPU time ## c ## ## c ################################################################## c c c "settime" initializes the wall clock and elapsed CPU times c c subroutine settime use chrono implicit none integer count,crate,cmax real time c c c set wall clock and cpu time via Fortran intrinsic functions c call system_clock (count,crate,cmax) twall = dble(count) / dble(crate) call cpu_time (time) tcpu = dble(time) return end c c c ################################################################ c ## ## c ## subroutine gettime -- elapsed wall clock and CPU times ## c ## ## c ################################################################ c c c "gettime" finds the elapsed wall clock and CPU times in seconds c since the last call to "settime" c c subroutine gettime (wall,cpu) use chrono implicit none integer count,crate,cmax real time real*8 wall,cpu real*8 twall0,tcpu0 c c c get total wall clock time via Fortran intrinsic functions c twall0 = twall call system_clock (count,crate,cmax) twall = dble(count) / dble(crate) wall = twall - twall0 if (wall .lt. 0.0d0) wall = wall + dble(cmax)/dble(crate) c c get elapsed CPU time via Fortran intrinsic functions c tcpu0 = tcpu call cpu_time (time) tcpu = dble(time) cpu = tcpu - tcpu0 return end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine cluster -- set user-defined groups of atoms ## c ## ## c ################################################################ c c c "cluster" gets the partitioning of the system into groups c and stores a list of the group to which each atom belongs c c subroutine cluster use atomid use atoms use bound use group use inform use iounit use keys use limits use molcul implicit none integer i,j,k integer next,size integer gnum,ga,gb integer, allocatable :: list(:) real*8 wg logical header character*20 keyword character*240 record character*240 string c c c perform dynamic allocation of some global arrays c if (.not. allocated(igrp)) allocate (igrp(2,0:maxgrp)) if (.not. allocated(grpmass)) allocate (grpmass(0:maxgrp)) if (.not. allocated(wgrp)) allocate (wgrp(0:maxgrp,0:maxgrp)) if (allocated(kgrp)) deallocate (kgrp) if (allocated(grplist)) deallocate (grplist) allocate (kgrp(n)) allocate (grplist(n)) c c set defaults for the group atom list and weight options c use_group = .false. use_intra = .false. use_inter = .false. ngrp = 0 do i = 1, n kgrp(i) = 0 grplist(i) = 0 end do do i = 0, maxgrp igrp(1,i) = 1 igrp(2,i) = 0 end do do i = 0, maxgrp do j = 0, maxgrp wgrp(j,i) = 1.0d0 end do end do c c perform dynamic allocation of some local arrays c size = max(100,n) allocate (list(size)) c c get any keywords containing atom group definitions c do j = 1, nkey next = 1 record = keyline(j) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:6) .eq. 'GROUP ') then use_group = .true. gnum = 0 do i = 1, size list(i) = 0 end do call getnumb (record,gnum,next) if (gnum .gt. maxgrp) then write (iout,10) 10 format (/,' CLUSTER -- Too many Atom Groups;', & ' Increase MAXGRP') call fatal end if string = record(next:240) read (string,*,err=20,end=20) (list(i),i=1,size) 20 continue i = 1 do while (list(i) .ne. 0) if (list(i) .gt. 0) then grplist(list(i)) = gnum i = i + 1 else do k = abs(list(i)), abs(list(i+1)) grplist(k) = gnum end do i = i + 2 end if end do c c get any keywords with weights for group interactions c else if (keyword(1:15) .eq. 'GROUP-MOLECULE ') then use_group = .true. use_inter = .true. use_intra = .false. if (nmol .gt. maxgrp) then write (iout,30) 30 format (/,' CLUSTER -- Too many Atom Groups;', & ' Increase MAXGRP') call fatal end if do i = 1, nmol do k = imol(1,i), imol(2,i) grplist(kmol(k)) = i end do end do c c get any keywords with weights for group interactions c else if (keyword(1:13) .eq. 'GROUP-SELECT ') then ga = 0 gb = 0 wg = -1.0d0 string = record(next:240) read (string,*,err=40,end=40) ga,gb,wg 40 continue if (wg .lt. 0.0d0) wg = 1.0d0 wgrp(ga,gb) = wg wgrp(gb,ga) = wg use_inter = .false. c c get keywords to select common sets of group interactions c else if (keyword(1:12) .eq. 'GROUP-INTRA ') then use_intra = .true. use_inter = .false. else if (keyword(1:12) .eq. 'GROUP-INTER ') then use_inter = .true. use_intra = .false. end if end do c c pack atoms of each group into a contiguous indexed list c if (use_group) then do i = 1, n list(i) = grplist(i) end do call sort3 (n,list,kgrp) c c find the first and last atom in each of the groups c k = list(1) igrp(1,k) = 1 do i = 1, n j = list(i) if (j .ne. k) then igrp(2,k) = i - 1 igrp(1,j) = i k = j end if ngrp = max(j,ngrp) end do igrp(2,j) = n c c sort the list of atoms in each group by atom number c 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))) end do end if c c perform deallocation of some local arrays c deallocate (list) c c use only intragroup or intergroup interactions if selected c if (use_intra) then do i = 0, ngrp do j = 0, ngrp wgrp(j,i) = 0.0d0 end do wgrp(i,i) = 1.0d0 end do end if if (use_inter) then do i = 0, ngrp do j = 0, ngrp wgrp(j,i) = 1.0d0 end do wgrp(i,i) = 0.0d0 end do end if c c disable consideration of interactions with any empty groups c do i = 0, ngrp size = igrp(2,i) - igrp(1,i) + 1 if (size .eq. 0) then do j = 0, ngrp wgrp(j,i) = 0.0d0 wgrp(i,j) = 0.0d0 end do end if end do c c turn off bounds and replicas for intragroup calculations c if (use_intra) then use_bounds = .false. use_replica = .false. call cutoffs end if c c compute the total mass of all atoms in each group c do i = 1, ngrp grpmass(i) = 0.0d0 do j = igrp(1,i), igrp(2,i) grpmass(i) = grpmass(i) + mass(kgrp(j)) end do end do c c output the final list of atoms in each group c if (use_group .and. debug) then do i = 1, ngrp size = igrp(2,i) - igrp(1,i) + 1 if (size .ne. 0) then write (iout,50) i 50 format (/,' List of Atoms in Group',i3,' :',/) write (iout,60) (kgrp(j),j=igrp(1,i),igrp(2,i)) 60 format (3x,10i7) end if end do end if c c output the weights for intragroup and intergroup interactions c if (use_group .and. debug) then header = .true. do i = 0, ngrp do j = i, ngrp if (wgrp(j,i) .ne. 0.0d0) then if (header) then header = .false. write (iout,70) 70 format (/,' Active Sets of Intra- and InterGroup', & ' Interactions :', & //,11x,'Groups',15x,'Type',14x,'Weight',/) end if if (i .eq. j) then write (iout,80) i,j,wgrp(j,i) 80 format (5x,2i6,12x,'IntraGroup',5x,f12.4) else write (iout,90) i,j,wgrp(j,i) 90 format (5x,2i6,12x,'InterGroup',5x,f12.4) end if end if end do end do end if return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine column -- access Hessian elements by column ## c ## ## c ################################################################ c c c "column" takes the off-diagonal Hessian elements stored c as sparse rows and sets up indices to allow column access c c subroutine column (nvar,hinit,hstop,hindex, & cinit,cstop,cindex,cvalue) implicit none integer i,j,k integer m,nvar integer hinit(*) integer hstop(*) integer cinit(*) integer cstop(*) integer hindex(*) integer cindex(*) integer cvalue(*) c c c zero out the start and end marker for each column c do i = 1, nvar cinit(i) = 0 cstop(i) = 0 end do c c count the number of elements in each column c do i = 1, nvar do j = hinit(i), hstop(i) k = hindex(j) cstop(k) = cstop(k) + 1 end do end do c c set each start marker just past last element for its column c cinit(1) = cstop(1) + 1 do i = 2, nvar cinit(i) = cinit(i-1) + cstop(i) end do c c set column index by scanning rows in reverse order c do i = nvar, 1, -1 do j = hinit(i), hstop(i) k = hindex(j) m = cinit(k) - 1 cinit(k) = m cindex(m) = i cvalue(m) = j end do end do c c convert from number of elements to end marker for column c do i = 1, nvar cstop(i) = cinit(i) + cstop(i) - 1 end do return end c c c ################################################### c ## COPYRIGHT (C) 1995 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine command -- get any command line arguments ## c ## ## c ############################################################## c c c "command" uses the standard Unix-like iargc/getarg routines c to get the number and values of arguments specified on the c command line at program runtime c c subroutine command use argue implicit none integer i,iargc character*1 letter character*20 blank c c c initialize command line arguments as blank strings c narg = 0 blank = ' ' do i = 0, maxarg arg(i) = blank//blank//blank end do c c get the number of arguments and store each in a string c narg = iargc () if (narg .gt. maxarg) narg = maxarg do i = 0, narg call getarg (i,arg(i)) end do c c mark the command line options as unuseable for input c listarg(0) = .false. do i = 1, narg listarg(i) = .true. end do do i = 1, narg letter = arg(i)(1:1) if (letter .eq. '-') then letter = arg(i)(2:2) call upcase (letter) if (letter.ge.'A' .and. letter.le.'Z') then listarg(i) = .false. listarg(i+1) = .false. end if end if end do return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine connect -- attached atom list from Z-matrix ## c ## ## c ################################################################ c c c "connect" sets up the attached atom arrays c starting from a set of internal coordinates c c subroutine connect use atoms use couple use zcoord use zclose implicit none integer i,j,k integer id1,id2 c c c zero out the number of atoms attached to each atom c do i = 1, n n12(i) = 0 do j = 1, maxval i12(j,i) = 0 end do end do c c loop over the bonds in the Z-matrix, adding each bond c to the attach atom lists unless it is to be removed c do i = 2, n k = iz(1,i) do j = 1, ndel id1 = idel(1,j) id2 = idel(2,j) if ((i.eq.id1 .and. k.eq.id2) .or. & (i.eq.id2 .and. k.eq.id1)) goto 10 end do n12(i) = n12(i) + 1 n12(k) = n12(k) + 1 i12(n12(i),i) = k i12(n12(k),k) = i 10 continue end do c c add any extra bonds used to make ring closures c do i = 1, nadd do j = 1, 2 k = iadd(j,i) n12(k) = n12(k) + 1 i12(n12(k),k) = iadd(3-j,i) end do end do c c sort the attached atom lists into ascending order c do i = 1, n call sort (n12(i),i12(1,i)) end do return end c c c ################################################################## c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## COPYRIGHT (C) 1985 by Scripps Clinic & Research Foundation ## c ## All Rights Reserved ## c ################################################################## c c ################################################################# c ## ## c ## subroutine connolly -- analytical surface area & volume ## c ## ## c ################################################################# c c c "connolly" uses the algorithms from the AMS/VAM programs of c Michael Connolly to compute the analytical molecular surface c area and volume of a collection of spherical atoms; thus c it implements Fred Richards' molecular surface definition as c a set of analytically defined spherical and toroidal polygons c c literature references: c c M. L. Connolly, "Analytical Molecular Surface Calculation", c Journal of Applied Crystallography, 16, 548-558 (1983) c c M. L. Connolly, "Computation of Molecular Volume", Journal c of the American Chemical Society, 107, 1118-1124 (1985) c c variables only in the Connolly routines: c c na number of atoms c ntt number of temporary tori c nt number of tori c np number of probe positions c nv number of vertices c nen number of concave edges c nfn number of concave faces c nc number of circles c neq number of convex edges c nfs number of saddle faces c ncy number of cycles c fqncy number of cycles bounding convex face c nfq number of convex faces c cyneq number of convex edges in cycle c c axyz atomic coordinates c ar atomic radii c pr probe radius c skip if true, atom is not used c nosurf if true, atom has no free surface c afree atom free of neighbors c abur atom buried c c acls begin and end pointers for atoms neighbors c cls atom numbers of neighbors c clst pointer from neighbor to torus c c tta torus atom numbers c ttfe first edge of each temporary torus c ttle last edge of each temporary torus c enext pointer to next edge of torus c ttbur torus buried c ttfree torus free c c t torus center c tr torus radius c tax torus axis c ta torus atom numbers c tfe torus first edge c tfree torus free of neighbors c c p probe coordinates c pa probe atom numbers c vxyz vertex coordinates c va vertex atom number c vp vertex probe number c c circle center c cr circle radius c ca circle atom number c ct circle torus number c c env concave edge vertex numbers c fnen concave face concave edge numbers c eqc convex edge circle number c eqv convex edge vertex numbers c afe first convex edge of each atom c ale last convex edge of each atom c eqnext pointer to next convex edge of atom c fsen saddle face concave edge numbers c fseq saddle face convex edge numbers c cyeq cycle convex edge numbers c fqa atom number of convex face c fqcy convex face cycle numbers c c subroutine connolly (n,x,y,z,rad,exclude,reentrant,area,volume) use faces implicit none integer i,n real*8 area,volume real*8 exclude real*8 reentrant real*8 eps real*8 x(*) real*8 y(*) real*8 z(*) real*8 rad(*) logical dowiggle c c c dimensions for arrays used by Connolly routines c maxcls = 320 * n maxtt = 160 * n maxt = 8 * n maxp = 8 * n maxv = 24 * n maxen = 24 * n maxfn = 8 * n maxc = 16 * n maxeq = 24 * n maxfs = 12 * n maxcy = 6 * n mxcyeq = 32 maxfq = 4 * n mxfqcy = 10 c c perform dynamic allocation of some global arrays c if (.not. allocated(ar)) allocate (ar(n)) if (.not. allocated(axyz)) allocate (axyz(3,n)) if (.not. allocated(skip)) allocate (skip(n)) if (.not. allocated(nosurf)) allocate (nosurf(n)) if (.not. allocated(afree)) allocate (afree(n)) if (.not. allocated(abur)) allocate (abur(n)) if (.not. allocated(cls)) allocate (cls(maxcls)) if (.not. allocated(clst)) allocate (clst(maxcls)) if (.not. allocated(acls)) allocate (acls(2,n)) if (.not. allocated(ttfe)) allocate (ttfe(maxtt)) if (.not. allocated(ttle)) allocate (ttle(maxtt)) if (.not. allocated(enext)) allocate (enext(maxen)) if (.not. allocated(tta)) allocate (tta(2,maxtt)) if (.not. allocated(ttbur)) allocate (ttbur(maxtt)) if (.not. allocated(ttfree)) allocate (ttfree(maxtt)) if (.not. allocated(tfe)) allocate (tfe(maxt)) if (.not. allocated(ta)) allocate (ta(2,maxt)) if (.not. allocated(tr)) allocate (tr(maxt)) if (.not. allocated(t)) allocate (t(3,maxt)) if (.not. allocated(tax)) allocate (tax(3,maxt)) if (.not. allocated(tfree)) allocate (tfree(maxt)) if (.not. allocated(pa)) allocate (pa(3,maxp)) if (.not. allocated(p)) allocate (p(3,maxp)) if (.not. allocated(va)) allocate (va(maxv)) if (.not. allocated(vp)) allocate (vp(maxv)) if (.not. allocated(vxyz)) allocate (vxyz(3,maxv)) if (.not. allocated(env)) allocate (env(2,maxen)) if (.not. allocated(fnen)) allocate (fnen(3,maxfn)) if (.not. allocated(ca)) allocate (ca(maxc)) if (.not. allocated(ct)) allocate (ct(maxc)) if (.not. allocated(cr)) allocate (cr(maxc)) if (.not. allocated(c)) allocate (c(3,maxc)) if (.not. allocated(eqc)) allocate (eqc(maxeq)) if (.not. allocated(eqv)) allocate (eqv(2,maxeq)) if (.not. allocated(afe)) allocate (afe(n)) if (.not. allocated(ale)) allocate (ale(n)) if (.not. allocated(eqnext)) allocate (eqnext(maxeq)) if (.not. allocated(fsen)) allocate (fsen(2,maxfs)) if (.not. allocated(fseq)) allocate (fseq(2,maxfs)) if (.not. allocated(cyneq)) allocate (cyneq(maxcy)) if (.not. allocated(cyeq)) allocate (cyeq(mxcyeq,maxcy)) if (.not. allocated(fqa)) allocate (fqa(maxfq)) if (.not. allocated(fqncy)) allocate (fqncy(maxfq)) if (.not. allocated(fqcy)) allocate (fqcy(mxfqcy,maxfq)) c c set the number of atoms and reentrant probe radius c na = n pr = reentrant c c set atom coordinates and radii, the excluded buffer c probe radius ("exclude") is added to atomic radii c do i = 1, na axyz(1,i) = x(i) axyz(2,i) = y(i) axyz(3,i) = z(i) ar(i) = rad(i) if (ar(i) .eq. 0.0d0) then skip(i) = .true. else ar(i) = ar(i) + exclude skip(i) = .false. end if end do c c random coordinate perturbation to avoid numerical issues c dowiggle = .true. if (dowiggle) then eps = 0.000001d0 call wiggle (na,axyz,eps) end if c c find the analytical surface area and volume c call nearby call torus call place call compress call saddles call contact call vam (area,volume) return end c c c ############################################################# c ## ## c ## subroutine nearby -- list of neighboring atom pairs ## c ## ## c ############################################################# c c c "nearby" finds all of the through-space neighbors of each c atom for use in surface area and volume calculations c c local variables : c c ico integer cube coordinates c icuptr pointer to next atom in cube c comin minimum atomic coordinates (cube corner) c icube pointer to first atom in list for cube c scube true if cube contains active atoms c sscube true if cube or adjacent cubes have active atoms c itnl temporary neighbor list, before sorting c c subroutine nearby use faces implicit none integer maxclsa parameter (maxclsa=1000) integer i,j,k,m integer iptr,juse integer i1,j1,k1 integer iatom,jatom integer ici,icj,ick integer jci,jcj,jck integer jcls,jmin integer jmincls,jmold integer ncls,nclsa integer maxcube integer clsa(maxclsa) integer itnl(maxclsa) integer, allocatable :: icuptr(:) integer, allocatable :: ico(:,:) integer, allocatable :: icube(:,:,:) real*8 radmax,width real*8 sum,sumi real*8 dist2,d2,r2 real*8 vect1,vect2,vect3 real*8 comin(3) logical, allocatable :: scube(:,:,:) logical, allocatable :: sscube(:,:,:) c c c ignore all atoms that are completely inside another atom; c may give nonsense results if this step is not taken c do i = 1, na-1 if (.not. skip(i)) then do j = i+1, na d2 = dist2(axyz(1,i),axyz(1,j)) r2 = (ar(i) - ar(j))**2 if (.not.skip(j) .and. d2.lt.r2) then if (ar(i) .lt. ar(j)) then skip(i) = .true. else skip(j) = .true. end if end if end do end if end do c c check for new coordinate minima and radii maxima c radmax = 0.0d0 do k = 1, 3 comin(k) = axyz(k,1) end do do i = 1, na do k = 1, 3 if (axyz(k,i) .lt. comin(k)) comin(k) = axyz(k,i) end do if (ar(i) .gt. radmax) radmax = ar(i) end do c c calculate width of cube from maximum c atom radius and probe radius c width = 2.0d0 * (radmax+pr) c c perform dynamic allocation of some local arrays c maxcube = 40 allocate (icuptr(na)) allocate (ico(3,na)) allocate (icube(maxcube,maxcube,maxcube)) allocate (scube(maxcube,maxcube,maxcube)) allocate (sscube(maxcube,maxcube,maxcube)) c c set up cube arrays; first the integer coordinate arrays c do i = 1, na do k = 1, 3 ico(k,i) = int((axyz(k,i)-comin(k))/width) + 1 if (ico(k,i) .lt. 1) then call cerror ('Cube Coordinate Too Small') else if (ico(k,i) .gt. maxcube) then call cerror ('Cube Coordinate Too Large') end if end do end do c c initialize head pointer and srn=2 arrays c do i = 1, maxcube do j = 1, maxcube do k = 1, maxcube icube(i,j,k) = 0 scube(i,j,k) = .false. sscube(i,j,k) = .false. end do end do end do c c initialize linked list pointers c do i = 1, na icuptr(i) = 0 end do c c set up head and later pointers for each atom c do iatom = 1, na c c skip atoms with surface request numbers of zero c if (skip(iatom)) goto 30 i = ico(1,iatom) j = ico(2,iatom) k = ico(3,iatom) if (icube(i,j,k) .le. 0) then c c first atom in this cube c icube(i,j,k) = iatom else c c add to end of linked list c iptr = icube(i,j,k) 10 continue c c check for duplicate atoms, turn off one of them c if (dist2(axyz(1,iatom),axyz(1,iptr)) .le. 0.0d0) then skip(iatom) = .true. goto 30 end if c c move on down the list c if (icuptr(iptr) .le. 0) goto 20 iptr = icuptr(iptr) goto 10 20 continue c c store atom number c icuptr(iptr) = iatom end if c c check for surfaced atom c if (.not. skip(iatom)) scube(i,j,k) = .true. 30 continue end do c c check if this cube or any adjacent cube has active atoms c do k = 1, maxcube do j = 1, maxcube do i = 1, maxcube if (icube(i,j,k) .ne. 0) then do k1 = max(k-1,1), min(k+1,maxcube) do j1 = max(j-1,1), min(j+1,maxcube) do i1 = max(i-1,1), min(i+1,maxcube) if (scube(i1,j1,k1)) then sscube(i,j,k) = .true. end if end do end do end do end if end do end do end do ncls = 0 c c zero pointers for atom and find its cube c do i = 1, na nclsa = 0 nosurf(i) = skip(i) acls(1,i) = 0 acls(2,i) = 0 if (skip(i)) goto 70 ici = ico(1,i) icj = ico(2,i) ick = ico(3,i) c c skip iatom if its cube and adjoining c cubes contain only blockers c if (.not. sscube(ici,icj,ick)) goto 70 sumi = 2.0d0*pr + ar(i) c c check iatom cube and adjacent cubes for neighboring atoms c do jck = max(ick-1,1), min(ick+1,maxcube) do jcj = max(icj-1,1), min(icj+1,maxcube) do jci = max(ici-1,1), min(ici+1,maxcube) j = icube(jci,jcj,jck) 40 continue c c check for end of linked list for this cube c if (j .le. 0) goto 60 if (i .eq. j) goto 50 if (skip(j)) goto 50 c c distance check c sum = sumi + ar(j) vect1 = abs(axyz(1,j) - axyz(1,i)) if (vect1 .ge. sum) goto 50 vect2 = abs(axyz(2,j) - axyz(2,i)) if (vect2 .ge. sum) goto 50 vect3 = abs(axyz(3,j) - axyz(3,i)) if (vect3 .ge. sum) goto 50 d2 = vect1**2 + vect2**2 + vect3**2 if (d2 .ge. sum**2) goto 50 c c atoms are neighbors, save atom number in temporary array c if (.not. skip(j)) nosurf(i) = .false. nclsa = nclsa + 1 if (nclsa .gt. maxclsa) then call cerror ('Too many Neighbors for Atom') end if itnl(nclsa) = j 50 continue c c get number of next atom in cube c j = icuptr(j) goto 40 60 continue end do end do end do if (nosurf(i)) goto 70 c c set up neighbors arrays with jatom in increasing order c jmold = 0 do juse = 1, nclsa jmin = na + 1 do jcls = 1, nclsa c c don't use ones already sorted c if (itnl(jcls) .gt. jmold) then if (itnl(jcls) .lt. jmin) then jmin = itnl(jcls) jmincls = jcls end if end if end do jmold = jmin jcls = jmincls jatom = itnl(jcls) clsa(juse) = jatom end do c c set up pointers to first and last neighbors of atom c if (nclsa .gt. 0) then acls(1,i) = ncls + 1 do m = 1, nclsa ncls = ncls + 1 if (ncls .gt. maxcls) then call cerror ('Too many Neighboring Atom Pairs') end if cls(ncls) = clsa(m) end do acls(2,i) = ncls end if 70 continue end do c c perform deallocation of some local arrays c deallocate (icuptr) deallocate (ico) deallocate (icube) deallocate (scube) deallocate (sscube) return end c c c ############################################################## c ## ## c ## subroutine torus -- position of each temporary torus ## c ## ## c ############################################################## c c c "torus" sets a list of all of the temporary torus positions c by testing for a torus between each atom and its neighbors c c subroutine torus use faces implicit none integer ia,ja,jn integer ibeg,iend real*8 ttr real*8 tt(3) real*8 ttax(3) logical ttok c c c no torus is possible if there is only one atom c ntt = 0 do ia = 1, na afree(ia) = .true. end do if (na .le. 1) return c c get begin and end pointers to neighbors of this atom c do ia = 1, na if (.not. nosurf(ia)) then ibeg = acls(1,ia) iend = acls(2,ia) c c check for no neighbors c if (ibeg .gt. 0) then do jn = ibeg, iend c c clear pointer from neighbor to torus c clst(jn) = 0 c c get atom number of neighbor c ja = cls(jn) c c don't create torus twice c if (ja .ge. ia) then c c do some solid geometry c call gettor (ia,ja,ttok,tt,ttr,ttax) if (ttok) then c c we have a temporary torus, set up variables c ntt = ntt + 1 if (ntt .gt. maxtt) then call cerror ('Too many Temporary Tori') end if c c mark both atoms not free c afree(ia) = .false. afree(ja) = .false. tta(1,ntt) = ia tta(2,ntt) = ja c c pointer from neighbor to torus c clst(jn) = ntt c c initialize torus as both free and buried c ttfree(ntt) = .true. ttbur(ntt) = .true. c c clear pointers from torus to first and last concave edges c ttfe(ntt) = 0 ttle(ntt) = 0 end if end if end do end if end if end do return end c c c ################################################################# c ## ## c ## subroutine place -- locate positions of the probe sites ## c ## ## c ################################################################# c c c "place" finds the probe sites by putting the probe sphere c tangent to each triple of neighboring atoms c c subroutine place use faces implicit none integer maxmnb parameter (maxmnb=500) integer k,ke,kv integer l,l1,l2 integer ia,ja,ka integer ik,ip,jk integer km,la,lm integer lkf,itt,nmnb integer iend,jend integer iptr,jptr integer mnb(maxmnb) integer ikt(maxmnb) integer jkt(maxmnb) integer lkcls(maxmnb) real*8 dist2,d2,det real*8 hij,hijk real*8 uij(3),uijk(3) real*8 bij(3),bijk(3) real*8 aijk(3),pijk(3) real*8 tempv(3) real*8 discls(maxmnb) real*8 sumcls(maxmnb) logical tb,ttok,prbok c c c no possible placement if there are no temporary tori c np = 0 nfn = 0 nen = 0 nv = 0 if (ntt .le. 0) return c c consider each torus in turn c do itt = 1, ntt c c get atom numbers c ia = tta(1,itt) ja = tta(2,itt) c c form mutual neighbor list; clear number c of mutual neighbors of atoms ia and ja c nmnb = 0 c c get begin and end pointers for each atom's neighbor list c iptr = acls(1,ia) jptr = acls(1,ja) if (iptr.le.0 .or. jptr.le.0) goto 130 iend = acls(2,ia) jend = acls(2,ja) c c collect mutual neighbors c 10 continue c c check for end of loop c if (iptr .gt. iend) goto 40 if (jptr .gt. jend) goto 40 c c go move the lagging pointer c if (cls(iptr) .lt. cls(jptr)) goto 20 if (cls(jptr) .lt. cls(iptr)) goto 30 c c both point at same neighbor; one more mutual neighbor c save atom number of mutual neighbor c nmnb = nmnb + 1 if (nmnb .gt. maxmnb) then call cerror ('Too many Mutual Neighbors') end if mnb(nmnb) = cls(iptr) c c save pointers to second and third tori c ikt(nmnb) = clst(iptr) jkt(nmnb) = clst(jptr) 20 continue c c increment pointer to ia atom neighbors c iptr = iptr + 1 goto 10 30 continue c c increment pointer to ja atom neighbors c jptr = jptr + 1 goto 10 40 continue c c we have all the mutual neighbors of ia and ja c if no mutual neighbors, skip to end of loop c if (nmnb .le. 0) then ttbur(itt) = .false. goto 130 end if call gettor (ia,ja,ttok,bij,hij,uij) do km = 1, nmnb ka = mnb(km) discls(km) = dist2(bij,axyz(1,ka)) sumcls(km) = (pr+ar(ka))**2 c c initialize link to next farthest out neighbor c lkcls(km) = 0 end do c c set up a linked list of neighbors in order of c increasing distance from ia-ja torus center c lkf = 1 if (nmnb .le. 1) goto 70 c c put remaining neighbors in linked list at proper position c do l = 2, nmnb l1 = 0 l2 = lkf 50 continue if (discls(l) .lt. discls(l2)) goto 60 l1 = l2 l2 = lkcls(l2) if (l2 .ne. 0) goto 50 60 continue c c add to list c if (l1 .eq. 0) then lkf = l lkcls(l) = l2 else lkcls(l1) = l lkcls(l) = l2 end if end do 70 continue c c loop thru mutual neighbors c do km = 1, nmnb c c get atom number of neighbors c ka = mnb(km) if (skip(ia) .and. skip(ja) .and. skip(ka)) goto 120 c c get tori numbers for neighbor c ik = ikt(km) jk = jkt(km) c c possible new triple, do some geometry to c retrieve saddle center, axis and radius c call getprb (ia,ja,ka,prbok,tb,bijk,hijk,uijk) if (tb) then ttbur(itt) = .true. ttfree(itt) = .false. goto 120 end if c c no duplicate triples c if (ka .lt. ja) goto 120 c c check whether any possible probe positions c if (.not. prbok) goto 120 c c altitude vector c do k = 1, 3 aijk(k) = hijk * uijk(k) end do c c we try two probe placements c do ip = 1, 2 do k = 1, 3 if (ip .eq. 1) then pijk(k) = bijk(k) + aijk(k) else pijk(k) = bijk(k) - aijk(k) end if end do c c mark three tori not free c ttfree(itt) = .false. ttfree(ik) = .false. ttfree(jk) = .false. c c check for collisions c lm = lkf 80 continue if (lm .le. 0) goto 100 c c get atom number of mutual neighbor c la = mnb(lm) c c must not equal third atom c if (la .eq. ka) goto 90 c c compare distance to sum of radii c d2 = dist2(pijk,axyz(1,la)) if (d2 .le. sumcls(lm)) goto 110 90 continue lm = lkcls(lm) goto 80 100 continue c c we have a new probe position c np = np + 1 if (np .gt. maxp) then call cerror ('Too many Probe Positions') end if c c mark three tori not buried c ttbur(itt) = .false. ttbur(ik) = .false. ttbur(jk) = .false. c c store probe center c do k = 1, 3 p(k,np) = pijk(k) end do c c calculate vectors from probe to atom centers c if (nv+3 .gt. maxv) call cerror ('Too many Vertices') do k = 1, 3 vxyz(k,nv+1) = axyz(k,ia) - p(k,np) vxyz(k,nv+2) = axyz(k,ja) - p(k,np) vxyz(k,nv+3) = axyz(k,ka) - p(k,np) end do c c calculate determinant of vectors defining triangle c det = vxyz(1,nv+1)*vxyz(2,nv+2)*vxyz(3,nv+3) & + vxyz(1,nv+2)*vxyz(2,nv+3)*vxyz(3,nv+1) & + vxyz(1,nv+3)*vxyz(2,nv+1)*vxyz(3,nv+2) & - vxyz(1,nv+3)*vxyz(2,nv+2)*vxyz(3,nv+1) & - vxyz(1,nv+2)*vxyz(2,nv+1)*vxyz(3,nv+3) & - vxyz(1,nv+1)*vxyz(2,nv+3)*vxyz(3,nv+2) c c now add probe coordinates to vertices c do k = 1, 3 vxyz(k,nv+1) = p(k,np) + vxyz(k,nv+1)*pr/(ar(ia)+pr) vxyz(k,nv+2) = p(k,np) + vxyz(k,nv+2)*pr/(ar(ja)+pr) vxyz(k,nv+3) = p(k,np) + vxyz(k,nv+3)*pr/(ar(ka)+pr) end do c c want the concave face to have counter-clockwise orientation c if (det .gt. 0.0d0) then c c swap second and third vertices c do k = 1, 3 tempv(k) = vxyz(k,nv+2) vxyz(k,nv+2) = vxyz(k,nv+3) vxyz(k,nv+3) = tempv(k) end do c c set up pointers from probe to atoms c pa(1,np) = ia pa(2,np) = ka pa(3,np) = ja c c set up pointers from vertices to atoms c va(nv+1) = ia va(nv+2) = ka va(nv+3) = ja c c insert concave edges into linked lists for appropriate tori c call inedge (nen+1,ik) call inedge (nen+2,jk) call inedge (nen+3,itt) else c c similarly, if face already counter clockwise c pa(1,np) = ia pa(2,np) = ja pa(3,np) = ka va(nv+1) = ia va(nv+2) = ja va(nv+3) = ka call inedge (nen+1,itt) call inedge (nen+2,jk) call inedge (nen+3,ik) end if c c set up pointers from vertices to probe c do kv = 1, 3 vp(nv+kv) = np end do c c set up concave edges and concave face c if (nen+3 .gt. maxen) then call cerror ('Too many Concave Edges') end if c c edges point to vertices c env(1,nen+1) = nv+1 env(2,nen+1) = nv+2 env(1,nen+2) = nv+2 env(2,nen+2) = nv+3 env(1,nen+3) = nv+3 env(2,nen+3) = nv+1 if (nfn+1 .gt. maxfn) then call cerror ('Too many Concave Faces') end if c c face points to edges c do ke = 1, 3 fnen(ke,nfn+1) = nen + ke end do c c increment counters for number of faces, edges and vertices c nfn = nfn + 1 nen = nen + 3 nv = nv + 3 110 continue end do 120 continue end do 130 continue end do return end c c c ################################################################ c ## ## c ## subroutine inedge -- manage linked list of torus edges ## c ## ## c ################################################################ c c c "inedge" inserts a concave edge into the c linked list for its temporary torus c c subroutine inedge (ien,itt) use faces implicit none integer ien,itt,ieqen c c c check for a serious error in the calling arguments c if (ien .le. 0) call cerror ('Bad Edge Number in INEDGE') if (itt .le. 0) call cerror ('Bad Torus Number in INEDGE') c c set beginning of list or add to end c if (ttfe(itt) .eq. 0) then ttfe(itt) = ien enext(ien) = 0 ttle(itt) = ien else ieqen = ttle(itt) enext(ieqen) = ien enext(ien) = 0 ttle(itt) = ien end if return end c c c ################################################################# c ## ## c ## subroutine compress -- condense temporary to final tori ## c ## ## c ################################################################# c c c "compress" transfers only the non-buried tori from c the temporary tori arrays to the final tori arrays c c subroutine compress use faces implicit none integer itt,ia,ja integer iptr,ned integer ip1,ip2 integer iv1,iv2 logical ttok c c c initialize the number of nonburied tori c nt = 0 if (ntt .le. 0) return c c if torus is free, then it is not buried; c skip to end of loop if buried torus c do itt = 1, ntt if (ttfree(itt)) ttbur(itt) = .false. if (.not. ttbur(itt)) then c c first, transfer information c nt = nt + 1 if (nt .gt. maxt) call cerror ('Too many NonBuried Tori') ia = tta(1,itt) ja = tta(2,itt) call gettor (ia,ja,ttok,t(1,nt),tr(nt),tax(1,nt)) ta(1,nt) = ia ta(2,nt) = ja tfree(nt) = ttfree(itt) tfe(nt) = ttfe(itt) c c special check for inconsistent probes c iptr = tfe(nt) ned = 0 do while (iptr .ne. 0) ned = ned + 1 iptr = enext(iptr) end do if (mod(ned,2) .ne. 0) then iptr = tfe(nt) do while (iptr .ne. 0) iv1 = env(1,iptr) iv2 = env(2,iptr) ip1 = vp(iv1) ip2 = vp(iv2) call cerror ('Odd Torus for Probes IP1 and IP2') iptr = enext(iptr) end do end if end if end do return end c c c ############################################################## c ## ## c ## subroutine saddles -- builds saddle pieces from tori ## c ## ## c ############################################################## c c c "saddles" constructs circles, convex edges and saddle faces c c subroutine saddles use faces use math implicit none integer maxent parameter (maxent=500) integer k,ia,in,ip integer it,iv,itwo integer ien,ient,nent integer l1,l2,m1,n1 integer ten(maxent) integer nxtang(maxent) real*8 triple,factor real*8 dtev,dt real*8 atvect(3) real*8 teang(maxent) real*8 tev(3,maxent) logical sdstrt(maxent) c c c zero the number of circles, convex edges and saddle faces c nc = 0 neq = 0 nfs = 0 do ia = 1, na afe(ia) = 0 ale(ia) = 0 abur(ia) = .true. end do c c no saddle faces if no tori c if (nt .lt. 1) return c c cycle through tori c do it = 1, nt if (skip(ta(1,it)) .and. skip(ta(2,it))) goto 80 c c set up two circles c do in = 1, 2 ia = ta(in,it) c c mark atom not buried c abur(ia) = .false. c c vector from atom to torus center c do k = 1, 3 atvect(k) = t(k,it) - axyz(k,ia) end do factor = ar(ia) / (ar(ia)+pr) c c one more circle c nc = nc + 1 if (nc .gt. maxc) call cerror ('Too many Circles') c c circle center c do k = 1, 3 c(k,nc) = axyz(k,ia) + factor*atvect(k) end do c c pointer from circle to atom and to torus c ca(nc) = ia ct(nc) = it c c circle radius c cr(nc) = factor * tr(it) end do c c skip to special code if free torus c if (tfree(it)) goto 70 c c now we collect all the concave edges for this torus; c for each concave edge, calculate vector from torus center c thru probe center and the angle relative to first such vector c c clear the number of concave edges for torus c nent = 0 c c pointer to start of linked list c ien = tfe(it) 10 continue c c finished if concave edge pointer is zero c if (ien .le. 0) goto 20 c c one more concave edge c nent = nent + 1 if (nent .gt. maxent) then call cerror ('Too many Edges for Torus') end if c c first vertex of edge c iv = env(1,ien) c c probe number of vertex c ip = vp(iv) do k = 1, 3 tev(k,nent) = p(k,ip) - t(k,it) end do dtev = 0.0d0 do k = 1, 3 dtev = dtev + tev(k,nent)**2 end do if (dtev .le. 0.0d0) call cerror ('Probe on Torus Axis') dtev = sqrt(dtev) do k = 1, 3 tev(k,nent) = tev(k,nent) / dtev end do c c store concave edge number c ten(nent) = ien if (nent .gt. 1) then c c calculate angle between this vector and first vector c dt = 0.0d0 do k = 1, 3 dt = dt + tev(k,1)*tev(k,nent) end do c c be careful c if (dt .gt. 1.0d0) dt = 1.0d0 if (dt .lt. -1.0d0) dt = -1.0d0 c c store angle c teang(nent) = acos(dt) c c get the sign right c if (triple(tev(1,1),tev(1,nent),tax(1,it)) .lt. 0.0d0) then teang(nent) = 2.0d0*pi - teang(nent) end if else teang(1) = 0.0d0 end if c c saddle face starts with this edge if it points parallel c to torus axis vector (which goes from first to second atom) c sdstrt(nent) = (va(iv) .eq. ta(1,it)) c c next edge in list c ien = enext(ien) goto 10 20 continue if (nent .le. 0) then call cerror ('No Edges for Non-free Torus') end if itwo = 2 if (mod(nent,itwo) .ne. 0) then call cerror ('Odd Number of Edges for Torus') end if c c set up linked list of concave edges in order c of increasing angle around the torus axis; c clear second linked (angle-ordered) list pointers c do ient = 1, nent nxtang(ient) = 0 end do do ient = 2, nent c c we have an entry to put into linked list c search for place to put it c l1 = 0 l2 = 1 30 continue if (teang(ient) .lt. teang(l2)) goto 40 c c not yet, move along c l1 = l2 l2 = nxtang(l2) if (l2 .ne. 0) goto 30 40 continue c c we are at end of linked list or between l1 and l2; c insert edge c if (l1 .le. 0) call cerror ('Logic Error in SADDLES') nxtang(l1) = ient nxtang(ient) = l2 end do c c collect pairs of concave edges into saddles c create convex edges while you're at it c l1 = 1 50 continue if (l1 .le. 0) goto 60 c c check for start of saddle c if (sdstrt(l1)) then c c one more saddle face c nfs = nfs + 1 if (nfs .gt. maxfs) call cerror ('Too many Saddle Faces') c c get edge number c ien = ten(l1) c c first concave edge of saddle c fsen(1,nfs) = ien c c one more convex edge c neq = neq + 1 if (neq .gt. maxeq) call cerror ('Too many Convex Edges') c c first convex edge points to second circle c eqc(neq) = nc c c atom circle lies on c ia = ca(nc) c c insert convex edge into linked list for atom c call ipedge (neq,ia) c c first vertex of convex edge is second vertex of concave edge c eqv(1,neq) = env(2,ien) c c first convex edge of saddle c fseq(1,nfs) = neq c c one more convex edge c neq = neq + 1 if (neq .gt. maxeq) call cerror ('Too many Convex Edges') c c second convex edge points to first circle c eqc(neq) = nc - 1 ia = ca(nc-1) c c insert convex edge into linked list for atom c call ipedge (neq,ia) c c second vertex of second convex edge c is first vertex of first concave edge c eqv(2,neq) = env(1,ien) l1 = nxtang(l1) c c wrap around c if (l1 .le. 0) l1 = 1 if (sdstrt(l1)) then m1 = nxtang(l1) if (m1 .le. 0) m1 = 1 if (sdstrt(m1)) call cerror ('Three Starts in a Row') n1 = nxtang(m1) c c the old switcheroo c nxtang(l1) = n1 nxtang(m1) = l1 l1 = m1 end if ien = ten(l1) c c second concave edge for saddle face c fsen(2,nfs) = ien c c second vertex of first convex edge is c first vertex of second concave edge c eqv(2,neq-1) = env(1,ien) c c first vertex of second convex edge is c second vertex of second concave edge c eqv(1,neq) = env(2,ien) fseq(2,nfs) = neq c c quit if we have wrapped around to first edge c if (l1 .eq. 1) goto 60 end if c c next concave edge c l1 = nxtang(l1) goto 50 60 continue goto 80 c c free torus c 70 continue c c set up entire circles as convex edges for new saddle surface; c one more saddle face c nfs = nfs + 1 if (nfs .gt. maxfs) call cerror ('Too many Saddle Faces') c c no concave edges for saddle c fsen(1,nfs) = 0 fsen(2,nfs) = 0 c c one more convex edge c neq = neq + 1 ia = ca(nc) c c insert convex edge into linked list for atom c call ipedge (neq,ia) c c no vertices for convex edge c eqv(1,neq) = 0 eqv(2,neq) = 0 c c pointer from convex edge to second circle c eqc(neq) = nc c c first convex edge for saddle face c fseq(1,nfs) = neq c c one more convex edge c neq = neq + 1 ia = ca(nc-1) c c insert second convex edge into linked list c call ipedge (neq,ia) c c no vertices for convex edge c eqv(1,neq) = 0 eqv(2,neq) = 0 c c convex edge points to first circle c eqc(neq) = nc - 1 c c second convex edge for saddle face c fseq(2,nfs) = neq c c nothing to do for buried torus c 80 continue end do return end c c c ################################################################ c ## ## c ## subroutine gettor -- test torus site between two atoms ## c ## ## c ################################################################ c c c "gettor" tests for a possible torus position at the interface c between two atoms, and finds the torus radius, center and axis c c subroutine gettor (ia,ja,ttok,torcen,torad,torax) use faces implicit none integer k,ia,ja real*8 dist2,dij real*8 temp,temp1 real*8 temp2 real*8 torad real*8 torcen(3) real*8 torax(3) real*8 vij(3) real*8 uij(3) real*8 bij(3) logical ttok c c c get the distance between the two atoms c ttok = .false. dij = sqrt(dist2(axyz(1,ia),axyz(1,ja))) c c find a unit vector along interatomic (torus) axis c do k = 1, 3 vij(k) = axyz(k,ja) - axyz(k,ia) uij(k) = vij(k) / dij end do c c find coordinates of the center of the torus c temp = 1.0d0 + ((ar(ia)+pr)**2-(ar(ja)+pr)**2)/dij**2 do k = 1, 3 bij(k) = axyz(k,ia) + 0.5d0*vij(k)*temp end do c c skip if atoms too far apart (should not happen) c temp1 = (ar(ia)+ar(ja)+2.0d0*pr)**2 - dij**2 if (temp1 .ge. 0.0d0) then c c skip if one atom is inside the other c temp2 = dij**2 - (ar(ia)-ar(ja))**2 if (temp2 .ge. 0.0d0) then c c store the torus radius, center and axis c ttok = .true. torad = sqrt(temp1*temp2) / (2.0d0*dij) do k = 1, 3 torcen(k) = bij(k) torax(k) = uij(k) end do end if end if return end c c c ################################################################## c ## ## c ## subroutine getprb -- test probe site between three atoms ## c ## ## c ################################################################## c c c "getprb" tests for a possible probe position at the interface c between three neighboring atoms c c subroutine getprb (ia,ja,ka,prbok,tb,bijk,hijk,uijk) use faces implicit none integer k,ia,ja,ka real*8 dot,dotijk,dotut real*8 wijk,swijk,fact real*8 dist2,dat2 real*8 rad,rad2 real*8 dba,rip2,hijk real*8 rij,rik real*8 uij(3),uik(3) real*8 uijk(3),utb(3) real*8 tij(3),tik(3) real*8 bijk(3),tijik(3) logical prbok,tb,tok c c c initialize, then check torus over atoms "ia" and "ja" c prbok = .false. tb = .false. call gettor (ia,ja,tok,tij,rij,uij) if (.not. tok) return dat2 = dist2(axyz(1,ka),tij) rad2 = (ar(ka)+pr)**2 - rij**2 c c if "ka" less than "ja", then all we care about c is whether the torus is buried c if (ka .lt. ja) then if (rad2 .le. 0.0d0) return if (dat2 .gt. rad2) return end if call gettor (ia,ka,tok,tik,rik,uik) if (.not. tok) return dotijk = dot(uij,uik) if (dotijk .gt. 1.0d0) dotijk = 1.0d0 if (dotijk .lt. -1.0d0) dotijk = -1.0d0 wijk = acos(dotijk) swijk = sin(wijk) c c if the three atoms are colinear, then there is no c probe placement; but we still care whether the torus c is buried by atom "k" c if (swijk .eq. 0.0d0) then tb = (rad2.gt.0.0d0 .and. dat2.le.rad2) return end if call vcross (uij,uik,uijk) do k = 1, 3 uijk(k) = uijk(k) / swijk end do call vcross (uijk,uij,utb) do k = 1, 3 tijik(k) = tik(k) - tij(k) end do dotut = dot(uik,tijik) fact = dotut / swijk do k = 1, 3 bijk(k) = tij(k) + utb(k)*fact end do dba = dist2(axyz(1,ia),bijk) rip2 = (ar(ia) + pr)**2 rad = rip2 - dba if (rad .lt. 0.0d0) then tb = (rad2.gt.0.0d0 .and. dat2.le.rad2) else prbok = .true. hijk = sqrt(rad) end if return end c c c ################################################################# c ## ## c ## subroutine ipedge -- manage linked list of convex edges ## c ## ## c ################################################################# c c c "ipedge" inserts convex edge into linked list for atom c c subroutine ipedge (ieq,ia) use faces implicit none integer ieq,ia,ieqen c c c first, check for an error condition c if (ieq .le. 0) call cerror ('Bad Edge Number in IPEDGE') if (ia .le. 0) call cerror ('Bad Atom Number in IPEDGE') c c set beginning of list or add to end c if (afe(ia) .eq. 0) then afe(ia) = ieq eqnext(ieq) = 0 ale(ia) = ieq else ieqen = ale(ia) eqnext(ieqen) = ieq eqnext(ieq) = 0 ale(ia) = ieq end if return end c c c ############################################################### c ## ## c ## subroutine contact -- builds exposed contact surfaces ## c ## ## c ############################################################### c c c "contact" constructs the contact surface, cycles and convex faces c c subroutine contact use faces implicit none integer maxeqa,maxcypa parameter (maxeqa=300) parameter (maxcypa=100) integer i,k,ia,ia2,it integer ieq,ic,jc,jcy integer neqa,ieqa,jeqa integer ncypa,icya,jcya,kcya integer ncyeq,icyeq,jcyeq integer ncyold,nused,lookv integer aic(maxeqa) integer aia(maxeqa) integer aeq(maxeqa) integer av(2,maxeqa) integer ncyeqa(maxcypa) integer cyeqa(mxcyeq,maxcypa) real*8 anorm,anaa,factor real*8 acvect(3,maxeqa) real*8 aavect(3,maxeqa) real*8 pole(3),unvect(3) real*8 acr(maxeqa) logical ptincy,eqused(maxeqa) logical cycy(maxcypa,maxcypa) logical cyused(maxcypa) logical samef(maxcypa,maxcypa) c c c zero out the number of cycles and convex faces c ncy = 0 nfq = 0 c c mark all free atoms not buried c do ia = 1, na if (afree(ia)) abur(ia) = .false. end do c c go through all atoms c do ia = 1, na if (skip(ia)) goto 130 c c skip to end of loop if buried atom c if (abur(ia)) goto 130 c c special code for completely solvent-accessible atom c if (afree(ia)) goto 120 c c gather convex edges for atom c clear number of convex edges for atom c neqa = 0 c c pointer to first edge c ieq = afe(ia) 10 continue c c check whether finished gathering c if (ieq .le. 0) goto 20 c c one more edge c neqa = neqa + 1 if (neqa .gt. maxeqa) then call cerror ('Too many Convex Edges for Atom') end if c c store vertices of edge c av(1,neqa) = eqv(1,ieq) av(2,neqa) = eqv(2,ieq) c c store convex edge number c aeq(neqa) = ieq ic = eqc(ieq) c c store circle number c aic(neqa) = ic c c get neighboring atom c it = ct(ic) if (ta(1,it) .eq. ia) then ia2 = ta(2,it) else ia2 = ta(1,it) end if c c store other atom number, we might need it sometime c aia(neqa) = ia2 c c vector from atom to circle center; also c vector from atom to center of neighboring atom c sometimes we use one vector, sometimes the other c do k = 1, 3 acvect(k,neqa) = c(k,ic) - axyz(k,ia) aavect(k,neqa) = axyz(k,ia2) - axyz(k,ia) end do c c circle radius c acr(neqa) = cr(ic) c c pointer to next edge c ieq = eqnext(ieq) goto 10 20 continue if (neqa .le. 0) then call cerror ('No Edges for Non-buried, Non-free Atom') end if c c form cycles; initialize all the c convex edges as not used in cycle c do ieqa = 1, neqa eqused(ieqa) = .false. end do c c save old number of cycles c ncyold = ncy nused = 0 ncypa = 0 30 continue c c look for starting edge c do ieqa = 1, neqa if (.not. eqused(ieqa)) goto 40 end do c c cannot find starting edge, finished c goto 80 40 continue c c pointer to edge c ieq = aeq(ieqa) c c one edge so far for this cycle c ncyeq = 1 c c one more cycle for atom c ncypa = ncypa + 1 if (ncypa .gt. maxcypa) then call cerror ('Too many Cycles per Atom') end if c c mark edge used in cycle c eqused(ieqa) = .true. nused = nused + 1 c c one more cycle for molecule c ncy = ncy + 1 if (ncy .gt. maxcy) call cerror ('Too many Cycles') c c index of edge in atom cycle array c cyeqa(ncyeq,ncypa) = ieqa c c store in molecule cycle array a pointer to edge c cyeq(ncyeq,ncy) = ieq c c second vertex of this edge is the vertex to look c for next as the first vertex of another edge c lookv = av(2,ieqa) c c if no vertex, this cycle is finished c if (lookv .le. 0) goto 70 50 continue c c look for next connected edge c do jeqa = 1, neqa if (eqused(jeqa)) goto 60 c c check second vertex of ieqa versus first vertex of jeqa c if (av(1,jeqa) .ne. lookv) goto 60 c c edges are connected c pointer to edge c ieq = aeq(jeqa) c c one more edge for this cycle c ncyeq = ncyeq + 1 if (ncyeq .gt. mxcyeq) then call cerror ('Too many Edges per Cycle') end if eqused(jeqa) = .true. nused = nused + 1 c c store index in local edge array c cyeqa(ncyeq,ncypa) = jeqa c c store pointer to edge c cyeq(ncyeq,ncy) = ieq c c new vertex to look for c lookv = av(2,jeqa) c c if no vertex, this cycle is in trouble c if (lookv .le. 0) then call cerror ('Pointer Error in Cycle') end if goto 50 60 continue end do c c it better connect to first edge of cycle c if (lookv .ne. av(1,ieqa)) then call cerror ('Cycle does not Close') end if 70 continue c c this cycle is finished, store number of edges in cycle c ncyeqa(ncypa) = ncyeq cyneq(ncy) = ncyeq if (nused .ge. neqa) goto 80 c c look for more cycles c goto 30 80 continue c c compare cycles for inside/outside relation; c check to see if cycle i is inside cycle j c do icya = 1, ncypa do jcya = 1, ncypa jcy = ncyold + jcya cycy(icya,jcya) = .true. if (icya .eq. jcya) goto 90 c c if cycle j has two or fewer edges, nothing can c lie in its exterior; i is therefore inside j c if (ncyeqa(jcya) .le. 2) goto 90 c c if cycles i and j have a pair of edges belonging c to the same circle, then they are outside each other c do icyeq = 1, ncyeqa(icya) ieqa = cyeqa(icyeq,icya) ic = aic(ieqa) do jcyeq = 1, ncyeqa(jcya) jeqa = cyeqa(jcyeq,jcya) jc = aic(jeqa) if (ic .eq. jc) then cycy(icya,jcya) = .false. goto 90 end if end do end do ieqa = cyeqa(1,icya) anaa = anorm(aavect(1,ieqa)) factor = ar(ia) / anaa c c north pole and unit vector pointing south c do k = 1, 3 pole(k) = factor*aavect(k,ieqa) + axyz(k,ia) unvect(k) = -aavect(k,ieqa) / anaa end do cycy(icya,jcya) = ptincy(pole,unvect,jcy) 90 continue end do end do c c group cycles into faces; direct comparison for i and j c do icya = 1, ncypa do jcya = 1, ncypa c c tentatively say that cycles i and j bound c the same face if they are inside each other c samef(icya,jcya) = (cycy(icya,jcya) .and. & cycy(jcya,icya)) end do end do c c if i is in exterior of k, and k is in interior of c i and j, then i and j do not bound the same face c do icya = 1, ncypa do jcya = 1, ncypa if (icya .ne. jcya) then do kcya = 1, ncypa if (kcya.ne.icya .and. kcya.ne.jcya) then if (cycy(kcya,icya) .and. cycy(kcya,jcya) & .and. .not.cycy(icya,kcya)) then samef(icya,jcya) = .false. samef(jcya,icya) = .false. end if end if end do end if end do end do c c fill gaps so that "samef" falls into complete blocks c do icya = 1, ncypa-2 do jcya = icya+1, ncypa-1 if (samef(icya,jcya)) then do kcya = jcya+1, ncypa if (samef(jcya,kcya)) then samef(icya,kcya) = .true. samef(kcya,icya) = .true. end if end do end if end do end do c c group cycles belonging to the same face c do icya = 1, ncypa cyused(icya) = .false. end do c c clear number of cycles used in bounding faces c nused = 0 do icya = 1, ncypa c c check for already used c if (cyused(icya)) goto 110 c c one more convex face c nfq = nfq + 1 if (nfq .gt. maxfq) then call cerror ('Too many Convex Faces') end if c c clear number of cycles for face c fqncy(nfq) = 0 c c pointer from face to atom c fqa(nfq) = ia c c look for all other cycles belonging to same face c do jcya = 1, ncypa c c check for cycle already used in another face c if (cyused(jcya)) goto 100 c c cycles i and j belonging to same face c if (.not. samef(icya,jcya)) goto 100 c c mark cycle used c cyused(jcya) = .true. nused = nused + 1 c c one more cycle for face c fqncy(nfq) = fqncy(nfq) + 1 if (fqncy(nfq) .gt. mxfqcy) then call cerror ('Too many Cycles bounding Convex Face') end if i = fqncy(nfq) c c store cycle number c fqcy(i,nfq) = ncyold + jcya c c check for finished c if (nused .ge. ncypa) goto 130 100 continue end do 110 continue end do c c should not fall through end of do loops c call cerror ('Not all Cycles grouped into Convex Faces') 120 continue c c one face for free atom; no cycles c nfq = nfq + 1 if (nfq .gt. maxfq) then call cerror ('Too many Convex Faces') end if fqa(nfq) = ia fqncy(nfq) = 0 130 continue end do return end c c c ############################################################ c ## ## c ## subroutine vam -- find area and volume of molecule ## c ## ## c ############################################################ c c c "vam" takes the analytical molecular surface defined c as a collection of spherical and toroidal polygons c and uses it to compute the surface area and volume c c subroutine vam (area,volume) use faces use inform use iounit use math implicit none integer maxdot,maxop,nscale parameter (maxdot=1000) parameter (maxop=100) parameter (nscale=20) integer k,ke,ke2,kv integer ia,ic,ip,it integer ien,ieq integer ifn,ifq,ifs integer iv,iv1,iv2 integer isc,jfn integer ndots,idot integer nop,iop,nate integer neat,neatmx integer ivs(3) integer ispind(3) integer ispnd2(3) integer ifnop(maxop) integer, allocatable :: nlap(:) integer, allocatable :: enfs(:) integer, allocatable :: fnt(:,:) integer, allocatable :: nspt(:,:) real*8 area,volume real*8 alens,vint,vcone real*8 vpyr,vlens,hedron real*8 totaq,totvq,totas real*8 totvs,totasp,totvsp real*8 totan,totvn real*8 alenst,alensn real*8 vlenst,vlensn,prism real*8 areaq,volq,areas,vols real*8 areasp,volsp,arean,voln real*8 depth,triple,dist2 real*8 areado,voldo,dot,dota real*8 ds2,dij2,dt,dpp real*8 rm,rat,rsc,rho real*8 sumsc,sumsig,sumlam real*8 stq,scinc,coran,corvn real*8 cenop(3,maxop) real*8 sdot(3),dotv(nscale) real*8 tau(3),ppm(3) real*8 xpnt1(3),xpnt2(3) real*8 qij(3),qji(3) real*8 vects(3,3) real*8 vect1(3),vect2(3) real*8 vect3(3),vect4(3) real*8 vect5(3),vect6(3) real*8 vect7(3),vect8(3) real*8 upp(3),thetaq(3) real*8 sigmaq(3) real*8 umq(3),upq(3) real*8 uc(3),uq(3),uij(3) real*8 dots(3,maxdot) real*8 tdots(3,maxdot) real*8, allocatable :: atmarea(:) real*8, allocatable :: depths(:) real*8, allocatable :: cora(:) real*8, allocatable :: corv(:) real*8, allocatable :: alts(:,:) real*8, allocatable :: fncen(:,:) real*8, allocatable :: fnvect(:,:,:) logical spindl logical alli,allj logical anyi,anyj logical case1,case2 logical cinsp,cintp logical usenum logical vip(3) logical ate(maxop) logical, allocatable :: badav(:) logical, allocatable :: badt(:) logical, allocatable :: fcins(:,:) logical, allocatable :: fcint(:,:) logical, allocatable :: fntrev(:,:) c c c compute the volume of the interior polyhedron c hedron = 0.0d0 do ifn = 1, nfn call measpm (ifn,prism) hedron = hedron + prism end do c c perform dynamic allocation of some local arrays c allocate (nlap(nfn)) allocate (enfs(20*na)) allocate (fnt(3,nfn)) allocate (nspt(3,nfn)) allocate (atmarea(na)) allocate (depths(nfn)) allocate (cora(nfn)) allocate (corv(nfn)) allocate (alts(3,nfn)) allocate (fncen(3,nfn)) allocate (fnvect(3,3,nfn)) allocate (badav(nfn)) allocate (badt(nfn)) allocate (fcins(3,nfn)) allocate (fcint(3,nfn)) allocate (fntrev(3,nfn)) c c compute the area and volume due to convex faces c as well as the area partitioned among the atoms c totaq = 0.0d0 totvq = 0.0d0 do ia = 1, na atmarea(ia) = 0.0d0 end do do ifq = 1, nfq call measfq (ifq,areaq,volq) ia = fqa(ifq) atmarea(ia) = atmarea(ia) + areaq totaq = totaq + areaq totvq = totvq + volq end do c c compute the area and volume due to saddle faces c as well as the spindle correction value c totas = 0.0d0 totvs = 0.0d0 totasp = 0.0d0 totvsp = 0.0d0 do ifs = 1, nfs do k = 1, 2 ien = fsen(k,ifs) if (ien .gt. 0) enfs(ien) = ifs end do call measfs (ifs,areas,vols,areasp,volsp) totas = totas + areas totvs = totvs + vols totasp = totasp + areasp totvsp = totvsp + volsp if (areas-areasp .lt. 0.0d0) then call cerror ('Negative Area for Saddle Face') end if end do c c compute the area and volume due to concave faces c totan = 0.0d0 totvn = 0.0d0 do ifn = 1, nfn call measfn (ifn,arean,voln) totan = totan + arean totvn = totvn + voln end do c c compute the area and volume lens correction values c alenst = 0.0d0 alensn = 0.0d0 vlenst = 0.0d0 vlensn = 0.0d0 if (pr .le. 0.0d0) goto 140 ndots = maxdot call gendot (ndots,dots,pr,0.0d0,0.0d0,0.0d0) dota = (4.0d0 * pi * pr**2) / ndots do ifn = 1, nfn nlap(ifn) = 0 cora(ifn) = 0.0d0 corv(ifn) = 0.0d0 badav(ifn) = .false. badt(ifn) = .false. do k = 1, 3 nspt(k,ifn) = 0 end do ien = fnen(1,ifn) iv = env(1,ien) ip = vp(iv) depths(ifn) = depth(ip,alts(1,ifn)) do k = 1, 3 fncen(k,ifn) = p(k,ip) end do ia = va(iv) c c get vertices and vectors c do ke = 1, 3 ien = fnen(ke,ifn) ivs(ke) = env(1,ien) ia = va(ivs(ke)) ifs = enfs(ien) ieq = fseq(1,ifs) ic = eqc(ieq) it = ct(ic) fnt(ke,ifn) = it fntrev(ke,ifn) = (ta(1,it) .ne. ia) end do do ke = 1, 3 do k = 1, 3 vects(k,ke) = vxyz(k,ivs(ke)) - p(k,ip) end do end do c c calculate normal vectors for the three planes c that cut out the geodesic triangle c call vcross (vects(1,1),vects(1,2),fnvect(1,1,ifn)) call vnorm (fnvect(1,1,ifn),fnvect(1,1,ifn)) call vcross (vects(1,2),vects(1,3),fnvect(1,2,ifn)) call vnorm (fnvect(1,2,ifn),fnvect(1,2,ifn)) call vcross (vects(1,3),vects(1,1),fnvect(1,3,ifn)) call vnorm (fnvect(1,3,ifn),fnvect(1,3,ifn)) end do do ifn = 1, nfn-1 do jfn = ifn+1, nfn dij2 = dist2(fncen(1,ifn),fncen(1,jfn)) if (dij2 .gt. 4.0d0*pr**2) goto 90 if (depths(ifn).gt.pr .and. depths(jfn).gt.pr) goto 90 c c these two probes may have intersecting surfaces c dpp = sqrt(dist2(fncen(1,ifn),fncen(1,jfn))) c c compute the midpoint c do k = 1, 3 ppm(k) = (fncen(k,ifn) + fncen(k,jfn)) / 2.0d0 upp(k) = (fncen(k,jfn) - fncen(k,ifn)) / dpp end do rm = pr**2 - (dpp/2.0d0)**2 if (rm .lt. 0.0d0) rm = 0.0d0 rm = sqrt(rm) rat = dpp / (2.0d0*pr) if (rat .gt. 1.0d0) rat = 1.0d0 if (rat .lt. -1.0d0) rat = -1.0d0 rho = asin(rat) c c use circle-plane intersection routine c alli = .true. anyi = .false. spindl = .false. do k = 1, 3 ispind(k) = 0 ispnd2(k) = 0 end do do ke = 1, 3 thetaq(ke) = 0.0d0 sigmaq(ke) = 0.0d0 tau(ke) = 0.0d0 call cirpln (ppm,rm,upp,fncen(1,ifn),fnvect(1,ke,ifn), & cinsp,cintp,xpnt1,xpnt2) fcins(ke,ifn) = cinsp fcint(ke,ifn) = cintp if (.not. cinsp) alli = .false. if (cintp) anyi = .true. if (.not. cintp) goto 10 it = fnt(ke,ifn) if (tr(it) .gt. pr) goto 10 do ke2 = 1, 3 if (it .eq. fnt(ke2,jfn)) then ispind(ke) = it nspt(ke,ifn) = nspt(ke,ifn) + 1 ispnd2(ke2) = it nspt(ke2,jfn) = nspt(ke2,jfn) + 1 spindl = .true. end if end do if (ispind(ke) .eq. 0) goto 10 c c check that the two ways of calculating c intersection points match c rat = tr(it) / pr if (rat .gt. 1.0d0) rat = 1.0d0 if (rat .lt. -1.0d0) rat = -1.0d0 thetaq(ke) = acos(rat) stq = sin(thetaq(ke)) if (fntrev(ke,ifn)) then do k = 1, 3 uij(k) = -tax(k,it) end do else do k = 1, 3 uij(k) = tax(k,it) end do end if do k = 1, 3 qij(k) = t(k,it) - stq * pr * uij(k) qji(k) = t(k,it) + stq * pr * uij(k) end do do k = 1, 3 umq(k) = (qij(k) - ppm(k)) / rm upq(k) = (qij(k) - fncen(k,ifn)) / pr end do call vcross (uij,upp,vect1) dt = dot(umq,vect1) if (dt .gt. 1.0d0) dt = 1.0d0 if (dt .lt. -1.0d0) dt = -1.0d0 sigmaq(ke) = acos(dt) call vcross (upq,fnvect(1,ke,ifn),vect1) call vnorm (vect1,uc) call vcross (upp,upq,vect1) call vnorm (vect1,uq) dt = dot(uc,uq) if (dt .gt. 1.0d0) dt = 1.0d0 if (dt .lt. -1.0d0) dt = -1.0d0 tau(ke) = pi - acos(dt) 10 continue end do allj = .true. anyj = .false. do ke = 1, 3 call cirpln (ppm,rm,upp,fncen(1,jfn),fnvect(1,ke,jfn), & cinsp,cintp,xpnt1,xpnt2) fcins(ke,jfn) = cinsp fcint(ke,jfn) = cintp if (.not. cinsp) allj = .false. if (cintp) anyj = .true. end do case1 = (alli .and. allj .and. .not.anyi .and. .not.anyj) case2 = (anyi .and. anyj .and. spindl) if (.not.case1 .and. .not.case2) goto 90 c c this kind of overlap can be handled c nlap(ifn) = nlap(ifn) + 1 nlap(jfn) = nlap(jfn) + 1 do ke = 1, 3 ien = fnen(ke,ifn) iv1 = env(1,ien) iv2 = env(2,ien) do k = 1, 3 vect3(k) = vxyz(k,iv1) - fncen(k,ifn) vect4(k) = vxyz(k,iv2) - fncen(k,ifn) end do do ke2 = 1, 3 if (ispind(ke) .eq. ispnd2(ke2)) goto 40 if (ispind(ke) .eq. 0) goto 40 call cirpln (fncen(1,ifn),pr,fnvect(1,ke,ifn), & fncen(1,jfn),fnvect(1,ke2,jfn), & cinsp,cintp,xpnt1,xpnt2) if (.not. cintp) goto 40 ien = fnen(ke2,jfn) iv1 = env(1,ien) iv2 = env(2,ien) do k = 1, 3 vect7(k) = vxyz(k,iv1) - fncen(k,jfn) vect8(k) = vxyz(k,iv2) - fncen(k,jfn) end do c c check whether point lies on spindle arc c do k = 1, 3 vect1(k) = xpnt1(k) - fncen(k,ifn) vect2(k) = xpnt2(k) - fncen(k,ifn) vect5(k) = xpnt1(k) - fncen(k,jfn) vect6(k) = xpnt2(k) - fncen(k,jfn) end do if (triple(vect3,vect1,fnvect(1,ke,ifn)) .lt. 0.0d0) & goto 20 if (triple(vect1,vect4,fnvect(1,ke,ifn)) .lt. 0.0d0) & goto 20 if (triple(vect7,vect5,fnvect(1,ke2,jfn)) .lt. 0.0d0) & goto 20 if (triple(vect5,vect8,fnvect(1,ke2,jfn)) .lt. 0.0d0) & goto 20 goto 30 20 continue if (triple(vect3,vect2,fnvect(1,ke,ifn)) .lt. 0.0d0) & goto 40 if (triple(vect2,vect4,fnvect(1,ke,ifn)) .lt. 0.0d0) & goto 40 if (triple(vect7,vect6,fnvect(1,ke2,jfn)) .lt. 0.0d0) & goto 40 if (triple(vect6,vect8,fnvect(1,ke2,jfn)) .lt. 0.0d0) & goto 40 30 continue badav(ifn) = .true. 40 continue end do end do do ke = 1, 3 ien = fnen(ke,ifn) iv1 = env(1,ien) iv2 = env(2,ien) do k = 1, 3 vect3(k) = vxyz(k,iv1) - fncen(k,ifn) vect4(k) = vxyz(k,iv2) - fncen(k,ifn) end do do ke2 = 1, 3 if (ispind(ke) .eq. ispnd2(ke2)) goto 70 if (ispnd2(ke2) .eq. 0) goto 70 call cirpln (fncen(1,jfn),pr,fnvect(1,ke2,jfn), & fncen(1,ifn),fnvect(1,ke,ifn), & cinsp,cintp,xpnt1,xpnt2) if (.not. cintp) goto 70 ien = fnen(ke2,jfn) iv1 = env(1,ien) iv2 = env(2,ien) do k = 1, 3 vect7(k) = vxyz(k,iv1) - fncen(k,jfn) vect8(k) = vxyz(k,iv2) - fncen(k,jfn) end do c c check whether point lies on spindle arc c do k = 1, 3 vect1(k) = xpnt1(k) - fncen(k,ifn) vect2(k) = xpnt2(k) - fncen(k,ifn) vect5(k) = xpnt1(k) - fncen(k,jfn) vect6(k) = xpnt2(k) - fncen(k,jfn) end do if (triple(vect3,vect1,fnvect(1,ke,ifn)) .lt. 0.0d0) & goto 50 if (triple(vect1,vect4,fnvect(1,ke,ifn)) .lt. 0.0d0) & goto 50 if (triple(vect7,vect5,fnvect(1,ke2,jfn)) .lt. 0.0d0) & goto 50 if (triple(vect5,vect8,fnvect(1,ke2,jfn)) .lt. 0.0d0) & goto 50 goto 60 50 continue if (triple(vect3,vect2,fnvect(1,ke,ifn)) .lt. 0.0d0) & goto 70 if (triple(vect2,vect4,fnvect(1,ke,ifn)) .lt. 0.0d0) & goto 70 if (triple(vect7,vect6,fnvect(1,ke2,jfn)) .lt. 0.0d0) & goto 70 if (triple(vect6,vect8,fnvect(1,ke2,jfn)) .lt. 0.0d0) & goto 70 60 continue badav(jfn) = .true. 70 continue end do end do sumlam = 0.0d0 sumsig = 0.0d0 sumsc = 0.0d0 do ke = 1, 3 if (ispind(ke) .ne. 0) then sumlam = sumlam + pi - tau(ke) sumsig = sumsig + sigmaq(ke) - pi sumsc = sumsc + sin(sigmaq(ke))*cos(sigmaq(ke)) end if end do alens = 2.0d0 * pr**2 * (pi - sumlam - sin(rho)*(pi+sumsig)) vint = alens * pr / 3.0d0 vcone = pr * rm**2 * sin(rho) * (pi+sumsig) / 3.0d0 vpyr = pr * rm**2 * sin(rho) * sumsc / 3.0d0 vlens = vint - vcone + vpyr cora(ifn) = cora(ifn) + alens cora(jfn) = cora(jfn) + alens corv(ifn) = corv(ifn) + vlens corv(jfn) = corv(jfn) + vlens c c check for vertex on opposing probe in face c do kv = 1, 3 vip(kv) = .false. ien = fnen(kv,jfn) iv = env(1,ien) do k = 1, 3 vect1(k) = vxyz(k,iv) - fncen(k,ifn) end do call vnorm (vect1,vect1) do ke = 1, 3 dt = dot(fnvect(1,ke,ifn),vxyz(1,iv)) if (dt .gt. 0.0d0) goto 80 end do vip(kv) = .true. 80 continue end do 90 continue end do end do do ifn = 1, nfn do ke = 1, 3 if (nspt(ke,ifn) .gt. 1) badt(ifn) = .true. end do end do do ifn = 1, nfn if (nlap(ifn) .le. 0) goto 130 c c gather all overlapping probes c nop = 0 do jfn = 1, nfn if (ifn .ne. jfn) then dij2 = dist2(fncen(1,ifn),fncen(1,jfn)) if (dij2 .le. 4.0d0*pr**2) then if (depths(jfn) .le. pr) then nop = nop + 1 if (nop .gt. maxop) then call cerror ('NOP Overflow in VAM') end if ifnop(nop) = jfn do k = 1, 3 cenop(k,nop) = fncen(k,jfn) end do end if end if end if end do c c numerical calculation of the correction c areado = 0.0d0 voldo = 0.0d0 scinc = 1.0d0 / nscale do isc = 1, nscale rsc = isc - 0.5d0 dotv(isc) = pr * dota * rsc**2 * scinc**3 end do do iop = 1, nop ate(iop) = .false. end do neatmx = 0 do idot = 1, ndots do ke = 1, 3 dt = dot(fnvect(1,ke,ifn),dots(1,idot)) if (dt .gt. 0.0d0) goto 120 end do do k = 1, 3 tdots(k,idot) = fncen(k,ifn) + dots(k,idot) end do do iop = 1, nop jfn = ifnop(iop) ds2 = dist2(tdots(1,idot),fncen(1,jfn)) if (ds2 .lt. pr**2) then areado = areado + dota goto 100 end if end do 100 continue do isc = 1, nscale rsc = isc - 0.5d0 do k = 1, 3 sdot(k) = fncen(k,ifn) + rsc*scinc*dots(k,idot) end do neat = 0 do iop = 1, nop jfn = ifnop(iop) ds2 = dist2(sdot,fncen(1,jfn)) if (ds2 .lt. pr**2) then do k = 1, 3 vect1(k) = sdot(k) - fncen(k,jfn) end do do ke = 1, 3 dt = dot(fnvect(1,ke,jfn),vect1) if (dt .gt. 0.0d0) goto 110 end do neat = neat + 1 ate(iop) = .true. 110 continue end if end do if (neat .gt. neatmx) neatmx = neat if (neat .gt. 0) then voldo = voldo + dotv(isc) * (neat/(1.0d0+neat)) end if end do 120 continue end do coran = areado corvn = voldo nate = 0 do iop = 1, nop if (ate(iop)) nate = nate + 1 end do c c use either the analytical or numerical correction c usenum = (nate.gt.nlap(ifn) .or. neatmx.gt.1 .or. badt(ifn)) if (usenum) then cora(ifn) = coran corv(ifn) = corvn alensn = alensn + cora(ifn) vlensn = vlensn + corv(ifn) else if (badav(ifn)) then corv(ifn) = corvn vlensn = vlensn + corv(ifn) end if alenst = alenst + cora(ifn) vlenst = vlenst + corv(ifn) 130 continue end do 140 continue c c print out the decomposition of the area and volume c if (debug) then write (iout,150) 150 format (/,' Convex Surface Area for Individual Atoms :',/) k = 1 do while (k .le. na) write (iout,160) (ia,atmarea(ia),ia=k,min(k+4,na)) 160 format (1x,5(i7,f8.3)) k = k + 5 end do write (iout,170) 170 format (/,' Surface Area and Volume by Geometry Type :') write (iout,180) nfq,totaq,totvq 180 format (/,' Convex Faces :',i12,5x,'Area :',f13.3, & 4x,'Volume :',f13.3) write (iout,190) nfs,totas,totvs 190 format (' Saddle Faces :',i12,5x,'Area :',f13.3, & 4x,'Volume :',f13.3) write (iout,200) nfn,totan,totvn 200 format (' Concave Faces :',i11,5x,'Area :',f13.3, & 4x,'Volume :',f13.3) write (iout,210) hedron 210 format (' Buried Polyhedra :',36x,'Volume :',f13.3) if (totasp.ne.0.0d0 .or. totvsp.ne.0.0d0 .or. & alenst.ne.0.0d0 .or. vlenst.ne.0.0d0) then write (iout,220) -totasp,-totvsp 220 format (/,' Spindle Correction :',11x,'Area :',f13.3, & 4x,'Volume :',f13.3) write (iout,230) -alenst-alensn,vlenst-vlensn 230 format (' Lens Analytical Correction :',3x,'Area :',f13.3, & 4x,'Volume :',f13.3) end if if (alensn.ne.0.0d0 .or. vlensn.ne.0.0d0) then write (iout,240) alensn,vlensn 240 format (' Lens Numerical Correction :',4x,'Area :',f13.3, & 4x,'Volume :',f13.3) end if end if c c perform deallocation of some local arrays c deallocate (nlap) deallocate (enfs) deallocate (fnt) deallocate (nspt) deallocate (atmarea) deallocate (depths) deallocate (cora) deallocate (corv) deallocate (alts) deallocate (fncen) deallocate (fnvect) deallocate (badav) deallocate (badt) deallocate (fcins) deallocate (fcint) deallocate (fntrev) c c finally, compute the total area and total volume c area = totaq + totas + totan - totasp - alenst volume = totvq + totvs + totvn + hedron - totvsp + vlenst return end c c c ###################### c ## ## c ## function depth ## c ## ## c ###################### c c function depth (ip,alt) use faces implicit none integer k,ip,ia1,ia2,ia3 real*8 depth,dot,alt(3) real*8 vect1(3),vect2(3) real*8 vect3(3),vect4(3) c c ia1 = pa(1,ip) ia2 = pa(2,ip) ia3 = pa(3,ip) do k = 1, 3 vect1(k) = axyz(k,ia1) - axyz(k,ia3) vect2(k) = axyz(k,ia2) - axyz(k,ia3) vect3(k) = p(k,ip) - axyz(k,ia3) end do call vcross (vect1,vect2,vect4) call vnorm (vect4,vect4) depth = dot(vect4,vect3) do k = 1, 3 alt(k) = vect4(k) end do return end c c c ############################################################ c ## ## c ## subroutine measpm -- volume of interior polyhedron ## c ## ## c ############################################################ c c c "measpm" computes the volume of a single prism section of c the full interior polyhedron c c subroutine measpm (ifn,prism) use faces implicit none integer k,ke,ien integer iv,ia,ip,ifn real*8 prism,height real*8 vect1(3) real*8 vect2(3) real*8 vect3(3) real*8 pav(3,3) c c height = 0.0d0 do ke = 1, 3 ien = fnen(ke,ifn) iv = env(1,ien) ia = va(iv) height = height + axyz(3,ia) ip = vp(iv) do k = 1, 3 pav(k,ke) = axyz(k,ia) - p(k,ip) end do end do height = height / 3.0d0 do k = 1, 3 vect1(k) = pav(k,2) - pav(k,1) vect2(k) = pav(k,3) - pav(k,1) end do call vcross (vect1,vect2,vect3) prism = 0.5d0 * height * vect3(3) return end c c c ######################### c ## ## c ## subroutine measfq ## c ## ## c ######################### c c subroutine measfq (ifq,areaq,volq) use faces use math implicit none integer k,ke,ifq,ieq integer ia,ia2,ic integer it,iv1,iv2 integer ncycle,ieuler integer icyptr,icy integer nedge real*8 areaq,volq real*8 dot,dt,gauss real*8 vecang,angle,geo real*8 pcurve,gcurve real*8 vect1(3) real*8 vect2(3) real*8 acvect(3) real*8 aavect(3) real*8 radial(3,mxcyeq) real*8 tanv(3,2,mxcyeq) c c ia = fqa(ifq) pcurve = 0.0d0 gcurve = 0.0d0 ncycle = fqncy(ifq) if (ncycle .gt. 0) then ieuler = 2 - ncycle else ieuler = 2 end if do icyptr = 1, ncycle icy = fqcy(icyptr,ifq) nedge = cyneq(icy) do ke = 1, nedge ieq = cyeq(ke,icy) ic = eqc(ieq) it = ct(ic) if (ia .eq. ta(1,it)) then ia2 = ta(2,it) else ia2 = ta(1,it) end if do k = 1, 3 acvect(k) = c(k,ic) - axyz(k,ia) aavect(k) = axyz(k,ia2) - axyz(k,ia) end do call vnorm (aavect,aavect) dt = dot(acvect,aavect) geo = -dt / (ar(ia)*cr(ic)) iv1 = eqv(1,ieq) iv2 = eqv(2,ieq) if (iv1.eq.0 .or. iv2.eq.0) then angle = 2.0d0 * pi else do k = 1, 3 vect1(k) = vxyz(k,iv1) - c(k,ic) vect2(k) = vxyz(k,iv2) - c(k,ic) radial(k,ke) = vxyz(k,iv1) - axyz(k,ia) end do call vnorm (radial(1,ke),radial(1,ke)) call vcross (vect1,aavect,tanv(1,1,ke)) call vnorm (tanv(1,1,ke),tanv(1,1,ke)) call vcross (vect2,aavect,tanv(1,2,ke)) call vnorm (tanv(1,2,ke),tanv(1,2,ke)) angle = vecang(vect1,vect2,aavect,-1.0d0) end if gcurve = gcurve + cr(ic)*angle*geo if (nedge .ne. 1) then if (ke .gt. 1) then angle = vecang(tanv(1,2,ke-1),tanv(1,1,ke), & radial(1,ke),1.0d0) if (angle .lt. 0.0d0) then call cerror ('Negative Angle in MEASFQ') end if pcurve = pcurve + angle end if end if end do if (nedge .gt. 1) then angle = vecang(tanv(1,2,nedge),tanv(1,1,1), & radial(1,1),1.0d0) if (angle .lt. 0.0d0) then call cerror ('Negative Angle in MEASFQ') end if pcurve = pcurve + angle end if end do gauss = 2.0d0*pi*ieuler - pcurve - gcurve areaq = gauss * (ar(ia)**2) volq = areaq * ar(ia) / 3.0d0 return end c c c ######################### c ## ## c ## subroutine measfs ## c ## ## c ######################### c c subroutine measfs (ifs,areas,vols,areasp,volsp) use faces use math implicit none integer k,ifs,ieq integer ic,ic1,ic2 integer it,ia1,ia2 integer iv1,iv2 real*8 areas,vols real*8 areasp,volsp real*8 vecang,phi real*8 dot,d1,d2,w1,w2 real*8 theta1,theta2 real*8 rat,thetaq real*8 cone1,cone2 real*8 term1,term2 real*8 term3 real*8 spin,volt real*8 vect1(3) real*8 vect2(3) real*8 aavect(3) logical cusp c c ieq = fseq(1,ifs) ic = eqc(ieq) it = ct(ic) ia1 = ta(1,it) ia2 = ta(2,it) do k = 1, 3 aavect(k) = axyz(k,ia2) - axyz(k,ia1) end do call vnorm (aavect,aavect) iv1 = eqv(1,ieq) iv2 = eqv(2,ieq) if (iv1.eq.0 .or. iv2.eq.0) then phi = 2.0d0 * pi else do k = 1, 3 vect1(k) = vxyz(k,iv1) - c(k,ic) vect2(k) = vxyz(k,iv2) - c(k,ic) end do phi = vecang(vect1,vect2,aavect,1.0d0) end if do k = 1, 3 vect1(k) = axyz(k,ia1) - t(k,it) vect2(k) = axyz(k,ia2) - t(k,it) end do d1 = -dot(vect1,aavect) d2 = dot(vect2,aavect) theta1 = atan2(d1,tr(it)) theta2 = atan2(d2,tr(it)) c c check for cusps c if (tr(it).lt.pr .and. theta1.gt.0.0d0 & .and. theta2.gt.0.0d0) then cusp = .true. rat = tr(it) / pr if (rat .gt. 1.0d0) rat = 1.0d0 if (rat .lt. -1.0d0) rat = -1.0d0 thetaq = acos(rat) else cusp = .false. thetaq = 0.0d0 areasp = 0.0d0 volsp = 0.0d0 end if term1 = tr(it) * pr * (theta1+theta2) term2 = (pr**2) * (sin(theta1) + sin(theta2)) areas = phi * (term1-term2) if (cusp) then spin = tr(it)*pr*thetaq - pr**2 * sin(thetaq) areasp = 2.0d0 * phi * spin end if c ieq = fseq(1,ifs) ic2 = eqc(ieq) ieq = fseq(2,ifs) ic1 = eqc(ieq) if (ca(ic1) .ne. ia1) then call cerror ('IA1 Inconsistency in MEASFS') end if do k = 1, 3 vect1(k) = c(k,ic1) - axyz(k,ia1) vect2(k) = c(k,ic2) - axyz(k,ia2) end do w1 = dot(vect1,aavect) w2 = -dot(vect2,aavect) cone1 = phi * (w1*cr(ic1)**2)/6.0d0 cone2 = phi * (w2*cr(ic2)**2)/6.0d0 term1 = (tr(it)**2) * pr * (sin(theta1)+sin(theta2)) term2 = sin(theta1)*cos(theta1) + theta1 & + sin(theta2)*cos(theta2) + theta2 term2 = tr(it) * (pr**2) * term2 term3 = sin(theta1)*cos(theta1)**2 + 2.0d0*sin(theta1) & + sin(theta2)*cos(theta2)**2 + 2.0d0*sin(theta2) term3 = (pr**3 / 3.0d0) * term3 volt = (phi/2.0d0) * (term1-term2+term3) vols = volt + cone1 + cone2 if (cusp) then term1 = (tr(it)**2) * pr * sin(thetaq) term2 = sin(thetaq)*cos(thetaq) + thetaq term2 = tr(it) * (pr**2) * term2 term3 = sin(thetaq)*cos(thetaq)**2 + 2.0d0*sin(thetaq) term3 = (pr**3 / 3.0d0) * term3 volsp = phi * (term1-term2+term3) end if return end c c c ######################### c ## ## c ## subroutine measfn ## c ## ## c ######################### c c subroutine measfn (ifn,arean,voln) use faces use math implicit none integer k,ke,je integer ifn,ien integer iv,ia,ip real*8 arean,voln real*8 vecang,triple real*8 defect,simplx real*8 angle(3) real*8 pvv(3,3) real*8 pav(3,3) real*8 planev(3,3) c c do ke = 1, 3 ien = fnen(ke,ifn) iv = env(1,ien) ia = va(iv) ip = vp(iv) do k = 1, 3 pvv(k,ke) = vxyz(k,iv) - p(k,ip) pav(k,ke) = axyz(k,ia) - p(k,ip) end do if (pr .gt. 0.0d0) call vnorm (pvv(1,ke),pvv(1,ke)) end do if (pr .le. 0.0d0) then arean = 0.0d0 else do ke = 1, 3 je = ke + 1 if (je .gt. 3) je = 1 call vcross (pvv(1,ke),pvv(1,je),planev(1,ke)) call vnorm (planev(1,ke),planev(1,ke)) end do do ke = 1, 3 je = ke - 1 if (je .lt. 1) je = 3 angle(ke) = vecang(planev(1,je),planev(1,ke), & pvv(1,ke),-1.0d0) if (angle(ke) .lt. 0.0d0) then call cerror ('Negative Angle in MEASFN') end if end do defect = 2.0d0*pi - (angle(1)+angle(2)+angle(3)) arean = (pr**2) * defect end if simplx = -triple(pav(1,1),pav(1,2),pav(1,3)) / 6.0d0 voln = simplx - arean*pr/3.0d0 return end c c c ######################### c ## ## c ## subroutine projct ## c ## ## c ######################### c c subroutine projct (pnt,unvect,icy,ia,spv,nedge,fail) use faces implicit none integer k,ke,icy,ia integer nedge,ieq,iv real*8 dot,dt,f real*8 polev(3) real*8 pnt(3) real*8 unvect(3) real*8 spv(3,*) logical fail c c fail = .false. nedge = cyneq(icy) do ke = 1, cyneq(icy) c c vertex number (use first vertex of edge) c ieq = cyeq(ke,icy) iv = eqv(1,ieq) if (iv .ne. 0) then c c vector from north pole to vertex c do k = 1, 3 polev(k) = vxyz(k,iv) - pnt(k) end do c c calculate multiplication factor c dt = dot(polev,unvect) if (dt .eq. 0.0d0) then fail = .true. return end if f = (ar(ia)*2) / dt if (f .lt. 1.0d0) then fail = .true. return end if c c projected vertex for this convex edge c do k = 1, 3 spv(k,ke) = pnt(k) + f*polev(k) continue end do end if end do return end c c c ####################### c ## ## c ## function ptincy ## c ## ## c ####################### c c function ptincy (pnt,unvect,icy) use faces implicit none integer k,ke,icy,ieq integer ic,it,iatom integer iaoth,nedge real*8 dot,rotang real*8 totang real*8 unvect(3) real*8 pnt(3) real*8 acvect(3) real*8 cpvect(3) real*8 spv(3,mxcyeq) real*8 equ(3,mxcyeq) logical ptincy,fail c c c check for eaten by neighbor c do ke = 1, cyneq(icy) ieq = cyeq(ke,icy) ic = eqc(ieq) it = ct(ic) iatom = ca(ic) if (ta(1,it) .eq. iatom) then iaoth = ta(2,it) else iaoth = ta(1,it) end if do k = 1, 3 acvect(k) = axyz(k,iaoth) - axyz(k,iatom) cpvect(k) = pnt(k) - c(k,ic) end do if (dot(acvect,cpvect) .ge. 0.0d0) then ptincy = .false. return end if end do if (cyneq(icy) .le. 2) then ptincy = .true. return end if call projct (pnt,unvect,icy,iatom,spv,nedge,fail) if (fail) then ptincy = .true. return end if call equclc (spv,nedge,equ) totang = rotang(equ,nedge,unvect) ptincy = (totang .gt. 0.0d0) return end c c c ######################### c ## ## c ## subroutine equclc ## c ## ## c ######################### c c subroutine equclc (spv,nedge,equ) implicit none integer k,ke,ke2,le integer nedge real*8 anorm,equn real*8 spv(3,*) real*8 equ(3,*) c c c calculate unit vectors along edges c do ke = 1, nedge c c get index of second edge of corner c if (ke .lt. nedge) then ke2 = ke + 1 else ke2 = 1 end if c c unit vector along edge of cycle c do k = 1, 3 equ(k,ke) = spv(k,ke2) - spv(k,ke) end do equn = anorm(equ(1,ke)) c if (equn .le. 0.0d0) call cerror ('Null Edge in Cycle') c c normalize c if (equn .gt. 0.0d0) then do k = 1, 3 equ(k,ke) = equ(k,ke) / equn end do else do k = 1, 3 equ(k,ke) = 0.0d0 end do end if end do c c vectors for null edges come from following or preceding edges c do ke = 1, nedge if (anorm(equ(1,ke)) .le. 0.0d0) then le = ke - 1 if (le .le. 0) le = nedge do k = 1, 3 equ(k,ke) = equ(k,le) end do end if end do return end c c c ####################### c ## ## c ## function rotang ## c ## ## c ####################### c c function rotang (equ,nedge,unvect) implicit none integer ke,nedge real*8 rotang,totang real*8 dot,dt,ang real*8 unvect(3) real*8 crs(3) real*8 equ(3,*) c c totang = 0.0d0 c c sum angles at vertices of cycle c do ke = 1, nedge if (ke .lt. nedge) then dt = dot(equ(1,ke),equ(1,ke+1)) call vcross (equ(1,ke),equ(1,ke+1),crs) else c c closing edge of cycle c dt = dot(equ(1,ke),equ(1,1)) call vcross (equ(1,ke),equ(1,1),crs) end if if (dt .lt. -1.0d0) dt = -1.0d0 if (dt .gt. 1.0d0) dt = 1.0d0 ang = acos(dt) if (dot(crs,unvect) .gt. 0.0d0) ang = -ang c c add to total for cycle c totang = totang + ang end do rotang = totang return end c c c ################################################################ c ## ## c ## subroutine vcross -- find cross product of two vectors ## c ## ## c ################################################################ c c c "vcross" finds the cross product of two vectors c c subroutine vcross (x,y,z) implicit none real*8 x(3),y(3),z(3) c c z(1) = x(2)*y(3) - x(3)*y(2) z(2) = x(3)*y(1) - x(1)*y(3) z(3) = x(1)*y(2) - x(2)*y(1) return end c c c ############################################################# c ## ## c ## function dot -- find the dot product of two vectors ## c ## ## c ############################################################# c c c "dot" finds the dot product of two vectors c c function dot (x,y) implicit none real*8 dot,x(3),y(3) c c dot = x(1)*y(1) + x(2)*y(2) + x(3)*y(3) return end c c c ####################################################### c ## ## c ## function anorm -- find the length of a vector ## c ## ## c ####################################################### c c c "anorm" finds the norm (length) of a vector; used as a c service routine by the Connolly surface area and volume c computation c c function anorm (x) implicit none real*8 anorm,x(3) c c anorm = x(1)**2 + x(2)**2 + x(3)**2 if (anorm .lt. 0.0d0) anorm = 0.0d0 anorm = sqrt(anorm) return end c c c ############################################################### c ## ## c ## subroutine vnorm -- normalize a vector to unit length ## c ## ## c ############################################################### c c c "vnorm" normalizes a vector to unit length; used as a c service routine by the Connolly surface area and volume c computation c c subroutine vnorm (x,xn) implicit none integer k real*8 ax,anorm real*8 x(3),xn(3) c c ax = anorm(x) do k = 1, 3 xn(k) = x(k) / ax end do return end c c c ############################################################### c ## ## c ## function dist2 -- distance squared between two points ## c ## ## c ############################################################### c c c "dist2" finds the distance squared between two points; used c as a service routine by the Connolly surface area and volume c computation c c function dist2 (x,y) implicit none real*8 dist2 real*8 x(3),y(3) c c dist2 = (x(1)-y(1))**2 + (x(2)-y(2))**2 + (x(3)-y(3))**2 return end c c c ################################################################# c ## ## c ## function triple -- form triple product of three vectors ## c ## ## c ################################################################# c c c "triple" finds the triple product of three vectors; used as c a service routine by the Connolly surface area and volume c computation c c function triple (x,y,z) implicit none real*8 triple,dot real*8 x(3),y(3) real*8 z(3),xy(3) c c call vcross (x,y,xy) triple = dot(xy,z) return end c c c ################################################################ c ## ## c ## function vecang -- finds the angle between two vectors ## c ## ## c ################################################################ c c c "vecang" finds the angle between two vectors handed with respect c to a coordinate axis; returns an angle in the range [0,2*pi] c c function vecang (v1,v2,axis,hand) use math implicit none real*8 vecang,hand real*8 angle,dt real*8 a1,a2,a12 real*8 anorm,dot real*8 triple real*8 v1(3),v2(3) real*8 axis(3) c c a1 = anorm(v1) a2 = anorm(v2) dt = dot(v1,v2) a12 = a1 * a2 if (abs(a12) .ne. 0.0d0) dt = dt/a12 if (dt .lt. -1.0d0) dt = -1.0d0 if (dt .gt. 1.0d0) dt = 1.0d0 angle = acos(dt) if (hand*triple(v1,v2,axis) .lt. 0.0d0) then vecang = 2.0d0*pi - angle else vecang = angle end if return end c c c ############################################################### c ## ## c ## subroutine cirpln -- locate circle-plane intersection ## c ## ## c ############################################################### c c c "cirpln" determines the points of intersection between a c specified circle and plane c c subroutine cirpln (circen,cirrad,cirvec,plncen,plnvec, & cinsp,cintp,xpnt1,xpnt2) implicit none integer k real*8 anorm,dot real*8 dcp,dir real*8 ratio,rlen real*8 cirrad real*8 circen(3) real*8 cirvec(3) real*8 plncen(3) real*8 plnvec(3) real*8 xpnt1(3) real*8 xpnt2(3) real*8 cpvect(3) real*8 pnt1(3) real*8 vect1(3) real*8 vect2(3) real*8 uvect1(3) real*8 uvect2(3) logical cinsp logical cintp c c do k = 1, 3 cpvect(k) = plncen(k) - circen(k) end do dcp = dot(cpvect,plnvec) cinsp = (dcp .gt. 0.0d0) call vcross (plnvec,cirvec,vect1) if (anorm(vect1) .gt. 0.0d0) then call vnorm (vect1,uvect1) call vcross (cirvec,uvect1,vect2) if (anorm(vect2) .gt. 0.0d0) then call vnorm (vect2,uvect2) dir = dot(uvect2,plnvec) if (dir .ne. 0.0d0) then ratio = dcp / dir if (abs(ratio) .le. cirrad) then do k = 1, 3 pnt1(k) = circen(k) + ratio*uvect2(k) end do rlen = cirrad**2 - ratio**2 if (rlen .lt. 0.0d0) rlen = 0.0d0 rlen = sqrt(rlen) do k = 1, 3 xpnt1(k) = pnt1(k) - rlen*uvect1(k) xpnt2(k) = pnt1(k) + rlen*uvect1(k) end do cintp = .true. return end if end if end if end if cintp = .false. return end c c c ################################################################# c ## ## c ## subroutine gendot -- find surface points on unit sphere ## c ## ## c ################################################################# c c c "gendot" finds the coordinates of a specified number of surface c points for a sphere with the input radius and coordinate center c c subroutine gendot (ndots,dots,radius,xcenter,ycenter,zcenter) use math implicit none integer i,j,k integer ndots integer nequat integer nvert integer nhoriz real*8 fi,fj real*8 x,y,z,xy real*8 xcenter real*8 ycenter real*8 zcenter real*8 radius real*8 dots(3,*) c c nequat = int(sqrt(pi*dble(ndots))) nvert = int(0.5d0*dble(nequat)) if (nvert .lt. 1) nvert = 1 k = 0 do i = 0, nvert fi = (pi * dble(i)) / dble(nvert) z = cos(fi) xy = sin(fi) nhoriz = int(dble(nequat)*xy) if (nhoriz .lt. 1) nhoriz = 1 do j = 0, nhoriz-1 fj = (2.0d0 * pi * dble(j)) / dble(nhoriz) x = cos(fj) * xy y = sin(fj) * xy k = k + 1 dots(1,k) = x*radius + xcenter dots(2,k) = y*radius + ycenter dots(3,k) = z*radius + zcenter if (k .ge. ndots) goto 10 end do end do 10 continue ndots = k return end c c c ################################################################ c ## ## c ## subroutine cerror -- surface area-volume error message ## c ## ## c ################################################################ c c c "cerror" is the error handling routine for the Connolly c surface area and volume computation c c subroutine cerror (string) use iounit implicit none integer leng,trimtext character*(*) string c c c write out the error message and quit c leng = trimtext (string) write (iout,10) string(1:leng) 10 format (/,' CONNOLLY -- ',a) call fatal end c c c ################################################### c ## COPYRIGHT (C) 1995 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine control -- set information and output types ## c ## ## c ################################################################ c c c "control" gets initial values for parameters that determine c the output style and information level provided by Tinker c c subroutine control use argue use inform use keys use output implicit none integer i,next logical exist character*20 keyword character*240 record character*240 string c c c set default values for information and output variables c digits = 4 verbose = .false. debug = .false. holdup = .false. abort = .false. arcsave = .false. dcdsave = .false. cyclesave = .false. noversion = .false. overwrite = .false. c c check for control parameters on the command line c exist = .false. do i = 1, narg string = arg(i) call upcase (string) if (string(1:2) .eq. '-D') then debug = .true. verbose = .true. else if (string(1:2) .eq. '-V') then verbose = .true. end if end do c c search keywords for various control parameters c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'DIGITS ') then string = record(next:240) read (string,*,err=10,end=10) digits else if (keyword(1:6) .eq. 'DEBUG ') then debug = .true. verbose = .true. else if (keyword(1:8) .eq. 'VERBOSE ') then verbose = .true. else if (keyword(1:11) .eq. 'EXIT-PAUSE ') then holdup = .true. else if (keyword(1:8) .eq. 'ARCHIVE ') then arcsave = .true. dcdsave = .false. else if (keyword(1:12) .eq. 'DCD-ARCHIVE ') then arcsave = .false. dcdsave = .true. else if (keyword(1:10) .eq. 'NOARCHIVE ') then arcsave = .false. dcdsave = .false. cyclesave = .false. else if (keyword(1:11) .eq. 'SAVE-CYCLE ') then dcdsave = .false. cyclesave = .true. else if (keyword(1:10) .eq. 'NOVERSION ') then noversion = .true. else if (keyword(1:10) .eq. 'OVERWRITE ') then overwrite = .true. end if 10 continue end do return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## program correlate -- time correlation of a property ## c ## ## c ############################################################# c c c "correlate" computes the time correlation function of some c user-supplied property from individual snapshot frames taken c from a molecular dynamics or other trajectory c c program correlate use ascii use atoms use files use inform use iounit implicit none integer maxsite,maxblock parameter (maxsite=1000) parameter (maxblock=1000) integer i,j,k,m integer n1,n2,dt integer first,last,mode integer start,stop,step integer nframe,nblock,maxgap integer blksize,blkgap,blkdiff integer, allocatable :: t1(:) integer, allocatable :: t2(:) integer, allocatable :: icorr(:) real*8 value,property real*8, allocatable :: vcorr(:) real*8, allocatable :: x1(:,:) real*8, allocatable :: y1(:,:) real*8, allocatable :: z1(:,:) real*8, allocatable :: x2(:,:) real*8, allocatable :: y2(:,:) real*8, allocatable :: z2(:,:) logical exist,query,normal character*240 string c c c determine the desired type of time correlation function c call initial mode = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) mode query = .false. end if 10 continue if (query) then write (iout,20) 20 format (/,' The Tinker Correlation Function Utility Can :', & //,4x,'(1) Find Velocity Autocorrelation Function', & /,4x,'(2) Find Superposition Correlation Function') do while (mode.lt.1 .or. mode.gt.2) mode = 0 write (iout,30) 30 format (/,' Enter the Number of the Desired Choice : ',$) read (input,40,err=50,end=50) mode 40 format (i10) 50 continue end do end if c c get the base name of user specified input structures c call nextarg (filename,exist) if (.not. exist) then write (iout,60) 60 format (/,' Enter Base Name of Coordinate Cycle Files : ',$) read (input,70) filename 70 format (a240) end if call basefile (filename) c c set first and last snapshot frames and step increment c first = 0 last = 0 step = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=80,end=80) first query = .false. end if call nextarg (string,exist) if (exist) read (string,*,err=80,end=80) last call nextarg (string,exist) if (exist) read (string,*,err=80,end=80) step 80 continue if (query) then write (iout,90) 90 format (/,' Numbers of First & Last File and Step', & ' Increment : ',$) read (input,100) string 100 format (a240) read (string,*,err=110,end=110) first,last,step 110 continue end if if (last .eq. 0) last = first if (step .eq. 0) step = 1 c c set the maximum frame separation to be used for correlation c maxgap = last - first query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=120,end=120) maxgap query = .false. end if 120 continue if (query) then write (iout,130) 130 format (/,' Maximum Frame Separation to be Used in', & ' Correlation [ALL] : ',$) read (input,140) string 140 format (a240) read (string,*,err=150,end=150) maxgap 150 continue end if if (maxgap .eq. 0) maxgap = last - first c c get the number of frame blocks from the total frames c nframe = 1 + (last-first)/step nblock = 1 + (nframe-1)/maxblock blksize = maxblock * step blkgap = 1 + (maxgap-1)/blksize write (iout,160) nblock,min(nframe,maxblock) 160 format (/,' Correlation Function Computed using',i5, & ' Blocks of',i6,' Frames') c c perform dynamic allocation of some local arrays c allocate (t1(maxblock)) allocate (t2(maxblock)) allocate (icorr(0:maxgap)) allocate (vcorr(0:maxgap)) allocate (x1(maxsite,maxblock)) allocate (y1(maxsite,maxblock)) allocate (z1(maxsite,maxblock)) allocate (x2(maxsite,maxblock)) allocate (y2(maxsite,maxblock)) allocate (z2(maxsite,maxblock)) c c zero out the time correlation function cumulative values c do i = 0, maxgap icorr(i) = 0 vcorr(i) = 0.0d0 end do c c cycle over all pairs of snapshot frame blocks c do i = 1, nblock start = first + (i-1) * blksize stop = start + blksize - step stop = min(last,stop) call readblk (mode,start,stop,step,n1,t1,x1,y1,z1) write (iout,170) i 170 format (/,3x,'Correlation within Frame Block : ',i8) c c compute time correlation for frames within single block c do k = 1, n1 do m = k, n1 dt = t1(m) - t1(k) if (dt .le. maxgap) then value = property (mode,k,x1,y1,z1,m,x1,y1,z1) icorr(dt) = icorr(dt) + 1 vcorr(dt) = vcorr(dt) + value end if end do end do c c compute time correlation for frames between two blocks c do j = i+1, min(i+blkgap,nblock) start = first + (j-1) * blksize stop = start + blksize - step stop = min(last,stop) blkdiff = (j-i) * maxblock call readblk (mode,start,stop,step,n2,t2,x2,y2,z2) write (iout,180) i,j 180 format (3x,'Correlation between Frame Blocks : ',2i8) do k = 1, n1 do m = 1, n2 dt = t2(m) - t1(k) + blkdiff if (dt .le. maxgap) then value = property (mode,k,x1,y1,z1,m,x2,y2,z2) icorr(dt) = icorr(dt) + 1 vcorr(dt) = vcorr(dt) + value end if end do end do end do end do c c compute the average correlation function values c do i = 0, maxgap if (icorr(i) .ne. 0) vcorr(i) = vcorr(i)/dble(icorr(i)) end do normal = .false. if (vcorr(0) .ne. 0.0d0) normal = .true. c c print the final values of the correlation function c if (normal) then write (iout,190) 190 format (/,3x,'Separation',7x,'Samples',8x,'Average Value', & 7x,'Normalized',/) do i = 0, maxgap if (icorr(i) .ne. 0) then write (iout,200) i*step,icorr(i),vcorr(i), & vcorr(i)/vcorr(0) 200 format (i9,6x,i10,6x,2f17.6) end if end do else write (iout,210) 210 format (/,3x,'Separation',7x,'Samples',8x,'Average Value',/) do i = 0, maxgap if (icorr(i) .ne. 0) then write (iout,220) i*step,icorr(i),vcorr(i) 220 format (i9,6x,i10,6x,f17.6) end if end do end if c c perform deallocation of some local arrays c deallocate (t1) deallocate (t2) deallocate (icorr) deallocate (vcorr) deallocate (x1) deallocate (y1) deallocate (z1) deallocate (x2) deallocate (y2) deallocate (z2) c c perform any final tasks before program exit c call final end c c c ############################################################### c ## ## c ## subroutine readblk -- read a block of snapshot frames ## c ## ## c ############################################################### c c c "readblk" reads in a set of snapshot frames and transfers c the values to internal arrays for use in the computation c of time correlation functions c c subroutine readblk (mode,start,stop,step,nb,tb,xb,yb,zb) use atomid use atoms use files use iounit implicit none integer maxsite parameter (maxsite=1000) integer i,k,ixyz integer nt,nb,mode integer start,stop integer next,label integer step,lext integer freeunit integer tb(*) real*8 xb(maxsite,*) real*8 yb(maxsite,*) real*8 zb(maxsite,*) logical exist character*7 ext character*240 record character*240 string character*240 xyzfile c c c initialize the number of files and the numeral size c nt = 0 nb = 0 lext = 3 c c cycle over all snapshot frames in the block of files c do i = start, stop, step nt = nt + 1 call numeral (i,ext,lext) if (mode .eq. 1) then xyzfile = filename(1:leng)//'.'//ext(1:lext)//'v' else if (mode .eq. 2) then xyzfile = filename(1:leng)//'.'//ext(1:lext) end if inquire (file=xyzfile,exist=exist) c c add file to the current block and get number of atoms c if (exist) then nb = nb + 1 tb(nb) = nt ixyz = freeunit () open (unit=ixyz,file=xyzfile,status='old') read (ixyz,10) record 10 format (a240) read (record,*) n c c check for too many correlation sites in the frame c if (n .gt. maxsite) then write (iout,20) 20 format (/,' READBLK -- Too many Correlation Sites;', & ' Increase MAXSITE') call fatal end if c c read the frame in the Tinker-generated coordinate format; c this is fast, but assumes the fixed format shown below c c do k = 1, n c read (ixyz,30) name(k),xb(k,nb),yb(k,nb),zb(k,nb) c 30 format (8x,a3,3f12.6) c end do c c alternatively, get each frame from a free formated file; c this is slow, but correctly handles any valid Tinker file c do k = 1, n next = 1 read (ixyz,30) record 30 format (a240) read (record,*) label call getword (record,name(k),next) string = record(next:240) read (string,*) xb(k,nb),yb(k,nb),zb(k,nb) end do close (unit=ixyz) end if end do return end c c c ################################################################# c ## ## c ## function property -- compute correlation property value ## c ## ## c ################################################################# c c c "property" takes two input snapshot frames and computes the c value of the property for which the correlation function is c being accumulated c c this version of "property" finds the velocity autocorrelation c or the rms fit as a function of time, and is merely provided c as an example; the user will need to write a similar custom c function to compute other properties to be correlated c c function property (mode,i,xi,yi,zi,k,xk,yk,zk) use atoms implicit none integer maxsite parameter (maxsite=1000) integer i,j,k,mode real*8 property,value real*8, allocatable :: x1(:) real*8, allocatable :: y1(:) real*8, allocatable :: z1(:) real*8, allocatable :: x2(:) real*8, allocatable :: y2(:) real*8, allocatable :: z2(:) real*8 xi(maxsite,*) real*8 yi(maxsite,*) real*8 zi(maxsite,*) real*8 xk(maxsite,*) real*8 yk(maxsite,*) real*8 zk(maxsite,*) c c c perform dynamic allocation of some local arrays c allocate (x1(maxsite)) allocate (y1(maxsite)) allocate (z1(maxsite)) allocate (x2(maxsite)) allocate (y2(maxsite)) allocate (z2(maxsite)) c c transfer the input trajectory frames to local vectors c value = 0.0d0 do j = 1, n x1(j) = xi(j,i) y1(j) = yi(j,i) z1(j) = zi(j,i) x2(j) = xk(j,k) y2(j) = yk(j,k) z2(j) = zk(j,k) end do c c sample code to find the velocity autocorrelation function c if (mode .eq. 1) then do j = 1, n value = value + x1(j)*x2(j) + y1(j)*y2(j) + z1(j)*z2(j) end do end if c c sample code to find the rms deviation upon superposition c if (mode .eq. 2) then call impose (n,x1,y1,z1,n,x2,y2,z2,value) end if c c perform deallocation of some local arrays c deallocate (x1) deallocate (y1) deallocate (z1) deallocate (x2) deallocate (y2) deallocate (z2) c c set property value to be returned for this frame pair c property = value return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## module couple -- atom neighbor connectivity lists ## c ## ## c ############################################################ c c c n12 number of atoms directly bonded to each atom c n13 number of atoms in a 1-3 relation to each atom c n14 number of atoms in a 1-4 relation to each atom c n15 number of atoms in a 1-5 relation to each atom c i12 atom numbers of atoms 1-2 connected to each atom c i13 atom numbers of atoms 1-3 connected to each atom c i14 atom numbers of atoms 1-4 connected to each atom c i15 atom numbers of atoms 1-5 connected to each atom c c module couple use sizes implicit none integer n12(maxatm) integer, allocatable :: n13(:) integer, allocatable :: n14(:) integer, allocatable :: n15(:) integer i12(maxval,maxatm) integer, allocatable :: i13(:,:) integer, allocatable :: i14(:,:) integer, allocatable :: i15(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 2020 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## program critical -- stationary point by least squares ## c ## ## c ############################################################### c c c "critical" finds a stationary point for a molecular system via c least squares minimization of the atomic gradient components c c program critical use sizes use atoms use files use freeze use inform use iounit use keys use minima use usage implicit none integer i,j,k,next integer nvar,nrsd integer imin,freeunit real*8 epot,grdmin real*8 gnorm,grms real*8, allocatable :: xx(:) real*8, allocatable :: xlo(:) real*8, allocatable :: xhi(:) real*8, allocatable :: rsd(:) real*8, allocatable :: grd(:) real*8, allocatable :: derivs(:,:) real*8, allocatable :: fjac(:,:) logical exist character*20 keyword character*240 minfile character*240 record character*240 string external critical1 external critsave c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c search the keywords for output frequency parameters c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:120) if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=10,end=10) iprint else if (keyword(1:9) .eq. 'WRITEOUT ') then read (string,*,err=10,end=10) iwrite end if 10 continue end do c c get termination criterion as RMS gradient per atom c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=20,end=20) grdmin 20 continue if (grdmin .le. 0.0d0) then write (iout,30) 30 format (/,' Enter Residual Gradient Convergence Criterion', & ' [1.0] : ',$) read (input,40) grdmin 40 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 1.0d0 c c write out a copy of coordinates for later update c imin = freeunit () minfile = filename(1:leng)//'.xyz' call version (minfile,'new') open (unit=imin,file=minfile,status='new') call prtxyz (imin) close (unit=imin) outfile = minfile c c perform dynamic allocation of some local arrays c allocate (xx(3*n)) allocate (derivs(3,n)) c c set active atom coordinates as optimization variables c nvar = 0 do i = 1, n k = iuse(i) nvar = nvar + 1 xx(nvar) = x(k) nvar = nvar + 1 xx(nvar) = y(k) nvar = nvar + 1 xx(nvar) = z(k) end do c c perform dynamic allocation of some local arrays c allocate (xlo(3*n)) allocate (xhi(3*n)) allocate (rsd(3*n)) allocate (grd(3*n)) allocate (fjac(3*n,3*n)) c c make the call to the least squares optimization routine c maxiter = 10000 nrsd = nvar do i = 1, nvar xlo(i) = -1000000.0d0 xhi(i) = 1000000.0d0 end do call square (nvar,nrsd,xlo,xhi,xx,rsd,grd,fjac, & grdmin,critical1,critsave) c c perform deallocation of some local arrays c deallocate (xlo) deallocate (xhi) deallocate (rsd) deallocate (grd) deallocate (fjac) c c unpack the final coordinates for active atoms c nvar = 0 do i = 1, n k = iuse(i) nvar = nvar + 1 x(i) = xx(nvar) nvar = nvar + 1 y(i) = xx(nvar) nvar = nvar + 1 z(i) = xx(nvar) end do c c compute the final function and RMS gradient values c call gradient (epot,derivs) if (use_rattle) call shake2 (derivs) gnorm = 0.0d0 do i = 1, nuse k = iuse(i) do j = 1, 3 gnorm = gnorm + derivs(j,k)**2 end do 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 (digits .ge. 8) then if (grms .gt. 1.0d-8) then write (iout,50) epot,grms,gnorm 50 format (/,' Final Function Value :',2x,f20.8, & /,' Final RMS Gradient :',4x,f20.8, & /,' Final Gradient Norm :',3x,f20.8) else write (iout,60) epot,grms,gnorm 60 format (/,' Final Function Value :',2x,f20.8, & /,' Final RMS Gradient :',4x,d20.8, & /,' Final Gradient Norm :',3x,d20.8) end if else if (digits .ge. 6) then if (grms .gt. 1.0d-6) then write (iout,70) epot,grms,gnorm 70 format (/,' Final Function Value :',2x,f18.6, & /,' Final RMS Gradient :',4x,f18.6, & /,' Final Gradient Norm :',3x,f18.6) else write (iout,80) epot,grms,gnorm 80 format (/,' Final Function Value :',2x,f18.6, & /,' Final RMS Gradient :',4x,d18.6, & /,' Final Gradient Norm :',3x,d18.6) end if else if (grms .gt. 1.0d-4) then write (iout,90) epot,grms,gnorm 90 format (/,' Final Function Value :',2x,f16.4, & /,' Final RMS Gradient :',4x,f16.4, & /,' Final Gradient Norm :',3x,f16.4) else write (iout,100) epot,grms,gnorm 100 format (/,' Final Function Value :',2x,f16.4, & /,' Final RMS Gradient :',4x,d16.4, & /,' Final Gradient Norm :',3x,d16.4) end if end if c c write the final coordinates into a file c imin = freeunit () open (unit=imin,file=minfile,status='old') rewind (unit=imin) call prtxyz (imin) close (unit=imin) c c perform any final tasks before program exit c call final end c c c ################################################################# c ## ## c ## subroutine critical1 -- least squares gradient residual ## c ## ## c ################################################################# c c c "trudge1" is a service routine to compute gradient components c for a least squares minimization to a stationary point c c subroutine critical1 (nvar,nrsd,xx,rsd) use sizes use atoms use freeze use usage implicit none integer i,k integer nvar integer nrsd real*8 epot real*8 xx(*) real*8 rsd(*) real*8, allocatable :: derivs(:,:) c c c convert optimization parameters to atomic coordinates c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 x(k) = xx(nvar) nvar = nvar + 1 y(k) = xx(nvar) nvar = nvar + 1 z(k) = xx(nvar) end do c c adjust atomic coordinates to satisfy distance constraints c if (use_rattle) call shake (x,y,z) c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute energy and gradient for the current structure c call gradient (epot,derivs) c c adjust gradient to remove components along constraints c if (use_rattle) call shake2 (derivs) c c store the gradient components as the residual vector c nvar = 0 do i = 1, n k = iuse(i) nvar = nvar + 1 xx(nvar) = x(k) rsd(nvar) = derivs(1,k) nvar = nvar + 1 xx(nvar) = y(k) rsd(nvar) = derivs(2,k) nvar = nvar + 1 xx(nvar) = z(k) rsd(nvar) = derivs(3,k) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ############################################################## c ## ## c ## subroutine critsave -- critical point output routine ## c ## ## c ############################################################## c c subroutine critsave (niter,nrsd,xx,gs,rsd) use files use iounit use output implicit none integer niter,nrsd integer iopt,iend integer lext integer freeunit real*8 xx(*) real*8 gs(*) real*8 rsd(*) logical exist character*7 ext character*240 optfile character*240 endfile c c c get name of archive or intermediate coordinates file c iopt = freeunit () if (cyclesave) then if (archive) then optfile = filename(1:leng) call suffix (optfile,'arc','old') inquire (file=optfile,exist=exist) if (exist) then call openend (iopt,optfile) else open (unit=iopt,file=optfile,status='new') end if else lext = 3 call numeral (niter,ext,lext) optfile = filename(1:leng)//'.'//ext(1:lext) call version (optfile,'new') open (unit=iopt,file=optfile,status='new') end if else optfile = outfile call version (optfile,'old') open (unit=iopt,file=optfile,status='old') rewind (unit=iopt) end if c c update intermediate file with desired coordinate type c call prtxyz (iopt) close (unit=iopt) c c test for requested termination of the optimization c endfile = 'tinker.end' inquire (file=endfile,exist=exist) if (.not. exist) then endfile = filename(1:leng)//'.end' inquire (file=endfile,exist=exist) if (exist) then iend = freeunit () open (unit=iend,file=endfile,status='old') close (unit=iend,status='delete') end if end if if (exist) then write (iout,10) 10 format (/,' CRITSAVE -- Optimization Calculation Ending', & ' due to User Request') call fatal end if return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## program crystal -- fractional coordinate manipulations ## c ## ## c ################################################################ c c c "crystal" is a utility which converts between fractional and c Cartesian coordinates, and can generate full unit cells from c asymmetric units c c program crystal use atoms use bound use boxes use iounit use files implicit none integer maxspace parameter (maxspace=92) integer i,ixyz,mode integer na,nb,nc integer next,freeunit real*8 boxmax logical exist,query character*1 answer character*8 sgroup(maxspace) character*240 xyzfile character*240 record character*240 string data sgroup / 'P1 ', 'P2 ', 'P1(-) ', 'P21 ', & 'C2 ', 'Pm ', 'Pc ', 'Cm ', & 'Cc ', 'P2/m ', 'P21/m ', 'C2/m ', & 'P2/c ', 'P21/c ', 'P21/n ', 'P21/a ', & 'C2/c ', 'P21212 ', 'P212121 ', 'C2221 ', & 'Pca21 ', 'Pmn21 ', 'Pna21 ', 'Pnn2 ', & 'Pn21a ', 'Cmc21 ', 'Aba2 ', 'Fdd2 ', & 'Iba2 ', 'Pnna ', 'Pmna ', 'Pcca ', & 'Pbam ', 'Pccn ', 'Pbcm ', 'Pnnm ', & 'Pmmn ', 'Pbcn ', 'Pbca ', 'Pnma ', & 'Cmcm ', 'Cmca ', 'Ccca ', 'Fddd ', & 'Ibam ', 'Ibca ', 'P41 ', 'P43 ', & 'I4(-) ', 'P4/n ', 'P42/n ', 'I4/m ', & 'I41/a ', 'P41212 ', 'P43212 ', 'P4(-)21m', & 'P4(-)21c', 'P4(-)m2 ', 'I4(-)2d ', 'I41/amd ', & 'P31 ', 'P32 ', 'R3 ', 'P3(-) ', & 'R3(-) ', 'P3121 ', 'P3221 ', 'R3m ', & 'R3c ', 'R3(-)m ', 'P3(-)c1 ', 'R3(-)c ', & 'P61 ', 'P65 ', 'P63 ', 'P63/m ', & 'P63/mmc ', 'Pa3(-) ', 'P43m ', 'I4(-)3m ', & 'P4(-)3n ', 'I4(-)3d ', 'Pm3(-)m ', 'Pn3(-)n ', & 'Pm3(-)n ', 'Pn3(-)m ', 'Fm3(-)m ', 'Fm3(-)c ', & 'Fd3(-)m ', 'Fm3(-)c ', 'Im3(-)m ', 'Im3(-)d '/ c c c get and read the Cartesian coordinates file c call initial call getxyz c c find out which unit cell manipulation to perform c mode = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) mode if (mode.ge.1 .and. mode.le.5) query = .false. end if 10 continue if (query) then write (iout,20) 20 format (/,' The Tinker Crystal Structure Utility Can :', & //,4x,'(1) Convert Fractional to Cartesian Coords', & /,4x,'(2) Convert Cartesian to Fractional Coords', & /,4x,'(3) Move Any Stray Molecules into Unit Cell', & /,4x,'(4) Make a Unit Cell from an Asymmetric Unit', & /,4x,'(5) Make a Big Block from a Single Unit Cell') do while (mode.lt.1 .or. mode.gt.5) mode = 0 write (iout,30) 30 format (/,' Enter the Number of the Desired Choice : ',$) read (input,40,err=50,end=50) mode 40 format (i10) 50 continue end do end if c c get any cell dimensions found in the keyword list c call unitcell c c determine the space group if it will be needed later c if (mode .eq. 4) then do i = 1, maxspace if (spacegrp .eq. sgroup(i)) goto 120 end do 60 continue write (iout,70) (sgroup(i),i=1,32) 70 format (/,' Available Crystallographic Space Groups :',/, & /,3x,'(1) ',a8,5x,'(2) ',a8,5x,'(3) ',a8, & 5x,'(4) ',a8, & /,3x,'(5) ',a8,5x,'(6) ',a8,5x,'(7) ',a8, & 5x,'(8) ',a8, & /,3x,'(9) ',a8,4x,'(10) ',a8,4x,'(11) ',a8, & 4x,'(12) ',a8, & /,2x,'(13) ',a8,4x,'(14) ',a8,4x,'(15) ',a8, & 4x,'(16) ',a8, & /,2x,'(17) ',a8,4x,'(18) ',a8,4x,'(19) ',a8, & 4x,'(20) ',a8, & /,2x,'(21) ',a8,4x,'(22) ',a8,4x,'(23) ',a8, & 4x,'(24) ',a8, & /,2x,'(25) ',a8,4x,'(26) ',a8,4x,'(27) ',a8, & 4x,'(28) ',a8, & /,2x,'(29) ',a8,4x,'(30) ',a8,4x,'(31) ',a8, & 4x,'(32) ',a8) write (iout,80) (sgroup(i),i=33,64) 80 format (2x,'(33) ',a8,4x,'(34) ',a8,4x,'(35) ',a8, & 4x,'(36) ',a8, & /,2x,'(37) ',a8,4x,'(38) ',a8,4x,'(39) ',a8, & 4x,'(40) ',a8, & /,2x,'(41) ',a8,4x,'(42) ',a8,4x,'(43) ',a8, & 4x,'(44) ',a8, & /,2x,'(45) ',a8,4x,'(46) ',a8,4x,'(47) ',a8, & 4x,'(48) ',a8, & /,2x,'(49) ',a8,4x,'(50) ',a8,4x,'(51) ',a8, & 4x,'(52) ',a8, & /,2x,'(53) ',a8,4x,'(54) ',a8,4x,'(55) ',a8, & 4x,'(56) ',a8, & /,2x,'(57) ',a8,4x,'(58) ',a8,4x,'(59) ',a8, & 4x,'(60) ',a8, & /,2x,'(61) ',a8,4x,'(62) ',a8,4x,'(63) ',a8, & 4x,'(64) ',a8) write (iout,90) (sgroup(i),i=65,maxspace) 90 format (2x,'(76) ',a8,4x,'(66) ',a8,4x,'(67) ',a8, & 4x,'(68) ',a8, & /,2x,'(69) ',a8,4x,'(70) ',a8,4x,'(71) ',a8, & 4x,'(72) ',a8, & /,2x,'(73) ',a8,4x,'(74) ',a8,4x,'(75) ',a8, & 4x,'(76) ',a8, & /,2x,'(77) ',a8,4x,'(78) ',a8,4x,'(79) ',a8, & 4x,'(80) ',a8, & /,2x,'(81) ',a8,4x,'(82) ',a8,4x,'(83) ',a8, & 4x,'(84) ',a8, & /,2x,'(85) ',a8,4x,'(86) ',a8,4x,'(87) ',a8, & 4x,'(88) ',a8, & /,2x,'(89) ',a8,4x,'(90) ',a8,4x,'(91) ',a8, & 4x,'(92) ',a8) write (iout,100) 100 format (/,' Enter the Number of the Desired Choice : ',$) read (input,110) i 110 format (i10) if (i.lt.1 .or. i.gt.maxspace) goto 60 spacegrp = sgroup(i) 120 continue end if c c if not in keyfile, get the unit cell axis lengths c do while (xbox .eq. 0.0d0) write (iout,130) 130 format (/,' Enter Unit Cell Axis Lengths : ',$) read (input,140) record 140 format (a240) read (record,*,err=150,end=150) xbox,ybox,zbox 150 continue boxmax = max(xbox,ybox,zbox) if (boxmax .ne. 0.0d0) use_bounds = .true. if (xbox .eq. 0.0d0) xbox = boxmax if (ybox .eq. 0.0d0) ybox = boxmax if (zbox .eq. 0.0d0) zbox = boxmax end do c c if not in keyfile, get the unit cell angle values c do while (alpha .eq. 0.0d0) write (iout,160) 160 format (/,' Enter Unit Cell Axis Angles : ',$) read (input,170) record 170 format (a240) read (record,*,err=180,end=180) alpha,beta,gamma 180 continue if (alpha .eq. 0.0d0) alpha = 90.0d0 if (beta .eq. 0.0d0) beta = alpha if (gamma .eq. 0.0d0) gamma = alpha if (alpha.eq.90.0d0 .and. beta.eq.90.0d0 & .and. gamma.eq.90.0d0) then orthogonal = .true. else if (alpha.eq.90.0d0 .and. gamma.eq.90.0d0) then monoclinic = .true. else triclinic = .true. end if end do c c find constants for coordinate interconversion c call lattice c c print out the initial cell dimensions to be used c write (iout,190) xbox,ybox,zbox,alpha,beta,gamma 190 format (/,' Unit Cell Dimensions : a =',f12.4, & /,' b =',f12.4, & /,' c =',f12.4, & /,' Alpha =',f12.4, & /,' Beta =',f12.4, & /,' Gamma =',f12.4) c c convert Cartesian to fractional coordinates c if (mode.ne.1 .and. mode.ne.3) then do i = 1, n z(i) = (z(i)/gamma_term) / zbox y(i) = ((y(i)-z(i)*zbox*beta_term)/gamma_sin) / ybox x(i) = (x(i)-y(i)*ybox*gamma_cos-z(i)*zbox*beta_cos) / xbox end do end if c c apply the appropriate space group symmetry operators c if (mode .eq. 4) then write (iout,200) spacegrp 200 format (/,' Space Group Symbol :',8x,a8) call symmetry (spacegrp) end if c c replicate the unit cell to make a block of unit cells c if (mode .eq. 5) then na = 0 nb = 0 nc = 0 write (iout,210) 210 format (/,' Enter Number of Replicates along a-, b- and', & ' c-Axes [1 1 1] : ',$) read (input,220) record 220 format (a240) read (record,*,err=230,end=230) na,nb,nc 230 continue if (na .eq. 0) na = 1 if (nb .eq. 0) nb = na if (nc .eq. 0) nc = na if (na*nb*nc*n .gt. maxatm) then write (iout,240) maxatm 240 format (/,' CRYSTAL -- The Maximum of',i9,' Atoms', & ' has been Exceeded') call fatal end if call bigblock (na,nb,nc) write (iout,250) na,nb,nc,xbox,ybox,zbox 250 format (/,' Dimensions of the',i3,' x',i3,' x',i3, & ' Cell Block :', & //,' New Cell Dimensions : a =',f10.4, & /,' b =',f10.4, & /,' c =',f10.4) end if c c convert fractional to Cartesian coordinates c if (mode.ne.2 .and. mode.ne.3) then do i = 1, n x(i) = x(i)*xbox + y(i)*ybox*gamma_cos + z(i)*zbox*beta_cos y(i) = y(i)*ybox*gamma_sin + z(i)*zbox*beta_term z(i) = z(i)*zbox*gamma_term end do end if c c merge fragments to form complete connected molecules c if (mode .eq. 4) then answer = ' ' call nextarg (answer,exist) if (.not. exist) then write (iout,260) 260 format (/,' Attempt to Merge Fragments to Form Full', & ' Molecules [N] : ',$) read (input,270) record 270 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') call molmerge end if c c translate any stray molecules back into the unit cell c if (mode .eq. 3) then call field call katom call molecule call bounds else if (mode .eq. 4) then answer = ' ' call nextarg (answer,exist) if (.not. exist) then write (iout,280) 280 format (/,' Move Any Stray Molecules into Unit Cell', & ' [N] : ',$) read (input,290) record 290 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') then call field call katom call molecule call bounds end if end if c c optionally move unit cell center to coordinate origin c if (mode .eq. 4) then answer = ' ' call nextarg (answer,exist) if (.not. exist) then write (iout,300) 300 format (/,' Locate Center of Unit Cell at Coordinate', & ' Origin [N] : ',$) read (input,310) record 310 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') then do i = 1, n z(i) = (z(i)/gamma_term) / zbox y(i) = ((y(i)-z(i)*zbox*beta_term)/gamma_sin) / ybox x(i) = (x(i)-y(i)*ybox*gamma_cos-z(i)*zbox*beta_cos) & / xbox end do do i = 1, n x(i) = x(i) - 0.5d0 y(i) = y(i) - 0.5d0 z(i) = z(i) - 0.5d0 end do do i = 1, n x(i) = x(i)*xbox + y(i)*ybox*gamma_cos & + z(i)*zbox*beta_cos y(i) = y(i)*ybox*gamma_sin + z(i)*zbox*beta_term z(i) = z(i)*zbox*gamma_term end do end if end if c c write out the new coordinates to a file c ixyz = freeunit () if (mode .eq. 2) then xyzfile = filename(1:leng)//'.frac' call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') else xyzfile = filename(1:leng)//'.xyz' call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') end if call prtxyz (ixyz) close (unit=ixyz) c c perform any final tasks before program exit c call final end c c c ################################################################# c ## ## c ## subroutine molmerge -- connect fragments into molecules ## c ## ## c ################################################################# c c c "molmerge" connects fragments and removes duplicate atoms c during generation of a unit cell from an asymmetric unit c c subroutine molmerge use atomid use atoms use couple use molcul implicit none integer i,j,k,m,h integer im,km,in,kn real*8 r,eps real*8 xi,yi,zi real*8 xr,yr,zr logical ih,kh logical merge,join logical, allocatable :: omit(:) logical, allocatable :: hydro(:) c c c parse the system to find molecules and fragments c call molecule c c perform dynamic allocation of some local arrays c allocate (omit(n)) c c zero out the list of atoms to be deleted c do i = 1, n omit(i) = .false. end do c c first pass tests all pairs for duplicate atoms c eps = 0.05d0 do i = 1, n-1 xi = x(i) yi = y(i) zi = z(i) do k = i+1, n km = molcule(k) xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) merge = .false. if (r .lt. eps) merge = .true. c c translate molecular fragment to the closest image c if (merge) then xr = xr - x(k) + xi yr = yr - y(k) + yi zr = zr - z(k) + zi do j = imol(1,km), imol(2,km) m = kmol(j) x(m) = x(m) + xr y(m) = y(m) + yr z(m) = z(m) + zr end do c c connections between partially duplicated fragments c omit(k) = .true. do j = 1, n12(k) m = i12(j,k) join = .true. do h = 1, n12(m) if (i12(h,m) .eq. i) join = .false. end do if (join) then n12(m) = n12(m) + 1 i12(n12(m),m) = i end if join = .true. do h = 1, n12(i) if (i12(h,i) .eq. m) join = .false. end do if (join) then n12(i) = n12(i) + 1 i12(n12(i),i) = m end if end do end if end do end do c c delete any duplicated atoms identical by symmetry c j = n do i = j, 1, -1 if (omit(i)) call delete (i) end do c c perform deallocation of some local arrays c deallocate (omit) c c parse the system to find molecules and fragments c call molecule c c perform dynamic allocation of some local arrays c allocate (hydro(n)) c c find hydrogen atoms for use in connectivity assignment c do i = 1, n hydro(i) = .false. if (atomic(i) .eq. 1) hydro(i) = .true. if (name(i)(1:1) .eq. 'H') hydro(i) = .true. end do c c second pass tests all pairs for atoms to be bonded c do i = 1, n-1 im = molcule(i) in = n12(i) ih = hydro(i) xi = x(i) yi = y(i) zi = z(i) do k = i+1, n km = molcule(k) kn = n12(k) kh = hydro(k) xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) merge = .false. if (im .ne. km) then eps = 2.0d0 if (ih .or. kh) eps = 1.6d0 if (ih .and. kh) eps = 0.0d0 if (r .lt. eps) merge = .true. end if c c translate molecular fragment to the closest image c if (merge) then xr = xr - x(k) + xi yr = yr - y(k) + yi zr = zr - z(k) + zi do j = imol(1,km), imol(2,km) m = kmol(j) x(m) = x(m) + xr y(m) = y(m) + yr z(m) = z(m) + zr end do c c connection between bonded atoms in different fragments c n12(i) = n12(i) + 1 i12(n12(i),i) = k n12(k) = n12(k) + 1 i12(n12(k),k) = i end if end do end do c c perform deallocation of some local arrays c deallocate (hydro) c c sort the connected atom lists into ascending order c do i = 1, n call sort (n12(i),i12(1,i)) end do return end c c c ############################################################## c ## ## c ## subroutine cellatom -- add new atom to the unit cell ## c ## ## c ############################################################## c c c "cellatom" completes the addition of a symmetry related atom c to a unit cell by updating the atom type and attachment arrays c c subroutine cellatom (jj,j) use atomid use atoms use couple implicit none integer i,j,jj,delta c c c attachments of replicated atom are analogous to base atom c delta = jj - j n12(jj) = n12(j) do i = 1, n12(j) i12(i,jj) = i12(i,j) + delta end do type(jj) = type(j) name(jj) = name(j) return end c c c ############################################################# c ## ## c ## subroutine bigblock -- create a block of unit cells ## c ## ## c ############################################################# c c c "bigblock" replicates the coordinates of a single unit cell c to give a larger unit cell as a block of repeated units c c subroutine bigblock (na,nb,nc) use atoms use boxes implicit none integer i,j,k integer ii,jj,nsym integer na,nb,nc real*8, allocatable :: trans(:,:) c c c perform dynamic allocation of some local arrays c nsym = na * nb * nc allocate (trans(3,nsym)) c c construct translation offsets for the replicated cells c nsym = 0 do i = (1-na)/2, na/2 do j = (1-nb)/2, nb/2 do k = (1-nc)/2, nc/2 nsym = nsym + 1 trans(1,nsym) = i trans(2,nsym) = j trans(3,nsym) = k end do end do end do c c put the original cell at the top of the replica list c do i = 1, nsym if (trans(1,i).eq.0 .and. trans(2,i).eq.0 & .and. trans(3,i).eq.0) k = i end do do i = k, 2, -1 trans(1,i) = trans(1,i-1) trans(2,i) = trans(2,i-1) trans(3,i) = trans(3,i-1) end do trans(1,1) = 0 trans(2,1) = 0 trans(3,1) = 0 c c translate the original unit cell to make a block of cells c do i = 2, nsym ii = (i-1) * n do j = 1, n jj = j + ii x(jj) = x(j) + trans(1,i) y(jj) = y(j) + trans(2,i) z(jj) = z(j) + trans(3,i) call cellatom (jj,j) end do end do n = nsym * n c c update the cell dimensions and fractional coordinates c xbox = xbox * dble(na) ybox = ybox * dble(nb) zbox = zbox * dble(nc) do i = 1, n x(i) = x(i) / dble(na) y(i) = y(i) / dble(nb) z(i) = z(i) / dble(nc) end do c c perform deallocation of some local arrays c deallocate (trans) return end c c c ########################################################### c ## ## c ## subroutine symmetry -- apply space group symmetry ## c ## ## c ########################################################### c c c "symmetry" applies symmetry operators to the fractional c coordinates of the asymmetric unit in order to generate c the symmetry related atoms of the full unit cell c c subroutine symmetry (spacegrp) use atoms use math implicit none integer i,j,k integer ii,jj,kk integer nsym,noff real*8 one6,five6 real*8 xoff,yoff,zoff character*10 spacegrp c c c P1 space group (International Tables 1) c if (spacegrp .eq. 'P1 ') then nsym = 1 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c P1(-) space group (International Tables 2) c else if (spacegrp .eq. 'P1(-) ') then nsym = 2 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) end if call cellatom (jj,j) end do end do c c P2 space group (International Tables 3) c else if (spacegrp .eq. 'P2 ') then nsym = 2 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = y(j) z(jj) = -z(j) end if call cellatom (jj,j) end do end do c c P21 space group (International Tables 4) c else if (spacegrp .eq. 'P21 ') then nsym = 2 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) end if call cellatom (jj,j) end do end do c c C2 space group (International Tables 5) c else if (spacegrp .eq. 'C2 ') then nsym = 2 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Pm space group (International Tables 6) c else if (spacegrp .eq. 'Pm ') then nsym = 2 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = x(j) y(jj) = -y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c Pc space group (International Tables 7) c else if (spacegrp .eq. 'Pc ') then nsym = 2 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Cm space group (International Tables 8) c else if (spacegrp .eq. 'Cm ') then nsym = 2 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Cc space group (International Tables 9) c else if (spacegrp .eq. 'Cc ') then nsym = 2 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + 0.5d0 + zoff end if call cellatom (jj,j) end do end do end do c c P2/m space group (International Tables 10) c else if (spacegrp .eq. 'P2/m ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = -y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c P21/m space group (International Tables 11) c else if (spacegrp .eq. 'P21/m ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c C2/m space group (International Tables 12) c else if (spacegrp .eq. 'C2/m ') then nsym = 4 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c P2/c space group (International Tables 13) c else if (spacegrp .eq. 'P2/c ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c P21/c space group (International Tables 14) c else if (spacegrp .eq. 'P21/c ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c P21/n space group (International Tables 14) c else if (spacegrp .eq. 'P21/n ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c P21/a space group (International Tables 14) c else if (spacegrp .eq. 'P21/a ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c C2/c space group (International Tables 15) c else if (spacegrp .eq. 'C2/c ') then nsym = 4 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff end if call cellatom (jj,j) end do end do end do c c P21212 space group (International Tables 18) c else if (spacegrp .eq. 'P21212 ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) end if call cellatom (jj,j) end do end do c c P212121 space group (International Tables 19) c else if (spacegrp .eq. 'P212121 ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) end if call cellatom (jj,j) end do end do c c C2221 space group (International Tables 20) c else if (spacegrp .eq. 'C2221 ') then nsym = 4 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 4) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Pca21 space group (International Tables 29) c else if (spacegrp .eq. 'Pca21 ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = 0.5d0 + x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 4) then x(jj) = 0.5d0 - x(j) y(jj) = y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Pmn21 space group (International Tables 31) c else if (spacegrp .eq. 'Pmn21 ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = 0.5d0 + x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c Pna21 space group (International Tables 33) c else if (spacegrp .eq. 'Pna21 ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c Pn21a space group (International Tables 33) c else if (spacegrp .eq. 'Pn21a ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) end if call cellatom (jj,j) end do end do c c Pnn2 space group (International Tables 34) c else if (spacegrp .eq. 'Pnn2 ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 4) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Cmc21 space group (International Tables 36) c else if (spacegrp .eq. 'Cmc21 ') then nsym = 4 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 4) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Aba2 space group (International Tables 41) c else if (spacegrp .eq. 'Aba2 ') then nsym = 4 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.0d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 4) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Fdd2 space group (International Tables 43) c else if (spacegrp .eq. 'Fdd2 ') then nsym = 4 noff = 4 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.0d0 yoff = 0.5d0 zoff = 0.5d0 else if (k .eq. 3) then xoff = 0.5d0 yoff = 0.0d0 zoff = 0.5d0 else if (k .eq. 4) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = 0.25d0 - y(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 4) then x(jj) = 0.25d0 - x(j) + xoff y(jj) = 0.25d0 + y(j) + yoff z(jj) = 0.25d0 + z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Iba2 space group (International Tables 45) c else if (spacegrp .eq. 'Iba2 ') then nsym = 4 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 4) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Pnna space group (International Tables 52) c else if (spacegrp .eq. 'Pnna ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 5) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 7) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 8) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Pmna space group (International Tables 53) c else if (spacegrp .eq. 'Pmna ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 7) then x(jj) = 0.5d0 + x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 8) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Pcca space group (International Tables 54) c else if (spacegrp .eq. 'Pcca ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = -y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 5) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 7) then x(jj) = x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 8) then x(jj) = 0.5d0 - x(j) y(jj) = y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Pbam space group (International Tables 55) c else if (spacegrp .eq. 'Pbam ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 7) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = z(j) else if (i .eq. 8) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c Pccn space group (International Tables 56) c else if (spacegrp .eq. 'Pccn ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 + x(j) y(jj) = -y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 5) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 7) then x(jj) = 0.5d0 - x(j) y(jj) = y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 8) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Pbcm space group (International Tables 57) c else if (spacegrp .eq. 'Pbcm ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 7) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 8) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c Pnnm space group (International Tables 58) c else if (spacegrp .eq. 'Pnnm ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 5) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 7) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 8) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Pmmn space group (International Tables 59) c else if (spacegrp .eq. 'Pmmn ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 7) then x(jj) = x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 8) then x(jj) = -x(j) y(jj) = y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c Pbcn space group (International Tables 60) c else if (spacegrp .eq. 'Pbcn ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 5) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 7) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = z(j) else if (i .eq. 8) then x(jj) = x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Pbca space group (International Tables 61) c else if (spacegrp .eq. 'Pbca ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 7) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 8) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c Pnma space group (International Tables 62) c else if (spacegrp .eq. 'Pnma ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 5) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 7) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = z(j) else if (i .eq. 8) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Cmcm space group (International Tables 63) c else if (spacegrp .eq. 'Cmcm ') then nsym = 8 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 4) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 6) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 7) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 8) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Cmca space group (International Tables 64) c else if (spacegrp .eq. 'Cmca ') then nsym = 8 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 4) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 6) then x(jj) = x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 7) then x(jj) = x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 8) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Ccca space group (International Tables 68) c else if (spacegrp .eq. 'Ccca ') then nsym = 8 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = -x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 7) then x(jj) = x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 8) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Fddd space group (International Tables 70) c else if (spacegrp .eq. 'Fddd ') then nsym = 8 noff = 4 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.0d0 yoff = 0.5d0 zoff = 0.5d0 else if (k .eq. 3) then xoff = 0.5d0 yoff = 0.0d0 zoff = 0.5d0 else if (k .eq. 4) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = 0.25d0 - x(j) + xoff y(jj) = 0.25d0 - y(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 6) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = 0.25d0 + y(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 7) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = 0.25d0 - y(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 8) then x(jj) = 0.25d0 - x(j) + xoff y(jj) = 0.25d0 + y(j) + yoff z(jj) = 0.25d0 + z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Ibam space group (International Tables 72) c else if (spacegrp .eq. 'Ibam ') then nsym = 8 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 6) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 7) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 8) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c Ibca space group (International Tables 73) c else if (spacegrp .eq. 'Ibca ') then nsym = 8 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 7) then x(jj) = x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 8) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c P41 space group (International Tables 76) c else if (spacegrp .eq. 'P41 ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = -y(j) y(jj) = x(j) z(jj) = 0.25d0 + z(j) else if (i .eq. 4) then x(jj) = y(j) y(jj) = -x(j) z(jj) = 0.75d0 + z(j) end if call cellatom (jj,j) end do end do c c P43 space group (International Tables 78) c else if (spacegrp .eq. 'P43 ') then nsym = 4 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = -y(j) y(jj) = x(j) z(jj) = 0.75d0 + z(j) else if (i .eq. 4) then x(jj) = y(j) y(jj) = -x(j) z(jj) = 0.25d0 + z(j) end if call cellatom (jj,j) end do end do c c I4(-) space group (International Tables 82) c else if (spacegrp .eq. 'I4(-) ') then nsym = 4 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = y(j) + xoff y(jj) = -x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = -y(j) + xoff y(jj) = x(j) + yoff z(jj) = -z(j) + zoff end if call cellatom (jj,j) end do end do end do c c P4/n space group (International Tables 85) c else if (spacegrp .eq. 'P4/n ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 + x(j) z(jj) = z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 - x(j) z(jj) = z(j) else if (i .eq. 5) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 7) then x(jj) = y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 8) then x(jj) = -y(j) y(jj) = x(j) z(jj) = -z(j) end if call cellatom (jj,j) end do end do c c P42/n space group (International Tables 86) c else if (spacegrp .eq. 'P42/n ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 5) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 7) then x(jj) = y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 8) then x(jj) = -y(j) y(jj) = x(j) z(jj) = -z(j) end if call cellatom (jj,j) end do end do c c I4/m space group (International Tables 87) c else if (spacegrp .eq. 'I4/m ') then nsym = 8 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = -y(j) + xoff y(jj) = x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 4) then x(jj) = y(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 5) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 6) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 7) then x(jj) = y(j) + xoff y(jj) = -x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 8) then x(jj) = -y(j) + xoff y(jj) = x(j) + yoff z(jj) = -z(j) + zoff end if call cellatom (jj,j) end do end do end do c c I41/a space group (International Tables 88) c else if (spacegrp .eq. 'I41/a ') then nsym = 8 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = -y(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 4) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = -x(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 5) then x(jj) = -x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 6) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 7) then x(jj) = y(j) + xoff y(jj) = -x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 8) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.5d0 - z(j) + zoff end if call cellatom (jj,j) end do end do end do c c P41212 space group (International Tables 92) c else if (spacegrp .eq. 'P41212 ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.25d0 + z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.75d0 + z(j) else if (i .eq. 5) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.25d0 - z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.75d0 - z(j) else if (i .eq. 7) then x(jj) = y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 8) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = 0.5d0 - z(j) end if call cellatom (jj,j) end do end do c c P43212 space group (International Tables 96) c else if (spacegrp .eq. 'P43212 ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.75d0 + z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.25d0 + z(j) else if (i .eq. 5) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.75d0 - z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.25d0 - z(j) else if (i .eq. 7) then x(jj) = y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 8) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = 0.5d0 - z(j) end if call cellatom (jj,j) end do end do c c P4(-)21m space group (International Tables 113) c else if (spacegrp .eq. 'P4(-)21m') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = -y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) else if (i .eq. 7) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 - x(j) z(jj) = z(j) else if (i .eq. 8) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 + x(j) z(jj) = z(j) end if call cellatom (jj,j) end do end do c c P4(-)21c space group (International Tables 114) c else if (spacegrp .eq. 'P4(-)21c') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = -y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 7) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 8) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c P4(-)m2 space group (International Tables 115) c else if (spacegrp .eq. 'P4(-)m2 ') then nsym = 8 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 5) then x(jj) = -y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 7) then x(jj) = y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 8) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = -z(j) end if call cellatom (jj,j) end do end do c c I4(-)2d space group (International Tables 122) c else if (spacegrp .eq. 'I4(-)2d ') then nsym = 8 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = y(j) + xoff y(jj) = -x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = -y(j) + xoff y(jj) = x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 6) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 7) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = -x(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 8) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = x(j) + yoff z(jj) = 0.75d0 + z(j) + zoff end if call cellatom (jj,j) end do end do end do c c I41/amd space group (Intl. Tables 141, origin at center) c else if (spacegrp .eq. 'I41/amd ') then nsym = 16 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = 0.25d0 - y(j) + xoff y(jj) = 0.75d0 + x(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 4) then x(jj) = 0.25d0 + y(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 5) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 6) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 7) then x(jj) = 0.25d0 + y(j) + xoff y(jj) = 0.25d0 + x(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 8) then x(jj) = 0.25d0 - y(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 9) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 10) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 11) then x(jj) = 0.75d0 + y(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 12) then x(jj) = 0.75d0 - y(j) + xoff y(jj) = 0.75d0 + x(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 13) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 14) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 15) then x(jj) = 0.75d0 - y(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 16) then x(jj) = 0.75d0 + y(j) + xoff y(jj) = 0.75d0 + x(j) + yoff z(jj) = 0.25d0 + z(j) + zoff end if call cellatom (jj,j) end do end do end do c c P31 space group (International Tables 144) c else if (spacegrp .eq. 'P31 ') then nsym = 3 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = third + z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = third2 + z(j) end if call cellatom (jj,j) end do end do c c P32 space group (International Tables 145) c else if (spacegrp .eq. 'P32 ') then nsym = 3 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = third2 + z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = third + z(j) end if call cellatom (jj,j) end do end do c c R3 space group (International Tables 146) c else if (spacegrp .eq. 'R3 ') then nsym = 3 noff = 3 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = third2 yoff = third zoff = third else if (k .eq. 3) then xoff = third yoff = third2 zoff = third2 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -y(j) + xoff y(jj) = x(j) - y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = y(j) - x(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c P3(-) space group (International Tables 147) c else if (spacegrp .eq. 'P3(-) ') then nsym = 6 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = z(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = y(j) y(jj) = y(j) - x(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = x(j) - y(j) y(jj) = x(j) z(jj) = -z(j) end if call cellatom (jj,j) end do end do c c R3(-) space group (Intl. Tables 148, Hexagonal Axes) c c else if (spacegrp .eq. 'R3(-) ') then c nsym = 6 c noff = 3 c do i = 1, nsym c ii = (i-1) * noff * n c do k = 1, noff c kk = ii + (k-1)*n c if (k .eq. 1) then c xoff = 0.0d0 c yoff = 0.0d0 c zoff = 0.0d0 c else if (k .eq. 2) then c xoff = third2 c yoff = third c zoff = third c else if (k .eq. 3) then c xoff = third c yoff = third2 c zoff = third2 c end if c do j = 1, n c jj = j + kk c if (i .eq. 1) then c x(jj) = x(j) + xoff c y(jj) = y(j) + yoff c z(jj) = z(j) + zoff c else if (i .eq. 2) then c x(jj) = -y(j) + xoff c y(jj) = x(j) - y(j) + yoff c z(jj) = z(j) + zoff c else if (i .eq. 3) then c x(jj) = y(j) - x(j) + xoff c y(jj) = -x(j) + yoff c z(jj) = z(j) + zoff c else if (i .eq. 4) then c x(jj) = -x(j) + xoff c y(jj) = -y(j) + yoff c z(jj) = -z(j) + zoff c else if (i .eq. 5) then c x(jj) = y(j) + xoff c y(jj) = y(j) - x(j) + yoff c z(jj) = -z(j) + zoff c else if (i .eq. 6) then c x(jj) = x(j) - y(j) + xoff c y(jj) = x(j) + yoff c z(jj) = -z(j) + zoff c end if c call cellatom (jj,j) c end do c end do c end do c c R3(-) space group (Intl. Tables 148, Rhombohedral Axes) c else if (spacegrp .eq. 'R3(-) ') then nsym = 6 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 3) then x(jj) = y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 6) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = -x(j) end if call cellatom (jj,j) end do end do c c P3121 space group (International Tables 152) c else if (spacegrp .eq. 'P3121 ') then nsym = 6 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = third + z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = third2 + z(j) else if (i .eq. 4) then x(jj) = y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = x(j) - y(j) y(jj) = -y(j) z(jj) = third2 - z(j) else if (i .eq. 6) then x(jj) = -x(j) y(jj) = y(j) - x(j) z(jj) = third - z(j) end if call cellatom (jj,j) end do end do c c P3221 space group (International Tables 154) c else if (spacegrp .eq. 'P3221 ') then nsym = 6 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = third2 + z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = third + z(j) else if (i .eq. 4) then x(jj) = y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = x(j) - y(j) y(jj) = -y(j) z(jj) = third - z(j) else if (i .eq. 6) then x(jj) = -x(j) y(jj) = y(j) - x(j) z(jj) = third2 - z(j) end if call cellatom (jj,j) end do end do c c R3m space group (International Tables 160) c else if (spacegrp .eq. 'R3m ') then nsym = 6 noff = 3 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = third2 yoff = third zoff = third else if (k .eq. 3) then xoff = third yoff = third2 zoff = third2 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -y(j) + xoff y(jj) = x(j) - y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = y(j) - x(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 4) then x(jj) = -y(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 5) then x(jj) = y(j) - x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 6) then x(jj) = x(j) + xoff y(jj) = x(j) - y(j) + yoff z(jj) = z(j) + zoff end if call cellatom (jj,j) end do end do end do c c R3c space group (International Tables 161) c else if (spacegrp .eq. 'R3c ') then nsym = 6 noff = 3 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = third2 yoff = third zoff = third else if (k .eq. 3) then xoff = third yoff = third2 zoff = third2 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -y(j) + xoff y(jj) = x(j) - y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = y(j) - x(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 4) then x(jj) = -y(j) + xoff y(jj) = -x(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 5) then x(jj) = y(j) - x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 6) then x(jj) = x(j) + xoff y(jj) = x(j) - y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff end if call cellatom (jj,j) end do end do end do c c P3(-)c1 space group (International Tables 165) c else if (spacegrp .eq. 'P3(-)c1 ') then nsym = 12 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = z(j) else if (i .eq. 4) then x(jj) = y(j) y(jj) = x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 5) then x(jj) = x(i) - y(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 6) then x(jj) = -x(j) y(jj) = y(i) - x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 7) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 8) then x(jj) = y(j) y(jj) = y(j) - x(j) z(jj) = -z(j) else if (i .eq. 9) then x(jj) = x(j) - y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 10) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 11) then x(jj) = y(j) - x(i) y(jj) = y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 12) then x(jj) = x(j) y(jj) = x(j) - y(i) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c R3(-)m space group (Intl. Tables 166, Rhombohedral Axes) c else if (spacegrp .eq. 'R3(-)m ') then nsym = 12 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 3) then x(jj) = y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 4) then x(jj) = -z(j) y(jj) = -y(j) z(jj) = -x(j) else if (i .eq. 5) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 6) then x(jj) = -x(j) y(jj) = -z(j) z(jj) = -y(j) else if (i .eq. 7) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 8) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 9) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = -x(j) else if (i .eq. 10) then x(jj) = z(j) y(jj) = y(j) z(jj) = x(j) else if (i .eq. 11) then x(jj) = y(j) y(jj) = x(j) z(jj) = z(j) else if (i .eq. 12) then x(jj) = x(j) y(jj) = z(j) z(jj) = y(j) end if call cellatom (jj,j) end do end do c c R3(-)c space group (International Tables 167) c else if (spacegrp .eq. 'R3(-)c ') then nsym = 12 noff = 3 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = third2 yoff = third zoff = third else if (k .eq. 3) then xoff = third yoff = third2 zoff = third2 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -y(j) + xoff y(jj) = x(j) - y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = y(j) - x(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 4) then x(jj) = y(j) + xoff y(jj) = x(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 5) then x(jj) = x(j) - y(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 6) then x(jj) = -x(j) + xoff y(jj) = y(j) - x(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 7) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 8) then x(jj) = y(j) + xoff y(jj) = y(j) - x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 9) then x(jj) = x(j) - y(j) + xoff y(jj) = x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 10) then x(jj) = -y(j) + xoff y(jj) = -x(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 11) then x(jj) = y(j) - x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 12) then x(jj) = x(j) + xoff y(jj) = x(j) - y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff end if call cellatom (jj,j) end do end do end do c c P61 space group (International Tables 169) c else if (spacegrp .eq. 'P61 ') then nsym = 6 noff = 1 one6 = 1.0d0 / 6.0d0 five6 = 5.0d0 / 6.0d0 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = third + z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = third2 + z(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 5) then x(jj) = y(j) y(jj) = y(j) - x(i) z(jj) = five6 + z(j) else if (i .eq. 6) then x(jj) = x(j) - y(i) y(jj) = x(j) z(jj) = one6 + z(j) end if call cellatom (jj,j) end do end do c c P65 space group (International Tables 170) c else if (spacegrp .eq. 'P65 ') then nsym = 6 noff = 1 one6 = 1.0d0 / 6.0d0 five6 = 5.0d0 / 6.0d0 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = third2 + z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = third + z(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 5) then x(jj) = y(j) y(jj) = y(j) - x(i) z(jj) = one6 + z(j) else if (i .eq. 6) then x(jj) = x(j) - y(i) y(jj) = x(j) z(jj) = five6 + z(j) end if call cellatom (jj,j) end do end do c c P63 space group (International Tables 173) c else if (spacegrp .eq. 'P63 ') then nsym = 6 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = z(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 5) then x(jj) = y(j) y(jj) = y(j) - x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 6) then x(jj) = x(j) - y(j) y(jj) = x(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c P63/m space group (International Tables 176) c else if (spacegrp .eq. 'P63/m ') then nsym = 12 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = z(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 5) then x(jj) = y(j) y(jj) = y(j) - x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 6) then x(jj) = x(j) - y(j) y(jj) = x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 7) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 8) then x(jj) = y(j) y(jj) = y(j) - x(j) z(jj) = -z(j) else if (i .eq. 9) then x(jj) = x(j) - y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 10) then x(jj) = x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 11) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 12) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = 0.5d0 - z(j) end if call cellatom (jj,j) end do end do c c P6(3)/mmc space group (Intl. Tables 194, Hexagonal Close Packed) c else if (spacegrp .eq. 'P63/mmc ') then nsym = 24 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = z(j) else if (i .eq. 4) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 5) then x(jj) = y(j) y(jj) = y(j) - x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 6) then x(jj) = x(j) - y(j) y(jj) = x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 7) then x(jj) = y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 8) then x(jj) = x(j) - y(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 9) then x(jj) = -x(j) y(jj) = y(j) - x(j) z(jj) = -z(j) else if (i .eq. 10) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 11) then x(jj) = y(j) - x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 12) then x(jj) = x(j) y(jj) = x(j) - y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 13) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 14) then x(jj) = y(j) y(jj) = y(j) - x(j) z(jj) = -z(j) else if (i .eq. 15) then x(jj) = x(j) - y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 16) then x(jj) = x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 17) then x(jj) = -y(j) y(jj) = x(j) - y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 18) then x(jj) = y(j) - x(j) y(jj) = -x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 19) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = z(j) else if (i .eq. 20) then x(jj) = y(j) - x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 21) then x(jj) = x(j) y(jj) = x(j) - y(j) z(jj) = z(j) else if (i .eq. 22) then x(jj) = y(j) y(jj) = x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 23) then x(jj) = x(j) - y(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 24) then x(jj) = -x(j) y(jj) = y(j) - x(j) z(jj) = 0.5d0 + z(j) end if call cellatom (jj,j) end do end do c c Pa3(-) space group (International Tables 205) c else if (spacegrp .eq. 'Pa3(-) ') then nsym = 24 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 6) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 - x(j) z(jj) = -y(j) else if (i .eq. 7) then x(jj) = 0.5d0 - z(j) y(jj) = -x(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 8) then x(jj) = -z(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 9) then x(jj) = y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 10) then x(jj) = -y(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 11) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 - z(j) z(jj) = -x(j) else if (i .eq. 12) then x(jj) = 0.5d0 - y(j) y(jj) = -z(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 13) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 14) then x(jj) = 0.5d0 + x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 15) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 16) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + y(j) z(jj) = z(j) else if (i .eq. 17) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 18) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 + x(j) z(jj) = y(j) else if (i .eq. 19) then x(jj) = 0.5d0 + z(j) y(jj) = x(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 20) then x(jj) = z(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 21) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = -x(j) else if (i .eq. 22) then x(jj) = y(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 23) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 + z(j) z(jj) = x(j) else if (i .eq. 24) then x(jj) = 0.5d0 + y(j) y(jj) = z(j) z(jj) = 0.5d0 - x(j) end if call cellatom (jj,j) end do end do c c P4(-)3m space group (International Tables 215) c else if (spacegrp .eq. 'P4(-)3m ') then nsym = 24 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 6) then x(jj) = z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 7) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = y(j) else if (i .eq. 8) then x(jj) = -z(j) y(jj) = x(j) z(jj) = -y(j) else if (i .eq. 9) then x(jj) = y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 10) then x(jj) = -y(j) y(jj) = z(j) z(jj) = -x(j) else if (i .eq. 11) then x(jj) = y(j) y(jj) = -z(j) z(jj) = -x(j) else if (i .eq. 12) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = x(j) else if (i .eq. 13) then x(jj) = y(j) y(jj) = x(j) z(jj) = z(j) else if (i .eq. 14) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = z(j) else if (i .eq. 15) then x(jj) = y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 16) then x(jj) = -y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 17) then x(jj) = x(j) y(jj) = z(j) z(jj) = y(j) else if (i .eq. 18) then x(jj) = -x(j) y(jj) = z(j) z(jj) = -y(j) else if (i .eq. 19) then x(jj) = -x(j) y(jj) = -z(j) z(jj) = y(j) else if (i .eq. 20) then x(jj) = x(j) y(jj) = -z(j) z(jj) = -y(j) else if (i .eq. 21) then x(jj) = z(j) y(jj) = y(j) z(jj) = x(j) else if (i .eq. 22) then x(jj) = z(j) y(jj) = -y(j) z(jj) = -x(j) else if (i .eq. 23) then x(jj) = -z(j) y(jj) = y(j) z(jj) = -x(j) else if (i .eq. 24) then x(jj) = -z(j) y(jj) = -y(j) z(jj) = x(j) end if call cellatom (jj,j) end do end do c c I4(-)3m space group (Intl. Tables 217, Body Centered Cubic) c else if (spacegrp .eq. 'I4(-)3m ') then nsym = 24 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 6) then x(jj) = z(j) + xoff y(jj) = -x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 7) then x(jj) = -z(j) + xoff y(jj) = -x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 8) then x(jj) = -z(j) + xoff y(jj) = x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 9) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 10) then x(jj) = -y(j) + xoff y(jj) = z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 11) then x(jj) = y(j) + xoff y(jj) = -z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 12) then x(jj) = -y(j) + xoff y(jj) = -z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 13) then x(jj) = y(j) + xoff y(jj) = x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 14) then x(jj) = -y(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 15) then x(jj) = y(j) + xoff y(jj) = -x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 16) then x(jj) = -y(j) + xoff y(jj) = x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 17) then x(jj) = x(j) + xoff y(jj) = z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 18) then x(jj) = -x(j) + xoff y(jj) = z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 19) then x(jj) = -x(j) + xoff y(jj) = -z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 20) then x(jj) = x(j) + xoff y(jj) = -z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 21) then x(jj) = z(j) + xoff y(jj) = y(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 22) then x(jj) = z(j) + xoff y(jj) = -y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 23) then x(jj) = -z(j) + xoff y(jj) = y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 24) then x(jj) = -z(j) + xoff y(jj) = -y(j) + yoff z(jj) = x(j) + zoff end if call cellatom (jj,j) end do end do end do c c P4(-)3n space group (International Tables 218) c else if (spacegrp .eq. 'P4(-)3n ') then nsym = 24 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 6) then x(jj) = z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 7) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = y(j) else if (i .eq. 8) then x(jj) = -z(j) y(jj) = x(j) z(jj) = -y(j) else if (i .eq. 9) then x(jj) = y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 10) then x(jj) = -y(j) y(jj) = z(j) z(jj) = -x(j) else if (i .eq. 11) then x(jj) = y(j) y(jj) = -z(j) z(jj) = -x(j) else if (i .eq. 12) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = x(j) else if (i .eq. 13) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 14) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 15) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 16) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 17) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 18) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 19) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 20) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 21) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 22) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 23) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 24) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + x(j) end if call cellatom (jj,j) end do end do c c I4(-)3d space group (International Tables 220) c else if (spacegrp .eq. 'I4(-)3d ') then nsym = 24 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 6) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 7) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = -x(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 8) then x(jj) = -z(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 9) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 10) then x(jj) = -y(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 11) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 12) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = -z(j) + yoff z(jj) = 0.5d0 + x(j) + zoff else if (i .eq. 13) then x(jj) = 0.25d0 + y(j) + xoff y(jj) = 0.25d0 + x(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 14) then x(jj) = 0.25d0 - y(j) + xoff y(jj) = 0.75d0 - x(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 15) then x(jj) = 0.75d0 + y(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 16) then x(jj) = 0.75d0 - y(j) + xoff y(jj) = 0.75d0 + x(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 17) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = 0.25d0 + z(j) + yoff z(jj) = 0.25d0 + y(j) + zoff else if (i .eq. 18) then x(jj) = 0.75d0 - x(j) + xoff y(jj) = 0.75d0 + z(j) + yoff z(jj) = 0.25d0 - y(j) + zoff else if (i .eq. 19) then x(jj) = 0.25d0 - x(j) + xoff y(jj) = 0.75d0 - z(j) + yoff z(jj) = 0.75d0 + y(j) + zoff else if (i .eq. 20) then x(jj) = 0.75d0 + x(j) + xoff y(jj) = 0.25d0 - z(j) + yoff z(jj) = 0.75d0 - y(j) + zoff else if (i .eq. 21) then x(jj) = 0.25d0 + z(j) + xoff y(jj) = 0.25d0 + y(j) + yoff z(jj) = 0.25d0 + x(j) + zoff else if (i .eq. 22) then x(jj) = 0.75d0 + z(j) + xoff y(jj) = 0.25d0 - y(j) + yoff z(jj) = 0.75d0 - x(j) + zoff else if (i .eq. 23) then x(jj) = 0.75d0 - z(j) + xoff y(jj) = 0.75d0 + y(j) + yoff z(jj) = 0.25d0 - x(j) + zoff else if (i .eq. 24) then x(jj) = 0.25d0 - z(j) + xoff y(jj) = 0.75d0 - y(j) + yoff z(jj) = 0.75d0 + x(j) + zoff end if call cellatom (jj,j) end do end do end do c c Pm3(-)m space group (International Tables 221) c else if (spacegrp .eq. 'Pm3(-)m ') then nsym = 48 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 6) then x(jj) = z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 7) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = y(j) else if (i .eq. 8) then x(jj) = -z(j) y(jj) = x(j) z(jj) = -y(j) else if (i .eq. 9) then x(jj) = y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 10) then x(jj) = -y(j) y(jj) = z(j) z(jj) = -x(j) else if (i .eq. 11) then x(jj) = y(j) y(jj) = -z(j) z(jj) = -x(j) else if (i .eq. 12) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = x(j) else if (i .eq. 13) then x(jj) = y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 14) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 15) then x(jj) = y(j) y(jj) = -x(j) z(jj) = z(j) else if (i .eq. 16) then x(jj) = -y(j) y(jj) = x(j) z(jj) = z(j) else if (i .eq. 17) then x(jj) = x(j) y(jj) = z(j) z(jj) = -y(j) else if (i .eq. 18) then x(jj) = -x(j) y(jj) = z(j) z(jj) = y(j) else if (i .eq. 19) then x(jj) = -x(j) y(jj) = -z(j) z(jj) = -y(j) else if (i .eq. 20) then x(jj) = x(j) y(jj) = -z(j) z(jj) = y(j) else if (i .eq. 21) then x(jj) = z(j) y(jj) = y(j) z(jj) = -x(j) else if (i .eq. 22) then x(jj) = z(j) y(jj) = -y(j) z(jj) = x(j) else if (i .eq. 23) then x(jj) = -z(j) y(jj) = y(j) z(jj) = x(j) else if (i .eq. 24) then x(jj) = -z(j) y(jj) = -y(j) z(jj) = -x(j) else if (i .eq. 25) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 26) then x(jj) = x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 27) then x(jj) = x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 28) then x(jj) = -x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 29) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 30) then x(jj) = -z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 31) then x(jj) = z(j) y(jj) = x(j) z(jj) = -y(j) else if (i .eq. 32) then x(jj) = z(j) y(jj) = -x(j) z(jj) = y(j) else if (i .eq. 33) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = -x(j) else if (i .eq. 34) then x(jj) = y(j) y(jj) = -z(j) z(jj) = x(j) else if (i .eq. 35) then x(jj) = -y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 36) then x(jj) = y(j) y(jj) = z(j) z(jj) = -x(j) else if (i .eq. 37) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = z(j) else if (i .eq. 38) then x(jj) = y(j) y(jj) = x(j) z(jj) = z(j) else if (i .eq. 39) then x(jj) = -y(j) y(jj) = x(j) z(jj) = -z(j) else if (i .eq. 40) then x(jj) = y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 41) then x(jj) = -x(j) y(jj) = -z(j) z(jj) = y(j) else if (i .eq. 42) then x(jj) = x(j) y(jj) = -z(j) z(jj) = -y(j) else if (i .eq. 43) then x(jj) = x(j) y(jj) = z(j) z(jj) = y(j) else if (i .eq. 44) then x(jj) = -x(j) y(jj) = z(j) z(jj) = -y(j) else if (i .eq. 45) then x(jj) = -z(j) y(jj) = -y(j) z(jj) = x(j) else if (i .eq. 46) then x(jj) = -z(j) y(jj) = y(j) z(jj) = -x(j) else if (i .eq. 47) then x(jj) = z(j) y(jj) = -y(j) z(jj) = -x(j) else if (i .eq. 48) then x(jj) = z(j) y(jj) = y(j) z(jj) = x(j) end if call cellatom (jj,j) end do end do c c Pn3(-)n space group (Intl. Tables 222, origin at center) c else if (spacegrp .eq. 'Pn3(-)n ') then nsym = 48 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 5) then x(jj) = z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 6) then x(jj) = z(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 7) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 - x(j) z(jj) = y(j) else if (i .eq. 8) then x(jj) = 0.5d0 - z(j) y(jj) = x(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 9) then x(jj) = y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 10) then x(jj) = 0.5d0 - y(j) y(jj) = z(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 11) then x(jj) = y(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 12) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 - z(j) z(jj) = x(j) else if (i .eq. 13) then x(jj) = y(j) y(jj) = x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 14) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 15) then x(jj) = y(j) y(jj) = 0.5d0 - x(j) z(jj) = z(j) else if (i .eq. 16) then x(jj) = 0.5d0 - y(j) y(jj) = x(j) z(jj) = z(j) else if (i .eq. 17) then x(jj) = x(j) y(jj) = z(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 18) then x(jj) = 0.5d0 - x(j) y(jj) = z(j) z(jj) = y(j) else if (i .eq. 19) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 20) then x(jj) = x(j) y(jj) = 0.5d0 - z(j) z(jj) = y(j) else if (i .eq. 21) then x(jj) = z(j) y(jj) = y(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 22) then x(jj) = z(j) y(jj) = 0.5d0 - y(j) z(jj) = x(j) else if (i .eq. 23) then x(jj) = 0.5d0 - z(j) y(jj) = y(j) z(jj) = x(j) else if (i .eq. 24) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 25) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 26) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 27) then x(jj) = 0.5d0 + x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 28) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 29) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 30) then x(jj) = -z(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 31) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 + x(j) z(jj) = -y(j) else if (i .eq. 32) then x(jj) = 0.5d0 + z(j) y(jj) = -x(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 33) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = -x(j) else if (i .eq. 34) then x(jj) = 0.5d0 + y(j) y(jj) = -z(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 35) then x(jj) = -y(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 36) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 + z(j) z(jj) = -x(j) else if (i .eq. 37) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 38) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 39) then x(jj) = -y(j) y(jj) = 0.5d0 + x(j) z(jj) = -z(j) else if (i .eq. 40) then x(jj) = 0.5d0 + y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 41) then x(jj) = -x(j) y(jj) = -z(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 42) then x(jj) = 0.5d0 + x(j) y(jj) = -z(j) z(jj) = -y(j) else if (i .eq. 43) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 44) then x(jj) = -x(j) y(jj) = 0.5d0 + z(j) z(jj) = -y(j) else if (i .eq. 45) then x(jj) = -z(j) y(jj) = -y(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 46) then x(jj) = -z(j) y(jj) = 0.5d0 + y(j) z(jj) = -x(j) else if (i .eq. 47) then x(jj) = 0.5d0 + z(j) y(jj) = -y(j) z(jj) = -x(j) else if (i .eq. 48) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + x(j) end if call cellatom (jj,j) end do end do c c Pm3(-)n space group (International Tables 223) c else if (spacegrp .eq. 'Pm3(-)n ') then nsym = 48 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = -x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 5) then x(jj) = z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 6) then x(jj) = z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 7) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = y(j) else if (i .eq. 8) then x(jj) = -z(j) y(jj) = x(j) z(jj) = -y(j) else if (i .eq. 9) then x(jj) = y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 10) then x(jj) = -y(j) y(jj) = z(j) z(jj) = -x(j) else if (i .eq. 11) then x(jj) = y(j) y(jj) = -z(j) z(jj) = -x(j) else if (i .eq. 12) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = x(j) else if (i .eq. 13) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 14) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 15) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 16) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 17) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 18) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 19) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 20) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 21) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 22) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 23) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 24) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 25) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 26) then x(jj) = x(j) y(jj) = y(j) z(jj) = -z(j) else if (i .eq. 27) then x(jj) = x(j) y(jj) = -y(j) z(jj) = z(j) else if (i .eq. 28) then x(jj) = -x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 29) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 30) then x(jj) = -z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 31) then x(jj) = z(j) y(jj) = x(j) z(jj) = -y(j) else if (i .eq. 32) then x(jj) = z(j) y(jj) = -x(j) z(jj) = y(j) else if (i .eq. 33) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = -x(j) else if (i .eq. 34) then x(jj) = y(j) y(jj) = -z(j) z(jj) = x(j) else if (i .eq. 35) then x(jj) = -y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 36) then x(jj) = y(j) y(jj) = z(j) z(jj) = -x(j) else if (i .eq. 37) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 38) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 39) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 40) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 41) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 42) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 43) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 44) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 45) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 46) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 47) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 48) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + x(j) end if call cellatom (jj,j) end do end do c c Pn3(-)m space group (Intl. Tables 224, origin at center) c else if (spacegrp .eq. 'Pn3(-)m ') then nsym = 48 noff = 1 do i = 1, nsym ii = (i-1) * n do j = 1, n jj = j + ii if (i .eq. 1) then x(jj) = x(j) y(jj) = y(j) z(jj) = z(j) else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - y(j) z(jj) = z(j) else if (i .eq. 3) then x(jj) = 0.5d0 - x(j) y(jj) = y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 4) then x(jj) = x(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 5) then x(jj) = z(j) y(jj) = x(j) z(jj) = y(j) else if (i .eq. 6) then x(jj) = z(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 7) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 - x(j) z(jj) = y(j) else if (i .eq. 8) then x(jj) = 0.5d0 - z(j) y(jj) = x(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 9) then x(jj) = y(j) y(jj) = z(j) z(jj) = x(j) else if (i .eq. 10) then x(jj) = 0.5d0 - y(j) y(jj) = z(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 11) then x(jj) = y(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 12) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 - z(j) z(jj) = x(j) else if (i .eq. 13) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 + x(j) z(jj) = -z(j) else if (i .eq. 14) then x(jj) = -y(j) y(jj) = -x(j) z(jj) = -z(j) else if (i .eq. 15) then x(jj) = 0.5d0 + y(j) y(jj) = -x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 16) then x(jj) = -y(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 17) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + z(j) z(jj) = -y(j) else if (i .eq. 18) then x(jj) = -x(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 19) then x(jj) = -x(j) y(jj) = -z(j) z(jj) = -y(j) else if (i .eq. 20) then x(jj) = 0.5d0 + x(j) y(jj) = -z(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 21) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 + y(j) z(jj) = -x(j) else if (i .eq. 22) then x(jj) = 0.5d0 + z(j) y(jj) = -y(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 23) then x(jj) = -z(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 24) then x(jj) = -z(j) y(jj) = -y(j) z(jj) = -x(j) else if (i .eq. 25) then x(jj) = -x(j) y(jj) = -y(j) z(jj) = -z(j) else if (i .eq. 26) then x(jj) = 0.5d0 + x(j) y(jj) = 0.5d0 + y(j) z(jj) = -z(j) else if (i .eq. 27) then x(jj) = 0.5d0 + x(j) y(jj) = -y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 28) then x(jj) = -x(j) y(jj) = 0.5d0 + y(j) z(jj) = 0.5d0 + z(j) else if (i .eq. 29) then x(jj) = -z(j) y(jj) = -x(j) z(jj) = -y(j) else if (i .eq. 30) then x(jj) = -z(j) y(jj) = 0.5d0 + x(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 31) then x(jj) = 0.5d0 + z(j) y(jj) = 0.5d0 + x(j) z(jj) = -y(j) else if (i .eq. 32) then x(jj) = 0.5d0 + z(j) y(jj) = -x(j) z(jj) = 0.5d0 + y(j) else if (i .eq. 33) then x(jj) = -y(j) y(jj) = -z(j) z(jj) = -x(j) else if (i .eq. 34) then x(jj) = 0.5d0 + y(j) y(jj) = -z(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 35) then x(jj) = -y(j) y(jj) = 0.5d0 + z(j) z(jj) = 0.5d0 + x(j) else if (i .eq. 36) then x(jj) = 0.5d0 + y(j) y(jj) = 0.5d0 + z(j) z(jj) = -x(j) else if (i .eq. 37) then x(jj) = 0.5d0 - y(j) y(jj) = 0.5d0 - x(j) z(jj) = z(j) else if (i .eq. 38) then x(jj) = y(j) y(jj) = x(j) z(jj) = z(j) else if (i .eq. 39) then x(jj) = 0.5d0 - y(j) y(jj) = x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 40) then x(jj) = y(j) y(jj) = 0.5d0 - x(j) z(jj) = 0.5d0 - z(j) else if (i .eq. 41) then x(jj) = 0.5d0 - x(j) y(jj) = 0.5d0 - z(j) z(jj) = y(j) else if (i .eq. 42) then x(jj) = x(j) y(jj) = 0.5d0 - z(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 43) then x(jj) = x(j) y(jj) = z(j) z(jj) = y(j) else if (i .eq. 44) then x(jj) = 0.5d0 - x(j) y(jj) = z(j) z(jj) = 0.5d0 - y(j) else if (i .eq. 45) then x(jj) = 0.5d0 - z(j) y(jj) = 0.5d0 - y(j) z(jj) = x(j) else if (i .eq. 46) then x(jj) = 0.5d0 - z(j) y(jj) = y(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 47) then x(jj) = z(j) y(jj) = 0.5d0 - y(j) z(jj) = 0.5d0 - x(j) else if (i .eq. 48) then x(jj) = z(j) y(jj) = y(j) z(jj) = x(j) end if call cellatom (jj,j) end do end do c c Fm3(-)m space group (Intl. Tables 225, Face Centered Cubic) c else if (spacegrp .eq. 'Fm3(-)m ') then nsym = 48 noff = 4 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.0d0 yoff = 0.5d0 zoff = 0.5d0 else if (k .eq. 3) then xoff = 0.5d0 yoff = 0.0d0 zoff = 0.5d0 else if (k .eq. 4) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 6) then x(jj) = z(j) + xoff y(jj) = -x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 7) then x(jj) = -z(j) + xoff y(jj) = -x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 8) then x(jj) = -z(j) + xoff y(jj) = x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 9) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 10) then x(jj) = -y(j) + xoff y(jj) = z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 11) then x(jj) = y(j) + xoff y(jj) = -z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 12) then x(jj) = -y(j) + xoff y(jj) = -z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 13) then x(jj) = y(j) + xoff y(jj) = x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 14) then x(jj) = -y(j) + xoff y(jj) = -x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 15) then x(jj) = y(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 16) then x(jj) = -y(j) + xoff y(jj) = x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 17) then x(jj) = x(j) + xoff y(jj) = z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 18) then x(jj) = -x(j) + xoff y(jj) = z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 19) then x(jj) = -x(j) + xoff y(jj) = -z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 20) then x(jj) = x(j) + xoff y(jj) = -z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 21) then x(jj) = z(j) + xoff y(jj) = y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 22) then x(jj) = z(j) + xoff y(jj) = -y(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 23) then x(jj) = -z(j) + xoff y(jj) = y(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 24) then x(jj) = -z(j) + xoff y(jj) = -y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 25) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 26) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 27) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 28) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 29) then x(jj) = -z(j) + xoff y(jj) = -x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 30) then x(jj) = -z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 31) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 32) then x(jj) = z(j) + xoff y(jj) = -x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 33) then x(jj) = -y(j) + xoff y(jj) = -z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 34) then x(jj) = y(j) + xoff y(jj) = -z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 35) then x(jj) = -y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 36) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 37) then x(jj) = -y(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 38) then x(jj) = y(j) + xoff y(jj) = x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 39) then x(jj) = -y(j) + xoff y(jj) = x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 40) then x(jj) = y(j) + xoff y(jj) = -x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 41) then x(jj) = -x(j) + xoff y(jj) = -z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 42) then x(jj) = x(j) + xoff y(jj) = -z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 43) then x(jj) = x(j) + xoff y(jj) = z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 44) then x(jj) = -x(j) + xoff y(jj) = z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 45) then x(jj) = -z(j) + xoff y(jj) = -y(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 46) then x(jj) = -z(j) + xoff y(jj) = y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 47) then x(jj) = z(j) + xoff y(jj) = -y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 48) then x(jj) = z(j) + xoff y(jj) = y(j) + yoff z(jj) = x(j) + zoff end if call cellatom (jj,j) end do end do end do c c Fm3(-)c space group (International Tables 226) c else if (spacegrp .eq. 'Fm3(-)c ') then nsym = 48 noff = 4 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.0d0 yoff = 0.5d0 zoff = 0.5d0 else if (k .eq. 3) then xoff = 0.5d0 yoff = 0.0d0 zoff = 0.5d0 else if (k .eq. 4) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 6) then x(jj) = z(j) + xoff y(jj) = -x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 7) then x(jj) = -z(j) + xoff y(jj) = -x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 8) then x(jj) = -z(j) + xoff y(jj) = x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 9) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 10) then x(jj) = -y(j) + xoff y(jj) = z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 11) then x(jj) = y(j) + xoff y(jj) = -z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 12) then x(jj) = -y(j) + xoff y(jj) = -z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 13) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 14) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 15) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 16) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 17) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 18) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 19) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 20) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 21) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 22) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 + x(j) + zoff else if (i .eq. 23) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.5d0 + x(j) + zoff else if (i .eq. 24) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 25) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 26) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 27) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 28) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 29) then x(jj) = -z(j) + xoff y(jj) = -x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 30) then x(jj) = -z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 31) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 32) then x(jj) = z(j) + xoff y(jj) = -x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 33) then x(jj) = -y(j) + xoff y(jj) = -z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 34) then x(jj) = y(j) + xoff y(jj) = -z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 35) then x(jj) = -y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 36) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 37) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 38) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 39) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 40) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 41) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 42) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 43) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 44) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 45) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 + x(j) + zoff else if (i .eq. 46) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 47) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 48) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.5d0 + x(j) + zoff end if call cellatom (jj,j) end do end do end do c c Fd3(-)m space group (Intl. Tables 227, origin at center) c else if (spacegrp .eq. 'Fd3(-)m ') then nsym = 48 noff = 4 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.0d0 yoff = 0.5d0 zoff = 0.5d0 else if (k .eq. 3) then xoff = 0.5d0 yoff = 0.0d0 zoff = 0.5d0 else if (k .eq. 4) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = 0.75d0 - x(j) + xoff y(jj) = 0.25d0 - y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = 0.25d0 - x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.75d0 - y(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 5) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 6) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = 0.75d0 - x(j) + yoff z(jj) = 0.25d0 - y(j) + zoff else if (i .eq. 7) then x(jj) = 0.75d0 - z(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 8) then x(jj) = 0.25d0 - z(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.75d0 - y(j) + zoff else if (i .eq. 9) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 10) then x(jj) = 0.25d0 - y(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = 0.75d0 - x(j) + zoff else if (i .eq. 11) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = 0.75d0 - z(j) + yoff z(jj) = 0.25d0 - x(j) + zoff else if (i .eq. 12) then x(jj) = 0.75d0 - y(j) + xoff y(jj) = 0.25d0 - z(j) + yoff z(jj) = 0.5d0 + x(j) + zoff else if (i .eq. 13) then x(jj) = 0.75d0 + y(j) + xoff y(jj) = 0.25d0 + x(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 14) then x(jj) = -y(j) + xoff y(jj) = -x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 15) then x(jj) = 0.25d0 + y(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 16) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = 0.75d0 + x(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 17) then x(jj) = 0.75d0 + x(j) + xoff y(jj) = 0.25d0 + z(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 18) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.75d0 + z(j) + yoff z(jj) = 0.25d0 + y(j) + zoff else if (i .eq. 19) then x(jj) = -x(j) + xoff y(jj) = -z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 20) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = 0.75d0 + y(j) + zoff else if (i .eq. 21) then x(jj) = 0.75d0 + z(j) + xoff y(jj) = 0.25d0 + y(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 22) then x(jj) = 0.25d0 + z(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.75d0 + x(j) + zoff else if (i .eq. 23) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = 0.75d0 + y(j) + yoff z(jj) = 0.25d0 + x(j) + zoff else if (i .eq. 24) then x(jj) = -z(j) + xoff y(jj) = -y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 25) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 26) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = 0.75d0 + y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 27) then x(jj) = 0.75d0 + x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 28) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.25d0 + y(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 29) then x(jj) = -z(j) + xoff y(jj) = -x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 30) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = 0.25d0 + x(j) + yoff z(jj) = 0.75d0 + y(j) + zoff else if (i .eq. 31) then x(jj) = 0.25d0 + z(j) + xoff y(jj) = 0.75d0 + x(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 32) then x(jj) = 0.75d0 + z(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = 0.25d0 + y(j) + zoff else if (i .eq. 33) then x(jj) = -y(j) + xoff y(jj) = -z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 34) then x(jj) = 0.75d0 + y(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = 0.25d0 + x(j) + zoff else if (i .eq. 35) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = 0.25d0 + z(j) + yoff z(jj) = 0.75d0 + x(j) + zoff else if (i .eq. 36) then x(jj) = 0.25d0 + y(j) + xoff y(jj) = 0.75d0 + z(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 37) then x(jj) = 0.25d0 - y(j) + xoff y(jj) = 0.75d0 - x(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 38) then x(jj) = y(j) + xoff y(jj) = x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 39) then x(jj) = 0.75d0 - y(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 40) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 41) then x(jj) = 0.25d0 - x(j) + xoff y(jj) = 0.75d0 - z(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 42) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.25d0 - z(j) + yoff z(jj) = 0.75d0 - y(j) + zoff else if (i .eq. 43) then x(jj) = x(j) + xoff y(jj) = z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 44) then x(jj) = 0.75d0 - x(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = 0.25d0 - y(j) + zoff else if (i .eq. 45) then x(jj) = 0.25d0 - z(j) + xoff y(jj) = 0.75d0 - y(j) + yoff z(jj) = 0.5d0 + x(j) + zoff else if (i .eq. 46) then x(jj) = 0.75d0 - z(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.25d0 - x(j) + zoff else if (i .eq. 47) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = 0.25d0 - y(j) + yoff z(jj) = 0.75d0 - x(j) + zoff else if (i .eq. 48) then x(jj) = z(j) + xoff y(jj) = y(j) + yoff z(jj) = x(j) + zoff end if call cellatom (jj,j) end do end do end do c c Fd3(-)c space group (Intl. Tables 228, origin at center) c else if (spacegrp .eq. 'Fd3(-)c ') then nsym = 48 noff = 4 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.0d0 yoff = 0.5d0 zoff = 0.5d0 else if (k .eq. 3) then xoff = 0.5d0 yoff = 0.0d0 zoff = 0.5d0 else if (k .eq. 4) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.0d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = 0.25d0 - x(j) + xoff y(jj) = 0.75d0 - y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = 0.75d0 - x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.25d0 - y(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 5) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 6) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.75d0 - y(j) + zoff else if (i .eq. 7) then x(jj) = 0.25d0 - z(j) + xoff y(jj) = 0.75d0 - x(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 8) then x(jj) = 0.75d0 - z(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.25d0 - y(j) + zoff else if (i .eq. 9) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 10) then x(jj) = 0.75d0 - y(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = 0.25d0 - x(j) + zoff else if (i .eq. 11) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = 0.25d0 - z(j) + yoff z(jj) = 0.75d0 - x(j) + zoff else if (i .eq. 12) then x(jj) = 0.25d0 - y(j) + xoff y(jj) = 0.75d0 - z(j) + yoff z(jj) = 0.5d0 + x(j) + zoff else if (i .eq. 13) then x(jj) = 0.75d0 + y(j) + xoff y(jj) = 0.25d0 + x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 14) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 15) then x(jj) = 0.25d0 + y(j) + xoff y(jj) = -x(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 16) then x(jj) = -y(j) + xoff y(jj) = 0.75d0 + x(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 17) then x(jj) = 0.75d0 + x(j) + xoff y(jj) = 0.25d0 + z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 18) then x(jj) = -x(j) + xoff y(jj) = 0.75d0 + z(j) + yoff z(jj) = 0.25d0 + y(j) + zoff else if (i .eq. 19) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 20) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = -z(j) + yoff z(jj) = 0.75d0 + y(j) + zoff else if (i .eq. 21) then x(jj) = 0.75d0 + z(j) + xoff y(jj) = 0.25d0 + y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 22) then x(jj) = 0.25d0 + z(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.75d0 + x(j) + zoff else if (i .eq. 23) then x(jj) = -z(j) + xoff y(jj) = 0.75d0 + y(j) + yoff z(jj) = 0.25d0 + x(j) + zoff else if (i .eq. 24) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 25) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 26) then x(jj) = 0.75d0 + x(j) + xoff y(jj) = 0.25d0 + y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 27) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 28) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.75d0 + y(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 29) then x(jj) = -z(j) + xoff y(jj) = -x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 30) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = 0.75d0 + x(j) + yoff z(jj) = 0.25d0 + y(j) + zoff else if (i .eq. 31) then x(jj) = 0.75d0 + z(j) + xoff y(jj) = 0.25d0 + x(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 32) then x(jj) = 0.25d0 + z(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = 0.75d0 + y(j) + zoff else if (i .eq. 33) then x(jj) = -y(j) + xoff y(jj) = -z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 34) then x(jj) = 0.25d0 + y(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = 0.75d0 + x(j) + zoff else if (i .eq. 35) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = 0.75d0 + z(j) + yoff z(jj) = 0.25d0 + x(j) + zoff else if (i .eq. 36) then x(jj) = 0.75d0 + y(j) + xoff y(jj) = 0.25d0 + z(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 37) then x(jj) = 0.25d0 - y(j) + xoff y(jj) = 0.75d0 - x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 38) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 39) then x(jj) = 0.75d0 - y(j) + xoff y(jj) = x(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 40) then x(jj) = y(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 41) then x(jj) = 0.25d0 - x(j) + xoff y(jj) = 0.75d0 - z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 42) then x(jj) = x(j) + xoff y(jj) = 0.25d0 - z(j) + yoff z(jj) = 0.75d0 - y(j) + zoff else if (i .eq. 43) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 44) then x(jj) = 0.75d0 - x(j) + xoff y(jj) = z(j) + yoff z(jj) = 0.25d0 - y(j) + zoff else if (i .eq. 45) then x(jj) = 0.25d0 - z(j) + xoff y(jj) = 0.75d0 - y(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 46) then x(jj) = 0.75d0 - z(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.25d0 - x(j) + zoff else if (i .eq. 47) then x(jj) = z(j) + xoff y(jj) = 0.25d0 - y(j) + yoff z(jj) = 0.75d0 - x(j) + zoff else if (i .eq. 48) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.5d0 + x(j) + zoff end if call cellatom (jj,j) end do end do end do c c Im3(-)m space group (Intl. Tables 229, Body Centered Cubic) c else if (spacegrp .eq. 'Im3(-)m ') then nsym = 48 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 4) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 6) then x(jj) = z(j) + xoff y(jj) = -x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 7) then x(jj) = -z(j) + xoff y(jj) = -x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 8) then x(jj) = -z(j) + xoff y(jj) = x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 9) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 10) then x(jj) = -y(j) + xoff y(jj) = z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 11) then x(jj) = y(j) + xoff y(jj) = -z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 12) then x(jj) = -y(j) + xoff y(jj) = -z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 13) then x(jj) = y(j) + xoff y(jj) = x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 14) then x(jj) = -y(j) + xoff y(jj) = -x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 15) then x(jj) = y(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 16) then x(jj) = -y(j) + xoff y(jj) = x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 17) then x(jj) = x(j) + xoff y(jj) = z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 18) then x(jj) = -x(j) + xoff y(jj) = z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 19) then x(jj) = -x(j) + xoff y(jj) = -z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 20) then x(jj) = x(j) + xoff y(jj) = -z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 21) then x(jj) = z(j) + xoff y(jj) = y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 22) then x(jj) = z(j) + xoff y(jj) = -y(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 23) then x(jj) = -z(j) + xoff y(jj) = y(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 24) then x(jj) = -z(j) + xoff y(jj) = -y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 25) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 26) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 27) then x(jj) = x(j) + xoff y(jj) = -y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 28) then x(jj) = -x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 29) then x(jj) = -z(j) + xoff y(jj) = -x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 30) then x(jj) = -z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 31) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 32) then x(jj) = z(j) + xoff y(jj) = -x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 33) then x(jj) = -y(j) + xoff y(jj) = -z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 34) then x(jj) = y(j) + xoff y(jj) = -z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 35) then x(jj) = -y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 36) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 37) then x(jj) = -y(j) + xoff y(jj) = -x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 38) then x(jj) = y(j) + xoff y(jj) = x(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 39) then x(jj) = -y(j) + xoff y(jj) = x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 40) then x(jj) = y(j) + xoff y(jj) = -x(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 41) then x(jj) = -x(j) + xoff y(jj) = -z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 42) then x(jj) = x(j) + xoff y(jj) = -z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 43) then x(jj) = x(j) + xoff y(jj) = z(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 44) then x(jj) = -x(j) + xoff y(jj) = z(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 45) then x(jj) = -z(j) + xoff y(jj) = -y(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 46) then x(jj) = -z(j) + xoff y(jj) = y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 47) then x(jj) = z(j) + xoff y(jj) = -y(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 48) then x(jj) = z(j) + xoff y(jj) = y(j) + yoff z(jj) = x(j) + zoff end if call cellatom (jj,j) end do end do end do c c Ia3(-)d space group (International Tables 230) c else if (spacegrp .eq. 'Ia3(-)d ') then nsym = 48 noff = 2 do i = 1, nsym ii = (i-1) * noff * n do k = 1, noff kk = ii + (k-1)*n if (k .eq. 1) then xoff = 0.0d0 yoff = 0.0d0 zoff = 0.0d0 else if (k .eq. 2) then xoff = 0.5d0 yoff = 0.5d0 zoff = 0.5d0 end if do j = 1, n jj = j + kk if (i .eq. 1) then x(jj) = x(j) + xoff y(jj) = y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 2) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = -y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 3) then x(jj) = -x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 4) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 5) then x(jj) = z(j) + xoff y(jj) = x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 6) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 7) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = -x(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 8) then x(jj) = -z(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 9) then x(jj) = y(j) + xoff y(jj) = z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 10) then x(jj) = -y(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 11) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 12) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = -z(j) + yoff z(jj) = 0.5d0 + x(j) + zoff else if (i .eq. 13) then x(jj) = 0.75d0 + y(j) + xoff y(jj) = 0.25d0 + x(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 14) then x(jj) = 0.75d0 - y(j) + xoff y(jj) = 0.75d0 - x(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 15) then x(jj) = 0.25d0 + y(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 16) then x(jj) = 0.25d0 - y(j) + xoff y(jj) = 0.75d0 + x(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 17) then x(jj) = 0.75d0 + x(j) + xoff y(jj) = 0.25d0 + z(j) + yoff z(jj) = 0.25d0 - y(j) + zoff else if (i .eq. 18) then x(jj) = 0.25d0 - x(j) + xoff y(jj) = 0.75d0 + z(j) + yoff z(jj) = 0.25d0 + y(j) + zoff else if (i .eq. 19) then x(jj) = 0.75d0 - x(j) + xoff y(jj) = 0.75d0 - z(j) + yoff z(jj) = 0.75d0 - y(j) + zoff else if (i .eq. 20) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = 0.25d0 - z(j) + yoff z(jj) = 0.75d0 + y(j) + zoff else if (i .eq. 21) then x(jj) = 0.75d0 + z(j) + xoff y(jj) = 0.25d0 + y(j) + yoff z(jj) = 0.25d0 - x(j) + zoff else if (i .eq. 22) then x(jj) = 0.25d0 + z(j) + xoff y(jj) = 0.25d0 - y(j) + yoff z(jj) = 0.75d0 + x(j) + zoff else if (i .eq. 23) then x(jj) = 0.25d0 - z(j) + xoff y(jj) = 0.75d0 + y(j) + yoff z(jj) = 0.25d0 + x(j) + zoff else if (i .eq. 24) then x(jj) = 0.75d0 - z(j) + xoff y(jj) = 0.75d0 - y(j) + yoff z(jj) = 0.75d0 - x(j) + zoff else if (i .eq. 25) then x(jj) = -x(j) + xoff y(jj) = -y(j) + yoff z(jj) = -z(j) + zoff else if (i .eq. 26) then x(jj) = 0.5d0 + x(j) + xoff y(jj) = y(j) + yoff z(jj) = 0.5d0 - z(j) + zoff else if (i .eq. 27) then x(jj) = x(j) + xoff y(jj) = 0.5d0 - y(j) + yoff z(jj) = 0.5d0 + z(j) + zoff else if (i .eq. 28) then x(jj) = 0.5d0 - x(j) + xoff y(jj) = 0.5d0 + y(j) + yoff z(jj) = z(j) + zoff else if (i .eq. 29) then x(jj) = -z(j) + xoff y(jj) = -x(j) + yoff z(jj) = -y(j) + zoff else if (i .eq. 30) then x(jj) = 0.5d0 - z(j) + xoff y(jj) = 0.5d0 + x(j) + yoff z(jj) = y(j) + zoff else if (i .eq. 31) then x(jj) = 0.5d0 + z(j) + xoff y(jj) = x(j) + yoff z(jj) = 0.5d0 - y(j) + zoff else if (i .eq. 32) then x(jj) = z(j) + xoff y(jj) = 0.5d0 - x(j) + yoff z(jj) = 0.5d0 + y(j) + zoff else if (i .eq. 33) then x(jj) = -y(j) + xoff y(jj) = -z(j) + yoff z(jj) = -x(j) + zoff else if (i .eq. 34) then x(jj) = y(j) + xoff y(jj) = 0.5d0 - z(j) + yoff z(jj) = 0.5d0 + x(j) + zoff else if (i .eq. 35) then x(jj) = 0.5d0 - y(j) + xoff y(jj) = 0.5d0 + z(j) + yoff z(jj) = x(j) + zoff else if (i .eq. 36) then x(jj) = 0.5d0 + y(j) + xoff y(jj) = z(j) + yoff z(jj) = 0.5d0 - x(j) + zoff else if (i .eq. 37) then x(jj) = 0.25d0 - y(j) + xoff y(jj) = 0.75d0 - x(j) + yoff z(jj) = 0.75d0 + z(j) + zoff else if (i .eq. 38) then x(jj) = 0.25d0 + y(j) + xoff y(jj) = 0.25d0 + x(j) + yoff z(jj) = 0.25d0 + z(j) + zoff else if (i .eq. 39) then x(jj) = 0.75d0 - y(j) + xoff y(jj) = 0.75d0 + x(j) + yoff z(jj) = 0.25d0 - z(j) + zoff else if (i .eq. 40) then x(jj) = 0.75d0 + y(j) + xoff y(jj) = 0.25d0 - x(j) + yoff z(jj) = 0.75d0 - z(j) + zoff else if (i .eq. 41) then x(jj) = 0.25d0 - x(j) + xoff y(jj) = 0.75d0 - z(j) + yoff z(jj) = 0.75d0 + y(j) + zoff else if (i .eq. 42) then x(jj) = 0.75d0 + x(j) + xoff y(jj) = 0.25d0 - z(j) + yoff z(jj) = 0.75d0 - y(j) + zoff else if (i .eq. 43) then x(jj) = 0.25d0 + x(j) + xoff y(jj) = 0.25d0 + z(j) + yoff z(jj) = 0.25d0 + y(j) + zoff else if (i .eq. 44) then x(jj) = 0.75d0 - x(j) + xoff y(jj) = 0.75d0 + z(j) + yoff z(jj) = 0.25d0 - y(j) + zoff else if (i .eq. 45) then x(jj) = 0.25d0 - z(j) + xoff y(jj) = 0.75d0 - y(j) + yoff z(jj) = 0.75d0 + x(j) + zoff else if (i .eq. 46) then x(jj) = 0.75d0 - z(j) + xoff y(jj) = 0.75d0 + y(j) + yoff z(jj) = 0.25d0 - x(j) + zoff else if (i .eq. 47) then x(jj) = 0.75d0 + z(j) + xoff y(jj) = 0.25d0 - y(j) + yoff z(jj) = 0.75d0 - x(j) + zoff else if (i .eq. 48) then x(jj) = 0.25d0 + z(j) + xoff y(jj) = 0.25d0 + y(j) + yoff z(jj) = 0.25d0 + x(j) + zoff end if call cellatom (jj,j) end do end do end do end if c c set the total number of atoms in the full unit cell c n = nsym * noff * n return end c c c ################################################### c ## COPYRIGHT (C) 2003 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine cspline -- periodic interpolating cube spline ## c ## ## c ################################################################## c c c "cspline" computes the coefficients for a periodic interpolating c cubic spline c c literature reference: c c G. Engeln-Mullges and F. Uhlig, Numerical Algorithms with Fortran, c Springer Verlag, 1996, Section 10.1.2 [see routine "isplpe"] c c subroutine cspline (n,xn,fn,b,c,d,h,du,dm,rc,rs) use iounit implicit none integer i,n,iflag real*8 eps,average real*8 temp1,temp2 real*8 xn(0:*) real*8 fn(0:*) real*8 b(0:*) real*8 c(0:*) real*8 d(0:*) real*8 h(0:*) real*8 du(0:*) real*8 dm(0:*) real*8 rc(0:*) real*8 rs(0:*) c c c check the periodicity of fn, and for subsequent call c eps = 0.000001d0 if (abs(fn(n)-fn(0)) .gt. eps) then write (iout,10) fn(0),fn(n) 10 format (/,' CSPLINE -- Warning, Non-Periodic Input', & ' Values',2f12.5) end if average = 0.5d0 * (fn(0) + fn(n)) fn(0) = average fn(n) = average c c get auxiliary variables and matrix elements on first call c do i = 0, n-1 h(i) = xn(i+1) - xn(i) end do h(n) = h(0) do i = 1, n-1 du(i) = h(i) end do du(n) = h(0) do i = 1, n dm(i) = 2.0d0 * (h(i-1)+h(i)) end do c c compute the right hand side c temp1 = (fn(1)-fn(0)) / h(0) do i = 1, n-1, 1 temp2 = (fn(i+1)-fn(i)) / h(i) rs(i) = 3.0d0 * (temp2-temp1) temp1 = temp2 end do rs(n) = 3.0d0 * ((fn(1)-fn(0))/h(0)-temp1) c c solve the linear system with factorization c call cytsy (n,dm,du,rc,rs,c,iflag) if (iflag .ne. 1) return c c compute remaining spline coefficients c c(0) = c(n) do i = 0, n-1 b(i) = (fn(i+1)-fn(i))/h(i) - h(i)/3.0d0*(c(i+1)+2.0d0*c(i)) d(i) = (c(i+1)-c(i)) / (3.0d0*h(i)) end do b(n) = (fn(1)-fn(n))/h(n) - h(n)/3.0d0*(c(1)+2.0d0*c(n)) return end c c c ############################################################# c ## ## c ## subroutine cytsy -- solve cyclic tridiagonal system ## c ## ## c ############################################################# c c c "cytsy" solves a system of linear equations for a cyclically c tridiagonal, symmetric, positive definite matrix c c literature reference: c c G. Engeln-Mullges and F. Uhlig, Numerical Algorithms with Fortran, c Springer Verlag, 1996, Section 4.11.2 c c subroutine cytsy (n,dm,du,cr,rs,x,iflag) implicit none integer n,iflag real*8 dm(0:*) real*8 du(0:*) real*8 cr(0:*) real*8 rs(0:*) real*8 x(0:*) c c c factorization of the input matrix c iflag = -2 if (n .lt. 3) return call cytsyp (n,dm,du,cr,iflag) c c update and back substitute as necessary c if (iflag .eq. 1) call cytsys (n,dm,du,cr,rs,x) return end c c c ################################################################# c ## ## c ## subroutine cytsyp -- tridiagonal Cholesky factorization ## c ## ## c ################################################################# c c c "cytsyp" finds the Cholesky factors of a cyclically tridiagonal c symmetric, positive definite matrix given by two vectors c c literature reference: c c G. Engeln-Mullges and F. Uhlig, Numerical Algorithms with Fortran, c Springer Verlag, 1996, Section 4.11.2 c c subroutine cytsyp (n,dm,du,cr,iflag) implicit none integer i,n,iflag real*8 eps,row,d real*8 temp1,temp2 real*8 dm(0:*) real*8 du(0:*) real*8 cr(0:*) c c c set error bound and test for condition n greater than 2 c eps = 0.00000001d0 iflag = -2 if (n .lt. 3) return c c checking to see if matrix is positive definite c row = abs(dm(1)) + abs(du(1)) + abs(du(n)) if (row .eq. 0.0d0) then iflag = 0 return end if d = 1.0d0 / row if (dm(1) .lt. 0.0d0) then iflag = -1 return else if (abs(dm(1))*d .le. eps) then iflag = 0 return end if c c factoring a while checking for a positive definite and strong c nonsingular matrix a c temp1 = du(1) du(1) = du(1) / dm(1) cr(1) = du(n) / dm(1) do i = 2, n-1 row = abs(dm(i)) + abs(du(i)) + abs(temp1) if (row .eq. 0.0d0) then iflag = 0 return end if d = 1.0d0 / row dm(i) = dm(i) - temp1*du(i-1) if (dm(i) .lt. 0.0d0) then iflag = -1 return else if (abs(dm(i))*d .le. eps) then iflag = 0 return end if if (i .lt. (n-1)) then cr(i) = -temp1 * cr(i-1) / dm(i) temp1 = du(i) du(i) = du(i) / dm(i) else temp2 = du(i) du(i) = (du(i) - temp1*cr(i-1)) / dm(i) end if end do row = abs(du(n)) + abs(dm(n)) + abs(temp2) if (row .eq. 0.0d0) then iflag = 0 return end if d = 1.0d0 / row dm(n) = dm(n) - dm(n-1)*du(n-1)*du(n-1) temp1 = 0.0d0 do i = 1, n-2 temp1 = temp1 + dm(i)*cr(i)*cr(i) end do dm(n) = dm(n) - temp1 if (dm(n) .lt. 0) then iflag = -1 return else if (abs(dm(n))*d .le. eps) then iflag = 0 return end if iflag = 1 return end c c c ################################################################ c ## ## c ## subroutine cytsys -- tridiagonal solution from factors ## c ## ## c ################################################################ c c c "cytsys" solves a cyclically tridiagonal linear system c given the Cholesky factors c c literature reference: c c G. Engeln-Mullges and F. Uhlig, Numerical Algorithms with Fortran, c Springer Verlag, 1996, Section 4.11.2 c c subroutine cytsys (n,dm,du,cr,rs,x) implicit none integer i,n real*8 sum,temp real*8 dm(0:*) real*8 du(0:*) real*8 cr(0:*) real*8 rs(0:*) real*8 x(0:*) c c c updating phase c temp = rs(1) rs(1) = temp / dm(1) sum = cr(1) * temp do i = 2, n-1 temp = rs(i) - du(i-1)*temp rs(i) = temp / dm(i) if (i .ne. (n-1)) sum = sum + cr(i)*temp end do temp = rs(n) - du(n-1)*temp temp = temp - sum rs(n) = temp / dm(n) c c back substitution phase c x(n) = rs(n) x(n-1) = rs(n-1) - du(n-1)*x(n) do i = n-2, 1, -1 x(i) = rs(i) - du(i)*x(i+1) - cr(i)*x(n) end do return end c c c ################################################### c ## COPYRIGHT (C) 2019 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module ctrpot -- charge transfer functional form details ## c ## ## c ################################################################## c c c ctrntyp type of charge transfer term (SEPARATE or COMBINED) c c module ctrpot character*8 ctrntyp save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine cutoffs -- distance cutoffs & neighbor lists ## c ## ## c ################################################################# c c c "cutoffs" initializes and stores spherical energy cutoff c distance windows, Hessian element and Ewald sum cutoffs, c and allocates pairwise neighbor lists c c subroutine cutoffs use atoms use bound use hescut use keys use limits use neigh use polpot use tarray implicit none integer i,next integer limit real*8 big,value logical truncate character*20 keyword character*240 record character*240 string c c c set defaults for spherical energy cutoff distances c big = 1.0d12 if (use_bounds) then vdwcut = 9.0d0 dispcut = 9.0d0 chgcut = 9.0d0 dplcut = 9.0d0 mpolecut = 9.0d0 else vdwcut = big dispcut = big chgcut = big dplcut = big mpolecut = big end if repcut = 6.0d0 ctrncut = 6.0d0 ewaldcut = 7.0d0 dewaldcut = 7.0d0 usolvcut = 4.5d0 c c set defaults for tapering, Hessian cutoff and neighbor buffers c vdwtaper = 0.90d0 reptaper = 0.90d0 disptaper = 0.90d0 chgtaper = 0.65d0 dpltaper = 0.75d0 mpoletaper = 0.65d0 ctrntaper = 0.90d0 hesscut = 0.0d0 lbuffer = 2.0d0 pbuffer = 2.0d0 c c set defaults for Ewald sum, tapering style and neighbor method c use_ewald = .false. use_dewald = .false. truncate = .false. use_lights = .false. use_list = .false. use_vlist = .false. use_dlist = .false. use_clist = .false. use_mlist = .false. use_ulist = .false. dovlst = .true. dodlst = .true. doclst = .true. domlst = .true. doulst = .true. c c search the keywords for various cutoff parameters c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) c c get values related to use of Ewald for electrostatics c if (keyword(1:6) .eq. 'EWALD ') then use_ewald = .true. else if (keyword(1:13) .eq. 'EWALD-CUTOFF ') then read (string,*,err=10,end=10) ewaldcut c c get values related to use of Ewald for dispersion c else if (keyword(1:7) .eq. 'DEWALD ') then use_dewald = .true. else if (keyword(1:14) .eq. 'DEWALD-CUTOFF ') then read (string,*,err=10,end=10) dewaldcut c c get values for the tapering style and neighbor method c else if (keyword(1:9) .eq. 'TRUNCATE ') then truncate = .true. else if (keyword(1:7) .eq. 'LIGHTS ') then use_lights = .true. else if (keyword(1:14) .eq. 'NEIGHBOR-LIST ') then use_list = .true. use_vlist = .true. use_dlist = .true. use_clist = .true. use_mlist = .true. use_ulist = .true. else if (keyword(1:9) .eq. 'VDW-LIST ') then use_list = .true. use_vlist = .true. else if (keyword(1:10) .eq. 'DISP-LIST ') then use_list = .true. use_dlist = .true. else if (keyword(1:12) .eq. 'CHARGE-LIST ') then use_list = .true. use_clist = .true. else if (keyword(1:11) .eq. 'MPOLE-LIST ') then use_list = .true. use_mlist = .true. use_ulist = .true. c c get values for the dipole solver preconditioner c else if (keyword(1:12) .eq. 'USOLVE-LIST ') then use_list = .true. use_ulist = .true. else if (keyword(1:14) .eq. 'USOLVE-CUTOFF ') then if (usolvcut .ne. 0.0d0) then read (string,*,err=10,end=10) usolvcut end if else if (keyword(1:16) .eq. 'USOLVE-DIAGONAL ') then usolvcut = 0.0d0 c c get cutoff for the magnitude of Hessian elements c else if (keyword(1:15) .eq. 'HESSIAN-CUTOFF ') then read (string,*,err=10,end=10) hesscut c c get the cutoff radii for potential energy functions c else if (keyword(1:7) .eq. 'CUTOFF ') then read (string,*,err=10,end=10) value vdwcut = value repcut = value dispcut = value chgcut = value dplcut = value mpolecut = value ewaldcut = value dewaldcut = value ctrncut = value else if (keyword(1:11) .eq. 'VDW-CUTOFF ') then read (string,*,err=10,end=10) vdwcut else if (keyword(1:14) .eq. 'REPULS-CUTOFF ') then read (string,*,err=10,end=10) repcut else if (keyword(1:12) .eq. 'DISP-CUTOFF ') then read (string,*,err=10,end=10) dispcut else if (keyword(1:14) .eq. 'CHARGE-CUTOFF ') then read (string,*,err=10,end=10) chgcut else if (keyword(1:14) .eq. 'DIPOLE-CUTOFF ') then read (string,*,err=10,end=10) dplcut else if (keyword(1:13) .eq. 'MPOLE-CUTOFF ') then read (string,*,err=10,end=10) mpolecut else if (keyword(1:14) .eq. 'CHGTRN-CUTOFF ') then read (string,*,err=10,end=10) ctrncut c c get distance for initialization of energy switching c else if (keyword(1:6) .eq. 'TAPER ') then read (string,*,err=10,end=10) value vdwtaper = value reptaper = value disptaper = value chgtaper = value dpltaper = value mpoletaper = value ctrntaper = value else if (keyword(1:10) .eq. 'VDW-TAPER ') then read (string,*,err=10,end=10) vdwtaper else if (keyword(1:13) .eq. 'REPULS-TAPER ') then read (string,*,err=10,end=10) reptaper else if (keyword(1:11) .eq. 'DISP-TAPER ') then read (string,*,err=10,end=10) disptaper else if (keyword(1:13) .eq. 'CHARGE-TAPER ') then read (string,*,err=10,end=10) chgtaper else if (keyword(1:13) .eq. 'DIPOLE-TAPER ') then read (string,*,err=10,end=10) dpltaper else if (keyword(1:12) .eq. 'MPOLE-TAPER ') then read (string,*,err=10,end=10) mpoletaper else if (keyword(1:13) .eq. 'CHGTRN-TAPER ') then read (string,*,err=10,end=10) ctrntaper c c get buffer width for use with pairwise neighbor lists c else if (keyword(1:12) .eq. 'LIST-BUFFER ') then read (string,*,err=10,end=10) lbuffer else if (keyword(1:14) .eq. 'USOLVE-BUFFER ') then read (string,*,err=10,end=10) pbuffer end if 10 continue end do c c check to see if preconditioner list should be disabled c if (poltyp .eq. 'DIRECT') use_ulist = .false. if (usolvcut .le. 0.0d0) use_ulist = .false. if (use_list) usolvcut = usolvcut - pbuffer c c apply any Ewald cutoff to dispersion and electrostatics c if (use_ewald) then chgcut = ewaldcut mpolecut = ewaldcut end if if (use_dewald) then dispcut = dewaldcut end if c c convert any tapering percentages to absolute distances c if (vdwtaper .lt. 1.0d0) vdwtaper = vdwtaper * vdwcut if (reptaper .lt. 1.0d0) reptaper = reptaper * repcut if (disptaper .lt. 1.0d0) disptaper = disptaper * dispcut if (chgtaper .lt. 1.0d0) chgtaper = chgtaper * chgcut if (dpltaper .lt. 1.0d0) dpltaper = dpltaper * dplcut if (mpoletaper .lt. 1.0d0) mpoletaper = mpoletaper * mpolecut if (ctrntaper .lt. 1.0d0) ctrntaper = ctrntaper * ctrncut c c apply truncation cutoffs if they were requested c if (truncate) then vdwtaper = big reptaper = big disptaper = big chgtaper = big dpltaper = big mpoletaper = big ctrntaper = big end if c c set buffer region limits for pairwise neighbor lists c lbuf2 = (0.5d0*lbuffer)**2 pbuf2 = (0.5d0*pbuffer)**2 vbuf2 = (vdwcut+lbuffer)**2 dbuf2 = (dispcut+lbuffer)**2 cbuf2 = (chgcut+lbuffer)**2 mbuf2 = (mpolecut+lbuffer)**2 ubuf2 = (usolvcut+pbuffer)**2 vbufx = (vdwcut+2.0d0*lbuffer)**2 dbufx = (dispcut+2.0d0*lbuffer)**2 cbufx = (chgcut+2.0d0*lbuffer)**2 mbufx = (mpolecut+2.0d0*lbuffer)**2 ubufx = (usolvcut+2.0d0*pbuffer)**2 c c specify maximum size for each of the neighbor lists c maxvlst = 2500 if (vdwcut.ne.big .and. dispcut.ne.big) then limit = int(sqrt(max(vbuf2,dbuf2))**3) + 100 maxvlst = min(limit,maxvlst) else if (vdwcut .ne. big) then limit = int(sqrt(vbuf2)**3) + 100 maxvlst = min(limit,maxvlst) else if (dispcut .ne. big) then limit = int(sqrt(dbuf2)**3) + 100 maxvlst = min(limit,maxvlst) end if maxelst = 2500 if (chgcut.ne.big .and. mpolecut.ne.big) then limit = int(sqrt(max(cbuf2,mbuf2))**3) + 100 maxelst = min(limit,maxelst) else if (chgcut .ne. big) then limit = int(sqrt(cbuf2)**3) + 100 maxelst = min(limit,maxelst) else if (mpolecut .ne. big) then limit = int(sqrt(mbuf2)**3) + 100 maxelst = min(limit,maxelst) end if maxulst = 500 limit = int(sqrt(ubuf2)**3) + 100 maxulst = min(limit,maxulst) c c perform dynamic allocation of some global arrays c if (use_vlist .or. use_dlist) then if (allocated(nvlst)) deallocate (nvlst) if (allocated(vlst)) deallocate (vlst) if (allocated(xvold)) deallocate (xvold) if (allocated(yvold)) deallocate (yvold) if (allocated(zvold)) deallocate (zvold) allocate (nvlst(n)) allocate (vlst(maxvlst,n)) allocate (xvold(n)) allocate (yvold(n)) allocate (zvold(n)) end if if (use_clist .or. use_mlist) then if (allocated(nelst)) deallocate (nelst) if (allocated(elst)) deallocate (elst) if (allocated(xeold)) deallocate (xeold) if (allocated(yeold)) deallocate (yeold) if (allocated(zeold)) deallocate (zeold) allocate (nelst(n)) allocate (elst(maxelst,n)) allocate (xeold(n)) allocate (yeold(n)) allocate (zeold(n)) if (poltyp .ne. 'DIRECT') then if (allocated(tindex)) deallocate (tindex) if (allocated(tdipdip)) deallocate (tdipdip) allocate (tindex(2,n*maxelst)) allocate (tdipdip(6,n*maxelst)) end if end if if (use_ulist) then if (allocated(nulst)) deallocate (nulst) if (allocated(ulst)) deallocate (ulst) if (allocated(xuold)) deallocate (xuold) if (allocated(yuold)) deallocate (yuold) if (allocated(zuold)) deallocate (zuold) allocate (nulst(n)) allocate (ulst(maxulst,n)) allocate (xuold(n)) allocate (yuold(n)) allocate (zuold(n)) end if return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################# c ## ## c ## subroutine dampewald -- find Ewald damping coefficients ## c ## ## c ################################################################# c c c "dampewald" finds coefficients for error function damping used c for Ewald real space interactions c c subroutine dampewald (rorder,r,r2,scale,dmpe) use ewald use math implicit none integer i,niter integer rorder real*8 r,r2,scale real*8 bfac,erfc real*8 aesq2,afac real*8 expterm,ra real*8 bn(0:5) real*8 dmpe(*) external erfc c c c initialize the Ewald damping factor coefficients c do i = 1, rorder dmpe(i) = scale end do c c compute the successive Ewald damping factors c ra = aewald * r bn(0) = erfc(ra) / r dmpe(1) = scale * bn(0) expterm = exp(-ra*ra) aesq2 = 2.0d0 * aewald * aewald afac = 0.0d0 if (aewald .gt. 0.0d0) afac = 1.0d0 / (rootpi*aewald) niter = (rorder-1) / 2 do i = 1, niter bfac = dble(2*i-1) afac = aesq2 * afac bn(i) = (bfac*bn(i-1)+afac*expterm) / r2 dmpe(2*i+1) = scale * bn(i) end do return end c c c ############################################################### c ## ## c ## subroutine dampthole -- original Thole damping values ## c ## ## c ############################################################### c c c "dampthole" finds coefficients for the original Thole damping c function used by AMOEBA and for mutual polarization by AMOEBA+ c c literature reference: c c B. T. Thole, "Molecular Polarizabilities Calculated with a c Modified Dipole Interaction", Chemical Physics, 59, 341-350 (1981) c c subroutine dampthole (i,k,rorder,r,dmpik) use atoms use mpole use polar implicit none integer i,j,k integer it,kt integer rorder real*8 r,damp real*8 damp2 real*8 damp3 real*8 expdamp real*8 pgamma real*8 dmpik(*) c c c initialize the Thole damping factors to a value of one c do j = 1, rorder dmpik(j) = 1.0d0 end do c c use original Thole polarization model damping factors c damp = pdamp(i) * pdamp(k) it = jpolar(i) kt = jpolar(k) pgamma = thlval(it,kt) if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then damp = pgamma * (r/damp)**3 if (damp .lt. 50.0d0) then expdamp = exp(-damp) dmpik(3) = 1.0d0 - expdamp dmpik(5) = 1.0d0 - expdamp*(1.0d0+damp) if (rorder .ge. 7) then damp2 = damp * damp dmpik(7) = 1.0d0 - expdamp*(1.0d0+damp+0.6d0*damp2) if (rorder .ge. 9) then damp3 = damp * damp2 dmpik(9) = 1.0d0 - expdamp*(1.0d0+damp & +(18.0d0/35.0d0)*damp2 & +(9.0d0/35.0d0)*damp3) end if end if end if end if return end c c c ################################################################# c ## ## c ## subroutine damptholed -- alternate Thole damping values ## c ## ## c ################################################################# c c c "damptholed" finds coefficients for the original Thole damping c function used by AMOEBA or for the alternate direct polarization c damping used by AMOEBA+ c c literature reference: c c B. T. Thole, "Molecular Polarizabilities Calculated with a c Modified Dipole Interaction", Chemical Physics, 59, 341-350 (1981) c c subroutine damptholed (i,k,rorder,r,dmpik) use atoms use mpole use polar use polpot implicit none integer i,j,k integer it,kt integer rorder real*8 r,damp real*8 damp2 real*8 damp3 real*8 expdamp real*8 pgamma real*8 dmpik(*) c c c initialize the Thole damping factors to a value of one c do j = 1, rorder dmpik(j) = 1.0d0 end do c c use alternate Thole model for AMOEBA+ direct polarization c damp = pdamp(i) * pdamp(k) if (use_tholed) then it = jpolar(i) kt = jpolar(k) pgamma = thdval(it,kt) if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then damp = pgamma * (r/damp)**(1.5d0) if (damp .lt. 50.0d0) then expdamp = exp(-damp) dmpik(3) = 1.0d0 - expdamp dmpik(5) = 1.0d0 - expdamp*(1.0d0+0.5d0*damp) if (rorder .ge. 7) then damp2 = damp * damp dmpik(7) = 1.0d0 - expdamp*(1.0d0+0.65d0*damp & +0.15d0*damp2) end if end if end if c c use original Thole polarization model damping factors c else it = jpolar(i) kt = jpolar(k) pgamma = thlval(it,kt) if (damp.ne.0.0d0 .and. pgamma.ne.0.0d0) then damp = pgamma * (r/damp)**3 if (damp .lt. 50.0d0) then expdamp = exp(-damp) dmpik(3) = 1.0d0 - expdamp dmpik(5) = 1.0d0 - expdamp*(1.0d0+damp) if (rorder .ge. 7) then damp2 = damp * damp dmpik(7) = 1.0d0 - expdamp*(1.0d0+damp+0.6d0*damp2) if (rorder .ge. 9) then damp3 = damp * damp2 dmpik(9) = 1.0d0 - expdamp*(1.0d0+damp & +(18.0d0/35.0d0)*damp2 & +(9.0d0/35.0d0)*damp3) end if end if end if end if end if return end c c c ################################################################ c ## ## c ## subroutine damppole -- penetration damping coefficents ## c ## ## c ################################################################ c c c "damppole" finds coefficients for two alternative Gordon charge c penetration damping function c c literature references: c c L. V. Slipchenko and M. S. Gordon, "Electrostatic Energy in the c Effective Fragment Potential Method: Theory and Application to c the Benzene Dimer", Journal of Computational Chemistry, 28, c 276-291 (2007) [Gordon f1 and f2 models] c c J. A. Rackers, Q. Wang, C. Liu, J.-P. Piquemal, P. Ren and c J. W. Ponder, "An Optimized Charge Penetration Model for Use with c the AMOEBA Force Field", Physical Chemistry Chemical Physics, 19, c 276-291 (2017) c c subroutine damppole (r,rorder,alphai,alphak,dmpi,dmpk,dmpik) use mplpot implicit none integer rorder real*8 termi,termk real*8 termi2,termk2 real*8 alphai,alphak real*8 alphai2,alphak2 real*8 r,eps,diff real*8 expi,expk real*8 dampi,dampk real*8 dampi2,dampi3 real*8 dampi4,dampi5 real*8 dampi6,dampi7 real*8 dampi8 real*8 dampk2,dampk3 real*8 dampk4,dampk5 real*8 dampk6 real*8 dmpi(*) real*8 dmpk(*) real*8 dmpik(*) c c c compute tolerance and exponential damping factors c eps = 0.001d0 diff = abs(alphai-alphak) dampi = alphai * r dampk = alphak * r expi = exp(-dampi) expk = exp(-dampk) c c core-valence charge penetration damping for Gordon f1 c if (pentyp .eq. 'GORDON1') then dampi2 = dampi * dampi dampi3 = dampi * dampi2 dampi4 = dampi2 * dampi2 dampi5 = dampi2 * dampi3 dmpi(1) = 1.0d0 - (1.0d0 + 0.5d0*dampi)*expi dmpi(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2)*expi dmpi(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0)*expi dmpi(7) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + dampi4/30.0d0)*expi dmpi(9) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + 4.0d0*dampi4/105.0d0 & + dampi5/210.0d0)*expi if (diff .lt. eps) then dmpk(1) = dmpi(1) dmpk(3) = dmpi(3) dmpk(5) = dmpi(5) dmpk(7) = dmpi(7) dmpk(9) = dmpi(9) else dampk2 = dampk * dampk dampk3 = dampk * dampk2 dampk4 = dampk2 * dampk2 dampk5 = dampk2 * dampk3 dmpk(1) = 1.0d0 - (1.0d0 + 0.5d0*dampk)*expk dmpk(3) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2)*expk dmpk(5) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2 & + dampk3/6.0d0)*expk dmpk(7) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2 & + dampk3/6.0d0 + dampk4/30.0d0)*expk dmpk(9) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2 & + dampk3/6.0d0 + 4.0d0*dampk4/105.0d0 & + dampk5/210.0d0)*expk end if c c valence-valence charge penetration damping for Gordon f1 c if (diff .lt. eps) then dampi6 = dampi3 * dampi3 dampi7 = dampi3 * dampi4 dmpik(1) = 1.0d0 - (1.0d0 + 11.0d0*dampi/16.0d0 & + 3.0d0*dampi2/16.0d0 & + dampi3/48.0d0)*expi dmpik(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + 7.0d0*dampi3/48.0d0 & + dampi4/48.0d0)*expi dmpik(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + dampi4/24.0d0 & + dampi5/144.0d0)*expi dmpik(7) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + dampi4/24.0d0 & + dampi5/120.0d0 + dampi6/720.0d0)*expi dmpik(9) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + dampi4/24.0d0 & + dampi5/120.0d0 + dampi6/720.0d0 & + dampi7/5040.0d0)*expi if (rorder .ge. 11) then dampi8 = dampi4 * dampi4 dmpik(11) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + dampi4/24.0d0 & + dampi5/120.0d0 + dampi6/720.0d0 & + dampi7/5040.0d0 + dampi8/45360.0d0)*expi end if else alphai2 = alphai * alphai alphak2 = alphak * alphak termi = alphak2 / (alphak2-alphai2) termk = alphai2 / (alphai2-alphak2) termi2 = termi * termi termk2 = termk * termk dmpik(1) = 1.0d0 - termi2*(1.0d0 + 2.0d0*termk & + 0.5d0*dampi)*expi & - termk2*(1.0d0 + 2.0d0*termi & + 0.5d0*dampk)*expk dmpik(3) = 1.0d0 - termi2*(1.0d0+dampi+0.5d0*dampi2)*expi & - termk2*(1.0d0+dampk+0.5d0*dampk2)*expk & - 2.0d0*termi2*termk*(1.0d0+dampi)*expi & - 2.0d0*termk2*termi*(1.0d0+dampk)*expk dmpik(5) = 1.0d0 - termi2*(1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0)*expi & - termk2*(1.0d0 + dampk + 0.5d0*dampk2 & + dampk3/6.0d0)*expk & - 2.0d0*termi2*termk & *(1.0d0 + dampi + dampi2/3.0d0)*expi & - 2.0d0*termk2*termi & *(1.0d0 + dampk + dampk2/3.0d0)*expk dmpik(7) = 1.0d0 - termi2*(1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + dampi4/30.0d0)*expi & - termk2*(1.0d0 + dampk + 0.5d0*dampk2 & + dampk3/6.0d0 + dampk4/30.0d0)*expk & - 2.0d0*termi2*termk*(1.0d0 + dampi & + 2.0d0*dampi2/5.0d0 + dampi3/15.0d0)*expi & - 2.0d0*termk2*termi*(1.0d0 + dampk & + 2.0d0*dampk2/5.0d0 + dampk3/15.0d0)*expk dmpik(9) = 1.0d0 - termi2*(1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + 4.0d0*dampi4/105.0d0 & + dampi5/210.0d0)*expi & - termk2*(1.0d0 + dampk + 0.5d0*dampk2 & + dampk3/6.0d0 + 4.0d0*dampk4/105.0d0 & + dampk5/210.0d0)*expk & - 2.0d0*termi2*termk*(1.0d0 + dampi & + 3.0d0*dampi2/7.0d0 & + 2.0d0*dampi3/21.0d0 & + dampi4/105.0d0)*expi & - 2.0d0*termk2*termi*(1.0d0 + dampk & + 3.0d0*dampk2/7.0d0 & + 2.0d0*dampk3/21.0d0 & + dampk4/105.0d0)*expk if (rorder .ge. 11) then dampi6 = dampi3 * dampi3 dampk6 = dampk3 * dampk3 dmpik(11) = 1.0d0 - termi2*(1.0d0 + dampi & + 0.5d0*dampi2 + dampi3/6.0d0 & + 5.0d0*dampi4/126.0d0 & + 2.0d0*dampi5/315.0d0 & + dampi6/1890.0d0)*expi & - termk2*(1.0d0 + dampk & + 0.5d0*dampk2 + dampk3/6.0d0 & + 5.0d0*dampk4/126.0d0 & + 2.0d0*dampk5/315.0d0 & + dampk6/1890.0d0)*expk & - 2.0d0*termi2*termk*(1.0d0 + dampi & + 4.0d0*dampi2/9.0d0 + dampi3/9.0d0 & + dampi4/63.0d0 + dampi5/945.0d0)*expi & - 2.0d0*termk2*termi*(1.0d0 + dampk & + 4.0d0*dampk2/9.0d0 + dampk3/9.0d0 & + dampk4/63.0d0 + dampk5/945.0d0)*expk end if end if c c core-valence charge penetration damping for Gordon f2 c else if (pentyp .eq. 'GORDON2') then dampi2 = dampi * dampi dampi3 = dampi * dampi2 dmpi(1) = 1.0d0 - expi dmpi(3) = 1.0d0 - (1.0d0 + dampi)*expi dmpi(5) = 1.0d0 - (1.0d0 + dampi + dampi2/3.0d0)*expi dmpi(7) = 1.0d0 - (1.0d0 + dampi + 0.4d0*dampi2 & + dampi3/15.0d0)*expi if (diff .lt. eps) then dmpk(1) = dmpi(1) dmpk(3) = dmpi(3) dmpk(5) = dmpi(5) dmpk(7) = dmpi(7) else dampk2 = dampk * dampk dampk3 = dampk * dampk2 dmpk(1) = 1.0d0 - expk dmpk(3) = 1.0d0 - (1.0d0 + dampk)*expk dmpk(5) = 1.0d0 - (1.0d0 + dampk + dampk2/3.0d0)*expk dmpk(7) = 1.0d0 - (1.0d0 + dampk + 0.4d0*dampk2 & + dampk3/15.0d0)*expk end if c c valence-valence charge penetration damping for Gordon f2 c dampi4 = dampi2 * dampi2 dampi5 = dampi2 * dampi3 if (diff .lt. eps) then dampi6 = dampi3 * dampi3 dmpik(1) = 1.0d0 - (1.0d0 + 0.5d0*dampi)*expi dmpik(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2)*expi dmpik(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0)*expi dmpik(7) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + dampi4/30.0d0)*expi dmpik(9) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + 4.0d0*dampi4/105.0d0 & + dampi5/210.0d0)*expi if (rorder .ge. 11) then dmpik(11) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + 5.0d0*dampi4/126.0d0 & + 2.0d0*dampi5/315.0d0 & + dampi6/1890.0d0)*expi end if else dampk4 = dampk2 * dampk2 dampk5 = dampk2 * dampk3 alphai2 = alphai * alphai alphak2 = alphak * alphak termi = alphak2 / (alphak2-alphai2) termk = alphai2 / (alphai2-alphak2) dmpik(1) = 1.0d0 - termi*expi - termk*expk dmpik(3) = 1.0d0 - termi*(1.0d0 + dampi)*expi & - termk*(1.0d0 + dampk)*expk dmpik(5) = 1.0d0 - termi*(1.0d0 + dampi + dampi2/3.0d0)*expi & - termk*(1.0d0 + dampk + dampk2/3.0d0)*expk dmpik(7) = 1.0d0 - termi*(1.0d0 + dampi + 0.4d0*dampi2 & + dampi3/15.0d0)*expi & - termk*(1.0d0 + dampk + 0.4d0*dampk2 & + dampk3/15.0d0)*expk dmpik(9) = 1.0d0 - termi*(1.0d0 + dampi + 3.0d0*dampi2/7.0d0 & + 2.0d0*dampi3/21.0d0 + dampi4/105.0d0)*expi & - termk*(1.0d0 + dampk + 3.0d0*dampk2/7.0d0 & + 2.0d0*dampk3/21.0d0 + dampk4/105.0d0)*expk if (rorder .ge. 11) then dmpik(11) = 1.0d0 - termi*(1.0d0 + dampi & + 4.0d0*dampi2/9.0d0 + dampi3/9.0d0 & + dampi4/63.0d0 + dampi5/945.0d0)*expi & - termk*(1.0d0 + dampk & + 4.0d0*dampk2/9.0d0 + dampk3/9.0d0 & + dampk4/63.0d0 + dampk5/945.0d0)*expk end if end if end if return end c c c ################################################################ c ## ## c ## subroutine dampdir -- direct field damping coefficents ## c ## ## c ################################################################ c c c "dampdir" finds coefficients for two alternative Gordon direct c field damping functions c c subroutine dampdir (r,alphai,alphak,dmpi,dmpk) use mplpot implicit none real*8 alphai,alphak real*8 r,eps,diff real*8 expi,expk real*8 dampi,dampk real*8 dampi2,dampk2 real*8 dampi3,dampk3 real*8 dampi4,dampk4 real*8 dmpi(*) real*8 dmpk(*) c c c compute tolerance and exponential damping factors c eps = 0.001d0 diff = abs(alphai-alphak) dampi = alphai * r dampk = alphak * r expi = exp(-dampi) expk = exp(-dampk) c c core-valence charge penetration damping for Gordon f1 c if (pentyp .eq. 'GORDON1') then dampi2 = dampi * dampi dampi3 = dampi * dampi2 dampi4 = dampi2 * dampi2 dmpi(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2)*expi dmpi(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0)*expi dmpi(7) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + dampi4/30.0d0)*expi if (diff .lt. eps) then dmpk(3) = dmpi(3) dmpk(5) = dmpi(5) dmpk(7) = dmpi(7) else dampk2 = dampk * dampk dampk3 = dampk * dampk2 dampk4 = dampk2 * dampk2 dmpk(3) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2)*expk dmpk(5) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2 & + dampk3/6.0d0)*expk dmpk(7) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2 & + dampk3/6.0d0 + dampk4/30.0d0)*expk end if c c core-valence charge penetration damping for Gordon f2 c else if (pentyp .eq. 'GORDON2') then dampi2 = dampi * dampi dampi3 = dampi * dampi2 dmpi(3) = 1.0d0 - (1.0d0 + dampi)*expi dmpi(5) = 1.0d0 - (1.0d0 + dampi + dampi2/3.0d0)*expi dmpi(7) = 1.0d0 - (1.0d0 + dampi + 0.4d0*dampi2 & + dampi3/15.0d0)*expi if (diff .lt. eps) then dmpk(3) = dmpi(3) dmpk(5) = dmpi(5) dmpk(7) = dmpi(7) else dampk2 = dampk * dampk dampk3 = dampk * dampk2 dmpk(3) = 1.0d0 - (1.0d0 + dampk)*expk dmpk(5) = 1.0d0 - (1.0d0 + dampk + dampk2/3.0d0)*expk dmpk(7) = 1.0d0 - (1.0d0 + dampk + 0.4d0*dampk2 & + dampk3/15.0d0)*expk end if end if return end c c c ################################################################ c ## ## c ## subroutine dampmut -- mutual field damping coefficents ## c ## ## c ################################################################ c c c "dampmut" finds coefficients for two alternative Gordon mutual c field damping functions c c subroutine dampmut (r,alphai,alphak,dmpik) use mplpot implicit none real*8 termi,termk real*8 termi2,termk2 real*8 alphai,alphak real*8 alphai2,alphak2 real*8 r,eps,diff real*8 expi,expk real*8 dampi,dampk real*8 dampi2,dampi3 real*8 dampi4,dampi5 real*8 dampk2,dampk3 real*8 dmpik(*) c c c compute tolerance and exponential damping factors c eps = 0.001d0 diff = abs(alphai-alphak) dampi = alphai * r dampk = alphak * r expi = exp(-dampi) expk = exp(-dampk) c c valence-valence charge penetration damping for Gordon f1 c if (pentyp .eq. 'GORDON1') then dampi2 = dampi * dampi dampi3 = dampi * dampi2 if (diff .lt. eps) then dampi4 = dampi2 * dampi2 dampi5 = dampi2 * dampi3 dmpik(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + 7.0d0*dampi3/48.0d0 & + dampi4/48.0d0)*expi dmpik(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0 + dampi4/24.0d0 & + dampi5/144.0d0)*expi else dampk2 = dampk * dampk dampk3 = dampk * dampk2 alphai2 = alphai * alphai alphak2 = alphak * alphak termi = alphak2 / (alphak2-alphai2) termk = alphai2 / (alphai2-alphak2) termi2 = termi * termi termk2 = termk * termk dmpik(3) = 1.0d0 - termi2*(1.0d0+dampi+0.5d0*dampi2)*expi & - termk2*(1.0d0+dampk+0.5d0*dampk2)*expk & - 2.0d0*termi2*termk*(1.0d0+dampi)*expi & - 2.0d0*termk2*termi*(1.0d0+dampk)*expk dmpik(5) = 1.0d0 - termi2*(1.0d0+dampi+0.5d0*dampi2 & +dampi3/6.0d0)*expi & - termk2*(1.0d0+dampk+0.5d0*dampk2 & +dampk3/6.00)*expk & - 2.0d0*termi2*termk & *(1.0+dampi+dampi2/3.0d0)*expi & - 2.0d0*termk2*termi & *(1.0+dampk+dampk2/3.0d0)*expk end if c c valence-valence charge penetration damping for Gordon f2 c else if (pentyp .eq. 'GORDON2') then dampi2 = dampi * dampi if (diff .lt. eps) then dampi3 = dampi * dampi2 dmpik(3) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2)*expi dmpik(5) = 1.0d0 - (1.0d0 + dampi + 0.5d0*dampi2 & + dampi3/6.0d0)*expi else dampk2 = dampk * dampk alphai2 = alphai * alphai alphak2 = alphak * alphak termi = alphak2 / (alphak2-alphai2) termk = alphai2 / (alphai2-alphak2) dmpik(3) = 1.0d0 - termi*(1.0d0 + dampi)*expi & - termk*(1.0d0 + dampk)*expk dmpik(5) = 1.0d0 - termi*(1.0d0 + dampi + dampi2/3.0d0)*expi & - termk*(1.0d0 + dampk + dampk2/3.0d0)*expk end if end if return end c c c ############################################################### c ## ## c ## subroutine damppot -- electrostatic potential damping ## c ## ## c ############################################################### c c c "damppot" finds coefficients for two alternative Gordon charge c penetration damping functions for the electrostatic potential c c subroutine damppot (r,alphak,dmpk) use mplpot implicit none real*8 r,alphak real*8 expk,dampk real*8 dampk2,dampk3 real*8 dmpk(*) c c c compute common exponential factors for damping c dampk = alphak * r expk = exp(-dampk) c c core-valence charge penetration damping for Gordon f1 c if (pentyp .eq. 'GORDON1') then dampk2 = dampk * dampk dampk3 = dampk * dampk2 dmpk(1) = 1.0d0 - (1.0d0 + 0.5d0*dampk)*expk dmpk(3) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2)*expk dmpk(5) = 1.0d0 - (1.0d0 + dampk + 0.5d0*dampk2 & + dampk3/6.0d0)*expk c c core-valence charge penetration damping for Gordon f2 c else if (pentyp .eq. 'GORDON2') then dampk2 = dampk * dampk dmpk(1) = 1.0d0 - expk dmpk(3) = 1.0d0 - (1.0d0 + dampk)*expk dmpk(5) = 1.0d0 - (1.0d0 + dampk + dampk2/3.0d0)*expk end if return end c c c ################################################################ c ## ## c ## subroutine damprep -- Pauli exchange repulsion damping ## c ## ## c ################################################################ c c c "damprep" finds coefficients for the Pauli repulsion damping c function used by HIPPO c c literature reference: c c J. A. Rackers and J. W. Ponder, "Classical Pauli Repulsion: An c Anisotropic, Atomic Multipole Model", Journal of Chemical Physics, c 150, 084104 (2019) c c subroutine damprep (r,r2,rr1,rr3,rr5,rr7,rr9,rr11, & rorder,dmpi,dmpk,dmpik) implicit none integer rorder real*8 r,r2,r3,r4 real*8 r5,r6,r7,r8 real*8 rr1,rr3,rr5 real*8 rr7,rr9,rr11 real*8 s,ds,d2s real*8 d3s,d4s,d5s real*8 dmpi,dmpk real*8 dmpi2,dmpk2 real*8 dmpi22,dmpi23 real*8 dmpi24,dmpi25 real*8 dmpi26,dmpi27 real*8 dmpk22,dmpk23 real*8 dmpk24,dmpk25 real*8 dmpk26 real*8 eps,diff real*8 expi,expk real*8 dampi,dampk real*8 pre,term,tmp real*8 dmpik(*) c c c compute tolerance value for damping exponents c eps = 0.001d0 diff = abs(dmpi-dmpk) c c treat the case where alpha damping exponents are equal c if (diff .lt. eps) then r3 = r2 * r r4 = r3 * r r5 = r4 * r r6 = r5 * r dmpi2 = 0.5d0 * dmpi dampi = dmpi2 * r expi = exp(-dampi) dmpi22 = dmpi2 * dmpi2 dmpi23 = dmpi22 * dmpi2 dmpi24 = dmpi23 * dmpi2 dmpi25 = dmpi24 * dmpi2 pre = 2.0d0 s = (r + dmpi2*r2 + dmpi22*r3/3.0d0) * expi ds = (dmpi22*r3 + dmpi23*r4) * expi / 3.0d0 d2s = dmpi24 * expi * r5 / 9.0d0 d3s = dmpi25 * expi * r6 / 45.0d0 if (rorder .ge. 9) then r7 = r6 * r dmpi26 = dmpi25 * dmpi2 d4s = (dmpi25*r6 + dmpi26*r7) * expi / 315.0d0 if (rorder .ge. 11) then r8 = r7 * r dmpi27 = dmpi2 * dmpi26 d5s = (dmpi25*r6 + dmpi26*r7 + dmpi27*r8/3.0d0) & * expi / 945.0d0 end if end if c c treat the case where alpha damping exponents are unequal c else r3 = r2 * r r4 = r3 * r dmpi2 = 0.5d0 * dmpi dmpk2 = 0.5d0 * dmpk dampi = dmpi2 * r dampk = dmpk2 * r expi = exp(-dampi) expk = exp(-dampk) dmpi22 = dmpi2 * dmpi2 dmpi23 = dmpi22 * dmpi2 dmpi24 = dmpi23 * dmpi2 dmpk22 = dmpk2 * dmpk2 dmpk23 = dmpk22 * dmpk2 dmpk24 = dmpk23 * dmpk2 term = dmpi22 - dmpk22 pre = 128.0d0 * dmpi23 * dmpk23 / term**4 tmp = 4.0d0 * dmpi2 * dmpk2 / term s = (dampi-tmp)*expk + (dampk+tmp)*expi ds = (dmpi2*dmpk2*r2 - 4.0d0*dmpi2*dmpk22*r/term & - 4.0d0*dmpi2*dmpk2/term) * expk & + (dmpi2*dmpk2*r2 + 4.0d0*dmpi22*dmpk2*r/term & + 4.0d0*dmpi2*dmpk2/term) * expi d2s = (dmpi2*dmpk2*r2/3.0d0 & + dmpi2*dmpk22*r3/3.0d0 & - (4.0d0/3.0d0)*dmpi2*dmpk23*r2/term & - 4.0d0*dmpi2*dmpk22*r/term & - 4.0d0*dmpi2*dmpk2/term) * expk & + (dmpi2*dmpk2*r2/3.0d0 & + dmpi22*dmpk2*r3/3.0d0 & + (4.0d0/3.0d0)*dmpi23*dmpk2*r2/term & + 4.0d0*dmpi22*dmpk2*r/term & + 4.0d0*dmpi2*dmpk2/term) * expi d3s = (dmpi2*dmpk23*r4/15.0d0 & + dmpi2*dmpk22*r3/5.0d0 & + dmpi2*dmpk2*r2/5.0d0 & - (4.0d0/15.0d0)*dmpi2*dmpk24*r3/term & - (8.0d0/5.0d0)*dmpi2*dmpk23*r2/term & - 4.0d0*dmpi2*dmpk22*r/term & - 4.0d0/term*dmpi2*dmpk2) * expk & + (dmpi23*dmpk2*r4/15.0d0 & + dmpi22*dmpk2*r3/5.0d0 & + dmpi2*dmpk2*r2/5.0d0 & + (4.0d0/15.0d0)*dmpi24*dmpk2*r3/term & + (8.0d0/5.0d0)*dmpi23*dmpk2*r2/term & + 4.0d0*dmpi22*dmpk2*r/term & + 4.0d0/term*dmpi2*dmpk2) * expi if (rorder .ge. 9) then r5 = r4 * r dmpi25 = dmpi24 * dmpi2 dmpk25 = dmpk24 * dmpk2 d4s = (dmpi2*dmpk24*r5/105.0d0 & + (2.0d0/35.0d0)*dmpi2*dmpk23*r4 & + dmpi2*dmpk22*r3/7.0d0 & + dmpi2*dmpk2*r2/7.0d0 & - (4.0d0/105.0d0)*dmpi2*dmpk25*r4/term & - (8.0d0/21.0d0)*dmpi2*dmpk24*r3/term & - (12.0d0/7.0d0)*dmpi2*dmpk23*r2/term & - 4.0d0*dmpi2*dmpk22*r/term & - 4.0d0*dmpi2*dmpk2/term) * expk & + (dmpi24*dmpk2*r5/105.0d0 & + (2.0d0/35.0d0)*dmpi23*dmpk2*r4 & + dmpi22*dmpk2*r3/7.0d0 & + dmpi2*dmpk2*r2/7.0d0 & + (4.0d0/105.0d0)*dmpi25*dmpk2*r4/term & + (8.0d0/21.0d0)*dmpi24*dmpk2*r3/term & + (12.0d0/7.0d0)*dmpi23*dmpk2*r2/term & + 4.0d0*dmpi22*dmpk2*r/term & + 4.0d0*dmpi2*dmpk2/term) * expi if (rorder .ge. 11) then r6 = r5 * r dmpi26 = dmpi25 * dmpi2 dmpk26 = dmpk25 * dmpk2 d5s = (dmpi2*dmpk25*r6/945.0d0 & + (2.0d0/189.0d0)*dmpi2*dmpk24*r5 & + dmpi2*dmpk23*r4/21.0d0 & + dmpi2*dmpk22*r3/9.0d0 & + dmpi2*dmpk2*r2/9.0d0 & - (4.0d0/945.0d0)*dmpi2*dmpk26*r5/term & - (4.0d0/63.0d0)*dmpi2*dmpk25*r4/term & - (4.0d0/9.0d0)*dmpi2*dmpk24*r3/term & - (16.0d0/9.0d0)*dmpi2*dmpk23*r2/term & - 4.0d0*dmpi2*dmpk22*r/term & - 4.0d0*dmpi2*dmpk2/term) * expk & + (dmpi25*dmpk2*r6/945.0d0 & + (2.0d0/189.0d0)*dmpi24*dmpk2*r5 & + dmpi23*dmpk2*r4/21.0d0 & + dmpi22*dmpk2*r3/9.0d0 & + dmpi2*dmpk2*r2/9.0d0 & + (4.0d0/945.0d0)*dmpi26*dmpk2*r5/term & + (4.0d0/63.0d0)*dmpi25*dmpk2*r4/term & + (4.0d0/9.0d0)*dmpi24*dmpk2*r3/term & + (16.0d0/9.0d0)*dmpi23*dmpk2*r2/term & + 4.0d0*dmpi22*dmpk2*r/term & + 4.0d0*dmpi2*dmpk2/term) * expi end if end if end if c c convert partial derivatives into full derivatives c s = s * rr1 ds = ds * rr3 d2s = d2s * rr5 d3s = d3s * rr7 dmpik(1) = 0.5d0 * pre * s * s dmpik(3) = pre * s * ds dmpik(5) = pre * (s*d2s + ds*ds) dmpik(7) = pre * (s*d3s + 3.0d0*ds*d2s) if (rorder .ge. 9) then d4s = d4s * rr9 dmpik(9) = pre * (s*d4s + 4.0d0*ds*d3s + 3.0d0*d2s*d2s) if (rorder .ge. 11) then d5s = d5s * rr11 dmpik(11) = pre * (s*d5s + 5.0d0*ds*d4s + 10.0d0*d2s*d3s) end if end if return end c c c ############################################################## c ## ## c ## subroutine dampexpl -- exchange polarization damping ## c ## ## c ############################################################## c c c "dampexpl" finds the overlap value for exchange polarization c damping function c c subroutine dampexpl (r,preik,alphai,alphak,s2,ds2) use polpot implicit none real*8 r,s,s2,ds2 real*8 alphai,alphak real*8 alphaik real*8 dmpi2,dmpk2 real*8 dmpi22,dmpk22 real*8 dmpik2 real*8 dampik,dampik2 real*8 eps,diff real*8 expi,expk,expik real*8 dampi,dampk,dampi2 real*8 pre,term,preik c c if (scrtyp .eq. 'S2U') then alphaik = sqrt(alphai * alphak) dmpik2 = 0.5d0 * alphaik dampik = dmpik2 * r dampik2 = dampik * dampik expik = exp(-dampik) s =(1+dampik+dampik2/3.0d0)*expik s2 = s*s ds2 = s * (-alphaik/3.0d0)*(dampik+dampik2)*expik c c compute tolerance value for overlap-based damping c else if (scrtyp .eq. 'S2 ') then eps = 0.001d0 diff = abs(alphai-alphak) c c treat the case where alpha damping exponents are equal c if (diff .lt. eps) then dmpi2 = 0.5d0 * alphai dampi = dmpi2 * r dampi2 = dampi * dampi expi = exp(-dampi) s = (1+dampi+dampi2/3.0d0)*expi ds2 = s * (-alphai/3.0d0)*(dampi+dampi2)*expi c c treat the case where alpha damping exponents are unequal c else dmpi2 = 0.5d0 * alphai dmpk2 = 0.5d0 * alphak dampi = dmpi2 * r dampk = dmpk2 * r expi = exp(-dampi) expk = exp(-dampk) dmpi22 = dmpi2 * dmpi2 dmpk22 = dmpk2 * dmpk2 term = dmpi22 - dmpk22 pre = sqrt(alphai**3 * alphak**3) / (r * term**3) s = pre*(dmpi2*(r*term - 4*dmpk2) * expk & + dmpk2*(r*term + 4*dmpi2) * expi) ds2 = 2.0d0*s*pre*dmpi2*dmpk2 * & ((4.0d0/r-(r*term-4.0d0*dmpk2))*expk & - ((4.0d0/r+(r*term+4.0d0*dmpi2))*expi)) end if s2 = s*s c c use simple gaussian-based damping functions c else if (scrtyp .eq. 'G ') then alphaik = sqrt(alphai * alphak) s2 = exp(-alphaik/10.0d0 * r**2) ds2 = (-alphaik/5.0d0)*r*s2 end if s2 = preik*s2 ds2 = preik*ds2 return end c c c ########################################################## c ## COPYRIGHT (C) 2020 by Chengwen Liu & Jay W. Ponder ## c ## All Rights Reserved ## c ########################################################## c c ############################################################## c ## ## c ## subroutine dcflux -- charge flux gradient chain rule ## c ## ## c ############################################################## c c c "dcflux" takes as input the electrostatic potential at each c atomic site and calculates gradient chain rule terms due to c charge flux coupling with bond stretching and angle bending c c literature reference: c c C. Liu, J.-P. Piquemal and P. Ren, "Implementation of Geometry- c Dependent Charge Flux into the Polarizable AMOEBA+ Potential", c Journal of Physical Chemistry Letters, 11, 419-426 (2020) c c subroutine dcflux (pot,dcfx,dcfy,dcfz) use sizes use angbnd use atoms use bndstr use bound use cflux implicit none integer i,ia,ib,ic real*8 xa,ya,za real*8 xb,yb,zb real*8 xc,yc,zc real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 rab,rab2,rab3 real*8 rcb,rcb2,rcb3 real*8 dpot,dpota,dpotc real*8 fx,fy,fz real*8 fxa1,fya1,fza1 real*8 fxb1,fyb1,fzb1 real*8 fxc1,fyc1,fzc1 real*8 fxa2,fya2,fza2 real*8 fxb2,fyb2,fzb2 real*8 fxc2,fyc2,fzc2 real*8 pb,pb1,pb2 real*8 pa1,pa2 real*8 eps,dot real*8 rabc,dra3,drc3 real*8 term,fterm real*8 termxa,termxc real*8 termya,termyc real*8 termza,termzc real*8 pot(*) real*8 dcfx(*) real*8 dcfy(*) real*8 dcfz(*) c c c zero out the charge flux correction forces c do i = 1, n dcfx(i) = 0.0d0 dcfy(i) = 0.0d0 dcfz(i) = 0.0d0 end do c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c calculate the charge flux forces due to bond stretches c do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) pb = bflx(i) xa = x(ia) ya = y(ia) za = z(ia) xb = x(ib) yb = y(ib) zb = z(ib) xab = xa - xb yab = ya - yb zab = za - zb if (use_polymer) call image (xab,yab,zab) rab2 = max(xab*xab+yab*yab+zab*zab,eps) dpot = pot(ib) - pot(ia) pb = pb * dpot / sqrt(rab2) fx = pb * xab fy = pb * yab fz = pb * zab dcfx(ia) = dcfx(ia) + fx dcfy(ia) = dcfy(ia) + fy dcfz(ia) = dcfz(ia) + fz dcfx(ib) = dcfx(ib) - fx dcfy(ib) = dcfy(ib) - fy dcfz(ib) = dcfz(ib) - fz end do c c calculate the charge flux forces due to angle bends c do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) pa1 = aflx(1,i) pa2 = aflx(2,i) pb1 = abflx(1,i) pb2 = abflx(2,i) xa = x(ia) ya = y(ia) za = z(ia) xb = x(ib) yb = y(ib) zb = z(ib) xc = x(ic) yc = y(ic) zc = z(ic) xab = xa - xb yab = ya - yb zab = za - zb xcb = xc - xb ycb = yc - yb zcb = zc - zb if (use_polymer) then call image (xab,yab,zab) call image (xcb,ycb,zcb) end if rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) rab = sqrt(rab2) rcb = sqrt(rcb2) c c get terms corresponding to asymmetric bond stretches c dpota = pot(ia) - pot(ib) dpotc = pot(ic) - pot(ib) pb1 = dpota * pb1 pb2 = dpotc * pb2 fxa1 = pb2 * xab/rab fya1 = pb2 * yab/rab fza1 = pb2 * zab/rab fxc1 = pb1 * xcb/rcb fyc1 = pb1 * ycb/rcb fzc1 = pb1 * zcb/rcb fxb1 = -fxa1 - fxc1 fyb1 = -fya1 - fyc1 fzb1 = -fza1 - fzc1 c c get terms corresponding to bond angle bending c rabc = rab * rcb rab3 = rab2 * rab rcb3 = rcb2 * rcb dot = xab*xcb + yab*ycb + zab*zcb dra3 = dot / (rab3*rcb) drc3 = dot / (rab*rcb3) term = -rabc / max(sqrt(rab2*rcb2-dot*dot),eps) fterm = term * (dpota*pa1+dpotc*pa2) termxa = xcb/rabc - xab*dra3 termya = ycb/rabc - yab*dra3 termza = zcb/rabc - zab*dra3 termxc = xab/rabc - xcb*drc3 termyc = yab/rabc - ycb*drc3 termzc = zab/rabc - zcb*drc3 fxa2 = fterm * termxa fya2 = fterm * termya fza2 = fterm * termza fxc2 = fterm * termxc fyc2 = fterm * termyc fzc2 = fterm * termzc fxb2 = -fxa2 - fxc2 fyb2 = -fya2 - fyc2 fzb2 = -fza2 - fzc2 dcfx(ia) = dcfx(ia) + fxa1 + fxa2 dcfy(ia) = dcfy(ia) + fya1 + fya2 dcfz(ia) = dcfz(ia) + fza1 + fza2 dcfx(ib) = dcfx(ib) + fxb1 + fxb2 dcfy(ib) = dcfy(ib) + fyb1 + fyb2 dcfz(ib) = dcfz(ib) + fzb1 + fzb2 dcfx(ic) = dcfx(ic) + fxc1 + fxc2 dcfy(ic) = dcfy(ic) + fyc1 + fyc2 dcfz(ic) = dcfz(ic) + fzc1 + fzc2 end do return end c c c ################################################### c ## COPYRIGHT (C) 1996 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine deflate -- eigenvalues by method of deflation ## c ## ## c ################################################################## c c c "deflate" uses the power method with deflation to compute the c few largest eigenvalues and eigenvectors of a symmetric matrix c c n dimension of the matrix to be diagonalized c nv number of largest eigenvalues to be extracted c a input with the matrix to be diagonalized; only c the lower triangle and diagonal are required c ev returned with the eigenvalues in descending order c vec returned with the eigenvectors of the matrix c work local vector containing temporary work space c c subroutine deflate (n,nv,a,ev,vec) use iounit implicit none integer i,j,k,n,nv integer iter,maxiter real*8 random,eps real*8 dot1,dot2,ratio real*8 ev(*) real*8, allocatable :: work(:) real*8 a(n,*) real*8 vec(n,*) external random c c c initialize number of iterations and convergence criteria c maxiter = 500 eps = 1.0d-6 c c use identity vector as initial guess for eigenvectors c do j = 1, nv do i = 1, n vec(i,j) = 1.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (work(n)) c c find the few largest eigenvalues and eigenvectors c do k = 1, nv ev(k) = 0.0d0 dot1 = 0.0d0 do i = 1, n work(i) = 0.0d0 do j = 1, i-1 work(i) = work(i) + a(i,j)*vec(j,k) end do do j = i, n work(i) = work(i) + a(j,i)*vec(j,k) end do dot1 = dot1 + work(i)**2 end do c c if in or near null space, use random guess as eigenvector c if (dot1 .le. 100.0d0*eps*dble(n)) then do i = 1, n work(i) = random () end do end if c c find the current eigenvalue by iterating to convergence; c first multiply vector by matrix and compute dot products c do iter = 1, maxiter dot1 = 0.0d0 dot2 = 0.0d0 do i = 1, n vec(i,k) = 0.0d0 do j = 1, i-1 vec(i,k) = vec(i,k) + a(i,j)*work(j) end do do j = i, n vec(i,k) = vec(i,k) + a(j,i)*work(j) end do dot1 = dot1 + vec(i,k)**2 dot2 = dot2 + vec(i,k)*work(i) end do c c normalize new eigenvector and substitute for old one c ratio = abs((ev(k)-dot2) / dot2) ev(k) = dot2 dot1 = sqrt(dot1) do i = 1, n vec(i,k) = vec(i,k) / dot1 work(i) = vec(i,k) end do if (ratio .lt. eps) goto 20 end do write (iout,10) k 10 format (/,' DEFLATE -- Eigenvalue',i3,' not Fully Converged') c c eliminate the current eigenvalue from the matrix c 20 continue do i = 1, n do j = i, n a(j,i) = a(j,i) - ev(k)*vec(i,k)*vec(j,k) end do end do end do c c perform deallocation of some local arrays c deallocate (work) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine delete -- remove atom from coordinates list ## c ## ## c ################################################################ c c c "delete" removes a specified atom from the Cartesian c coordinates list and shifts the remaining atoms c c subroutine delete (iatom) use atomid use atoms use couple use inform use iounit implicit none integer i,j,k,m,iatom c c c reduce by one the total number of atoms c n = n - 1 c c shift the atom coordinates, types and connectivities c do i = iatom, n name(i) = name(i+1) x(i) = x(i+1) y(i) = y(i+1) z(i) = z(i+1) type(i) = type(i+1) n12(i) = n12(i+1) do j = 1, n12(i) i12(j,i) = i12(j,i+1) end do end do c c remove connections to deleted atom and shift the lists c do i = 1, n m = 0 do j = 1, n12(i) if (i12(j,i) .eq. iatom) then m = m + 1 do k = j, n12(i)-1 i12(k,i) = i12(k+1,i) end do end if end do n12(i) = n12(i) - m do j = 1, n12(i) if (i12(j,i) .gt. iatom) i12(j,i) = i12(j,i) - 1 end do end do c c write a message to describe the atom deletion c if (debug) then write (iout,10) iatom 10 format (' DELETE -- Deleting Atom Number :',i9) end if return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module deriv -- Cartesian coord derivative components ## c ## ## c ############################################################### c c c desum total energy Cartesian coordinate derivatives c deb bond stretch Cartesian coordinate derivatives c dea angle bend Cartesian coordinate derivatives c deba stretch-bend Cartesian coordinate derivatives c deub Urey-Bradley Cartesian coordinate derivatives c deaa angle-angle Cartesian coordinate derivatives c deopb out-of-plane bend Cartesian coordinate derivatives c deopd out-of-plane distance Cartesian coordinate derivatives c deid improper dihedral Cartesian coordinate derivatives c deit improper torsion Cartesian coordinate derivatives c det torsional Cartesian coordinate derivatives c dept pi-system torsion Cartesian coordinate derivatives c debt stretch-torsion Cartesian coordinate derivatives c deat angle-torsion Cartesian coordinate derivatives c dett torsion-torsion Cartesian coordinate derivatives c dev van der Waals Cartesian coordinate derivatives c der Pauli repulsion Cartesian coordinate derivatives c dedsp damped dispersion Cartesian coordinate derivatives c dec charge-charge Cartesian coordinate derivatives c decd charge-dipole Cartesian coordinate derivatives c ded dipole-dipole Cartesian coordinate derivatives c dem multipole Cartesian coordinate derivatives c dep polarization Cartesian coordinate derivatives c dect charge transfer Cartesian coordinate derivatives c derxf reaction field Cartesian coordinate derivatives c des solvation Cartesian coordinate derivatives c delf metal ligand field Cartesian coordinate derivatives c deg geometric restraint Cartesian coordinate derivatives c dex extra energy term Cartesian coordinate derivatives c c module deriv implicit none real*8, allocatable :: desum(:,:) real*8, allocatable :: deb(:,:) real*8, allocatable :: dea(:,:) real*8, allocatable :: deba(:,:) real*8, allocatable :: deub(:,:) real*8, allocatable :: deaa(:,:) real*8, allocatable :: deopb(:,:) real*8, allocatable :: deopd(:,:) real*8, allocatable :: deid(:,:) real*8, allocatable :: deit(:,:) real*8, allocatable :: det(:,:) real*8, allocatable :: dept(:,:) real*8, allocatable :: debt(:,:) real*8, allocatable :: deat(:,:) real*8, allocatable :: dett(:,:) real*8, allocatable :: dev(:,:) real*8, allocatable :: der(:,:) real*8, allocatable :: dedsp(:,:) real*8, allocatable :: dec(:,:) real*8, allocatable :: decd(:,:) real*8, allocatable :: ded(:,:) real*8, allocatable :: dem(:,:) real*8, allocatable :: dep(:,:) real*8, allocatable :: dect(:,:) real*8, allocatable :: derxf(:,:) real*8, allocatable :: des(:,:) real*8, allocatable :: delf(:,:) real*8, allocatable :: deg(:,:) real*8, allocatable :: dex(:,:) save end c c c ################################################################ c ## COPYRIGHT (C) 2022 by Moses Chung, Zhi Wang & Jay Ponder ## c ## All Rights Reserved ## c ################################################################ c c ################################################################# c ## ## c ## subroutine dexpol -- variable polarizability chain rule ## c ## ## c ################################################################# c c c "dexpol" computes the chain rule terms to account for variable c polarizability in exchange polarization c c literature reference: c c M. K. J. Chung, Z. Wang, J. A. Rackers and J. W. Ponder, c "Classical Exchange Polarization: An Anisotropic Variable c Polarizability Model", Journal of Physical Chemistry B, 126, c 7579-7594 (2022) c c subroutine dexpol use limits implicit none c c c choose the method for summing over pairwise interactions c if (use_mlist) then call dexpol1b else call dexpol1a end if return end c c c ############################################################### c ## ## c ## subroutine dexpol1a -- exch-polar chain rule via loop ## c ## ## c ############################################################### c c c "dexpol1a" finds variable polarizability chain rule gradient c components due to exchange polarization using a double loop c c subroutine dexpol1a use atoms use bound use cell use chgpot use couple use deriv use expol use mpole use polar use polgrp use polpot use shunt use units use virial implicit none integer i,j,k integer ii,kk integer jcell real*8 xi,yi,zi real*8 xr,yr,zr real*8 r,r2,r3,r4,r5 real*8 sizi,sizk,sizik real*8 alphai,alphak real*8 springi,springk real*8 f,s2,ds2 real*8 s2i,s2k real*8 ds2i,ds2k real*8 taper,dtaper real*8 uix,uiy,uiz real*8 ukx,uky,ukz real*8 uixl,ukxl real*8 uiyl,ukyl real*8 uizl,ukzl real*8 vxx,vyy,vzz real*8 vxy,vxz,vyz real*8 frcil(3) real*8 frckl(3) real*8 frcxi,frcyi,frczi real*8 frcxk,frcyk,frczk real*8 frcx,frcy,frcz real*8 tqxil,tqyil real*8 tqxkl,tqykl real*8 ai(3,3) real*8 ak(3,3) real*8, allocatable :: pscale(:) logical epli,eplk character*6 mode c c c perform dynamic allocation of some local arrays c allocate (pscale(n)) c c set conversion factor, cutoff and switching coefficients c f = 0.5d0 * electric / dielec mode = 'REPULS' call switch (mode) c c set array needed to scale atom and group interactions c do i = 1, n pscale(i) = 1.0d0 end do c c find the exchange polarization gradient c do ii = 1, npole-1 i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) springi = kpep(i) / polarity(i) sizi = prepep(i) alphai = dmppep(i) epli = lpep(i) uix = uind(1,i) uiy = uind(2,i) uiz = uind(3,i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = p2scale do k = 1, np11(i) if (i12(j,i) .eq. ip11(k,i)) & pscale(i12(j,i)) = p2iscale end do end do do j = 1, n13(i) pscale(i13(j,i)) = p3scale do k = 1, np11(i) if (i13(j,i) .eq. ip11(k,i)) & pscale(i13(j,i)) = p3iscale end do end do do j = 1, n14(i) pscale(i14(j,i)) = p4scale do k = 1, np11(i) if (i14(j,i) .eq. ip11(k,i)) & pscale(i14(j,i)) = p4iscale end do end do do j = 1, n15(i) pscale(i15(j,i)) = p5scale do k = 1, np11(i) if (i15(j,i) .eq. ip11(k,i)) & pscale(i15(j,i)) = p5iscale end do end do c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) eplk = lpep(k) if (epli .or. eplk) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) springk = kpep(k) / polarity(k) sizk = prepep(k) alphak = dmppep(k) sizik = sizi * sizk ukx = uind(1,k) uky = uind(2,k) ukz = uind(3,k) call dampexpl (r,sizik,alphai,alphak,s2,ds2) c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 ds2 = ds2*taper + s2*dtaper s2 = s2 * taper end if s2i = springi * s2 * pscale(k) s2k = springk * s2 * pscale(k) ds2i = springi * ds2 * pscale(k) ds2k = springk * ds2 * pscale(k) call rotdexpl (r,xr,yr,zr,ai,ak) uixl = uix*ai(1,1) + uiy*ai(1,2) + uiz*ai(1,3) uiyl = uix*ai(2,1) + uiy*ai(2,2) + uiz*ai(2,3) uizl = uix*ai(3,1) + uiy*ai(3,2) + uiz*ai(3,3) ukxl = -ukx*ak(1,1) - uky*ak(1,2) - ukz*ak(1,3) ukyl = -ukx*ak(2,1) - uky*ak(2,2) - ukz*ak(2,3) ukzl = -ukx*ak(3,1) - uky*ak(3,2) - ukz*ak(3,3) frcil(3) = uizl**2 * ds2i frckl(3) = ukzl**2 * ds2k c c compute the torque in the local frame c tqxil = 2.0d0 * uiyl * uizl * s2i tqyil = -2.0d0 * uixl * uizl * s2i tqxkl = 2.0d0 * ukyl * ukzl * s2k tqykl = -2.0d0 * ukxl * ukzl * s2k c c convert the torque into force components c frcil(1) = -tqyil / r frcil(2) = tqxil / r frckl(1) = -tqykl / r frckl(2) = tqxkl / r c c rotate the force components into the global frame c frcxi = 0.0d0 frcyi = 0.0d0 frczi = 0.0d0 frcxk = 0.0d0 frcyk = 0.0d0 frczk = 0.0d0 do j = 1, 3 frcxi = frcxi + ai(j,1)*frcil(j) frcyi = frcyi + ai(j,2)*frcil(j) frczi = frczi + ai(j,3)*frcil(j) frcxk = frcxk + ak(j,1)*frckl(j) frcyk = frcyk + ak(j,2)*frckl(j) frczk = frczk + ak(j,3)*frckl(j) end do frcx = f * (frcxk-frcxi) frcy = f * (frcyk-frcyi) frcz = f * (frczk-frczi) c c increment force-based gradient on the interaction sites c dep(1,i) = dep(1,i) + frcx dep(2,i) = dep(2,i) + frcy dep(3,i) = dep(3,i) + frcz dep(1,k) = dep(1,k) - frcx dep(2,k) = dep(2,k) - frcy dep(3,k) = dep(3,k) - frcz c c increment the virial due to pairwise Cartesian forces c vxx = -xr * frcx vxy = -0.5d0 * (yr*frcx+xr*frcy) vxz = -0.5d0 * (zr*frcx+xr*frcz) vyy = -yr * frcy vyz = -0.5d0 * (zr*frcy+yr*frcz) vzz = -zr * frcz vir(1,1) = vir(1,1) + vxx vir(2,1) = vir(2,1) + vxy vir(3,1) = vir(3,1) + vxz vir(1,2) = vir(1,2) + vxy vir(2,2) = vir(2,2) + vyy vir(3,2) = vir(3,2) + vyz vir(1,3) = vir(1,3) + vxz vir(2,3) = vir(2,3) + vyz vir(3,3) = vir(3,3) + vzz end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 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 components with other unit cells c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) springi = kpep(i) / polarity(i) sizi = prepep(i) alphai = dmppep(i) epli = lpep(i) uix = uind(1,i) uiy = uind(2,i) uiz = uind(3,i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = p2scale do k = 1, np11(i) if (i12(j,i) .eq. ip11(k,i)) & pscale(i12(j,i)) = p2iscale end do end do do j = 1, n13(i) pscale(i13(j,i)) = p3scale do k = 1, np11(i) if (i13(j,i) .eq. ip11(k,i)) & pscale(i13(j,i)) = p3iscale end do end do do j = 1, n14(i) pscale(i14(j,i)) = p4scale do k = 1, np11(i) if (i14(j,i) .eq. ip11(k,i)) & pscale(i14(j,i)) = p4iscale end do end do do j = 1, n15(i) pscale(i15(j,i)) = p5scale do k = 1, np11(i) if (i15(j,i) .eq. ip11(k,i)) & pscale(i15(j,i)) = p5iscale end do end do c c evaluate all sites within the cutoff distance c do kk = ii, npole k = ipole(kk) eplk = lpep(k) if (epli .or. eplk) then do jcell = 2, ncell xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call imager (xr,yr,zr,jcell) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) springk = kpep(k) / polarity(k) sizk = prepep(k) alphak = dmppep(k) sizik = sizi * sizk ukx = uind(1,k) uky = uind(2,k) ukz = uind(3,k) call dampexpl (r,sizik,alphai,alphak,s2,ds2) c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 ds2 = ds2*taper + s2*dtaper s2 = s2 * taper end if c c interaction of an atom with its own image counts half c if (i .eq. k) then s2 = 0.5d0 * s2 ds2 = 0.5d0 * ds2 end if s2i = springi * s2 * pscale(k) s2k = springk * s2 * pscale(k) ds2i = springi * ds2 * pscale(k) ds2k = springk * ds2 * pscale(k) call rotdexpl (r,xr,yr,zr,ai,ak) uixl = uix*ai(1,1) + uiy*ai(1,2) + uiz*ai(1,3) uiyl = uix*ai(2,1) + uiy*ai(2,2) + uiz*ai(2,3) uizl = uix*ai(3,1) + uiy*ai(3,2) + uiz*ai(3,3) ukxl = -ukx*ak(1,1) - uky*ak(1,2) - ukz*ak(1,3) ukyl = -ukx*ak(2,1) - uky*ak(2,2) - ukz*ak(2,3) ukzl = -ukx*ak(3,1) - uky*ak(3,2) - ukz*ak(3,3) frcil(3) = uizl**2 * ds2i frckl(3) = ukzl**2 * ds2k c c compute the torque in the local frame c tqxil = 2.0d0 * uiyl * uizl * s2i tqyil = -2.0d0 * uixl * uizl * s2i tqxkl = 2.0d0 * ukyl * ukzl * s2k tqykl = -2.0d0 * ukxl * ukzl * s2k c c convert the torque into force components c frcil(1) = -tqyil / r frcil(2) = tqxil / r frckl(1) = -tqykl / r frckl(2) = tqxkl / r c c rotate the force components into the global frame c frcxi = 0.0d0 frcyi = 0.0d0 frczi = 0.0d0 frcxk = 0.0d0 frcyk = 0.0d0 frczk = 0.0d0 do j = 1, 3 frcxi = frcxi + ai(j,1)*frcil(j) frcyi = frcyi + ai(j,2)*frcil(j) frczi = frczi + ai(j,3)*frcil(j) frcxk = frcxk + ak(j,1)*frckl(j) frcyk = frcyk + ak(j,2)*frckl(j) frczk = frczk + ak(j,3)*frckl(j) end do frcx = f * (frcxk-frcxi) frcy = f * (frcyk-frcyi) frcz = f * (frczk-frczi) c c increment force-based gradient on the interaction sites c dep(1,i) = dep(1,i) + frcx dep(2,i) = dep(2,i) + frcy dep(3,i) = dep(3,i) + frcz dep(1,k) = dep(1,k) - frcx dep(2,k) = dep(2,k) - frcy dep(3,k) = dep(3,k) - frcz c c increment the virial due to pairwise Cartesian forces c vxx = -xr * frcx vxy = -0.5d0 * (yr*frcx+xr*frcy) vxz = -0.5d0 * (zr*frcx+xr*frcz) vyy = -yr * frcy vyz = -0.5d0 * (zr*frcy+yr*frcz) vzz = -zr * frcz vir(1,1) = vir(1,1) + vxx vir(2,1) = vir(2,1) + vxy vir(3,1) = vir(3,1) + vxz vir(1,2) = vir(1,2) + vxy vir(2,2) = vir(2,2) + vyy vir(3,2) = vir(3,2) + vyz vir(1,3) = vir(1,3) + vxz vir(2,3) = vir(2,3) + vyz vir(3,3) = vir(3,3) + vzz end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 end do end do end if c c perform deallocation of some local arrays c deallocate (pscale) return end c c c ############################################################### c ## ## c ## subroutine dexpol1b -- exch-polar chain rule via list ## c ## ## c ############################################################### c c c "dexpol1b" finds variable polarizability chain rule gradient c components due to exchange polarization using a neighbor list c c subroutine dexpol1b use atoms use bound use chgpot use couple use deriv use expol use mpole use neigh use polar use polgrp use polpot use shunt use units use virial implicit none integer i,j,k integer ii,kk,kkk real*8 xi,yi,zi real*8 xr,yr,zr real*8 r,r2,r3,r4,r5 real*8 sizi,sizk,sizik real*8 f,alphai,alphak real*8 springi,springk real*8 s2,ds2 real*8 s2i, s2k real*8 ds2i, ds2k real*8 taper,dtaper real*8 uix,uiy,uiz real*8 ukx,uky,ukz real*8 uixl,ukxl real*8 uiyl,ukyl real*8 uizl,ukzl real*8 vxx,vyy,vzz real*8 vxy,vxz,vyz real*8 frcil(3) real*8 frckl(3) real*8 frcxi,frcyi,frczi real*8 frcxk,frcyk,frczk real*8 frcx,frcy,frcz real*8 tqxil,tqyil real*8 tqxkl,tqykl real*8 ai(3,3) real*8 ak(3,3) real*8, allocatable :: pscale(:) logical epli,eplk character*6 mode c c c perform dynamic allocation of some local arrays c allocate (pscale(n)) c c set conversion factor, cutoff and switching coefficients c f = 0.5d0 * electric / dielec mode = 'REPULS' call switch (mode) c c set array needed to scale atom and group interactions c do i = 1, n pscale(i) = 1.0d0 end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(npole,ipole,x,y,z,kpep,prepep,dmppep,lpep,np11,ip11,n12, !$OMP& i12,n13,i13,n14,i14,n15,i15,p2scale,p3scale,p4scale,p5scale, !$OMP& p2iscale,p3iscale,p4iscale,p5iscale,nelst,elst,use_bounds, !$OMP& cut2,off2,c0,c1,c2,c3,c4,c5,polarity,f,uind) !$OMP& firstprivate(pscale) !$OMP& shared (dep,vir) !$OMP DO reduction(+:dep,vir) schedule(guided) c c find the exchange polarization gradient c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) springi = kpep(i) / polarity(i) sizi = prepep(i) alphai = dmppep(i) epli = lpep(i) uix = uind(1,i) uiy = uind(2,i) uiz = uind(3,i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = p2scale do k = 1, np11(i) if (i12(j,i) .eq. ip11(k,i)) & pscale(i12(j,i)) = p2iscale end do end do do j = 1, n13(i) pscale(i13(j,i)) = p3scale do k = 1, np11(i) if (i13(j,i) .eq. ip11(k,i)) & pscale(i13(j,i)) = p3iscale end do end do do j = 1, n14(i) pscale(i14(j,i)) = p4scale do k = 1, np11(i) if (i14(j,i) .eq. ip11(k,i)) & pscale(i14(j,i)) = p4iscale end do end do do j = 1, n15(i) pscale(i15(j,i)) = p5scale do k = 1, np11(i) if (i15(j,i) .eq. ip11(k,i)) & pscale(i15(j,i)) = p5iscale end do end do c c evaluate all sites within the cutoff distance c do kkk = 1, nelst(ii) kk = elst(kkk,ii) k = ipole(kk) eplk = lpep(k) if (epli .or. eplk) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) springk = kpep(k) / polarity(k) sizk = prepep(k) alphak = dmppep(k) sizik = sizi * sizk ukx = uind(1,k) uky = uind(2,k) ukz = uind(3,k) call dampexpl (r,sizik,alphai,alphak,s2,ds2) c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 ds2 = ds2*taper + s2*dtaper s2 = s2 * taper end if s2i = springi * s2 * pscale(k) s2k = springk * s2 * pscale(k) ds2i = springi * ds2 * pscale(k) ds2k = springk * ds2 * pscale(k) call rotdexpl (r,xr,yr,zr,ai,ak) uixl = uix*ai(1,1) + uiy*ai(1,2) + uiz*ai(1,3) uiyl = uix*ai(2,1) + uiy*ai(2,2) + uiz*ai(2,3) uizl = uix*ai(3,1) + uiy*ai(3,2) + uiz*ai(3,3) ukxl = -ukx*ak(1,1) - uky*ak(1,2) - ukz*ak(1,3) ukyl = -ukx*ak(2,1) - uky*ak(2,2) - ukz*ak(2,3) ukzl = -ukx*ak(3,1) - uky*ak(3,2) - ukz*ak(3,3) frcil(3) = uizl**2 * ds2i frckl(3) = ukzl**2 * ds2k c c compute the torque in the local frame c tqxil = 2.0d0 * uiyl * uizl * s2i tqyil = -2.0d0 * uixl * uizl * s2i tqxkl = 2.0d0 * ukyl * ukzl * s2k tqykl = -2.0d0 * ukxl * ukzl * s2k c c convert the torque into force components c frcil(1) = -tqyil / r frcil(2) = tqxil / r frckl(1) = -tqykl / r frckl(2) = tqxkl / r c c rotate the force conponents into the global frame c frcxi = 0.0d0 frcyi = 0.0d0 frczi = 0.0d0 frcxk = 0.0d0 frcyk = 0.0d0 frczk = 0.0d0 do j = 1, 3 frcxi = frcxi + ai(j,1)*frcil(j) frcyi = frcyi + ai(j,2)*frcil(j) frczi = frczi + ai(j,3)*frcil(j) frcxk = frcxk + ak(j,1)*frckl(j) frcyk = frcyk + ak(j,2)*frckl(j) frczk = frczk + ak(j,3)*frckl(j) end do frcx = f * (frcxk-frcxi) frcy = f * (frcyk-frcyi) frcz = f * (frczk-frczi) c c increment force-based gradient on the interaction sites c dep(1,i) = dep(1,i) + frcx dep(2,i) = dep(2,i) + frcy dep(3,i) = dep(3,i) + frcz dep(1,k) = dep(1,k) - frcx dep(2,k) = dep(2,k) - frcy dep(3,k) = dep(3,k) - frcz c c increment the virial due to pairwise Cartesian forces c vxx = -xr * frcx vxy = -0.5d0 * (yr*frcx+xr*frcy) vxz = -0.5d0 * (zr*frcx+xr*frcz) vyy = -yr * frcy vyz = -0.5d0 * (zr*frcy+yr*frcz) vzz = -zr * frcz vir(1,1) = vir(1,1) + vxx vir(2,1) = vir(2,1) + vxy vir(3,1) = vir(3,1) + vxz vir(1,2) = vir(1,2) + vxy vir(2,2) = vir(2,2) + vyy vir(3,2) = vir(3,2) + vyz vir(1,3) = vir(1,3) + vxz vir(2,3) = vir(2,3) + vyz vir(3,3) = vir(3,3) + vzz end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 end do end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (pscale) return end c c c ################################################################# c ## ## c ## subroutine rotdexpl -- rotation matrix for expol derivs ## c ## ## c ################################################################# c c c "rotdexpl" finds rotation matrices for variable polarizability c in the exchange polarization gradient c c subroutine rotdexpl (r,xr,yr,zr,ai,ak) use atoms use math use mpole use polpot implicit none real*8 r,xr,yr,zr real*8 dr,dot,eps real*8 dx,dy,dz real*8 ai(3,3) real*8 ak(3,3) c c c compute the rotation matrix elements c ai(3,1) = xr / r ai(3,2) = yr / r ai(3,3) = zr / r dx = 1.0d0 dy = 0.0d0 dz = 0.0d0 dot = ai(3,1) eps = 1.0d0 / root2 if (abs(dot) .gt. eps) then dx = 0.0d0 dy = 1.0d0 dot = ai(3,2) end if dx = dx - dot*ai(3,1) dy = dy - dot*ai(3,2) dz = dz - dot*ai(3,3) dr = sqrt(dx*dx + dy*dy + dz*dz) c c matrix "ai" rotates a vector from global to local frame c ai(1,1) = dx / dr ai(1,2) = dy / dr ai(1,3) = dz / dr ai(2,1) = ai(1,3)*ai(3,2) - ai(1,2)*ai(3,3) ai(2,2) = ai(1,1)*ai(3,3) - ai(1,3)*ai(3,1) ai(2,3) = ai(1,2)*ai(3,1) - ai(1,1)*ai(3,2) ak(1,1) = ai(1,1) ak(1,2) = ai(1,2) ak(1,3) = ai(1,3) ak(2,1) = -ai(2,1) ak(2,2) = -ai(2,2) ak(2,3) = -ai(2,3) ak(3,1) = -ai(3,1) ak(3,2) = -ai(3,2) ak(3,3) = -ai(3,3) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine diagq -- fast matrix diagonalization routine ## c ## ## c ################################################################# c c c "diagq" is a matrix diagonalization routine which is derived c from the classical given, housec, and eigen algorithms with c several modifications to increase efficiency and accuracy c c variables and parameters: c c n dimension of the matrix to be diagonalized c nv number of eigenvalues and eigenvectors desired c dd upper triangle of the matrix to be diagonalized c ev returned with the eigenvalues in ascending order c vec returned with the eigenvectors of the matrix c a,b,p,w local vectors containing temporary work space c ta,tb,y local vectors containing temporary work space c c literature reference: c c adapted from an original routine written by Bernie Brooks, c National Institutes of Health, Bethesda, MD c c subroutine diagq (n,nv,dd,ev,vec) implicit none integer i,j,k,m,n integer ia,ii,ji integer mi,mj,mk integer nn,nv,ntot integer nom,nomtch integer ipt,iter,j1 integer mi1,mj1,mk1 real*8 alimit,anorm real*8 eta,theta,eps real*8 rho,delta,gamma real*8 zeta,sigma real*8 bx,elim1,elim2 real*8 epr,f0,factor real*8 rvalue,rand1 real*8 rpower,rpow1 real*8 root,rootx real*8 s,sgn,sum1 real*8 t,term,temp real*8 trial,xnorm real*8 dd(*) real*8 ev(*) real*8, allocatable :: a(:) real*8, allocatable :: b(:) real*8, allocatable :: p(:) real*8, allocatable :: w(:) real*8, allocatable :: ta(:) real*8, allocatable :: tb(:) real*8, allocatable :: y(:) real*8 vec(n,*) logical done c c c initialization of some necessary parameters c eta = 1.0d-16 theta = 1.0d37 eps = 100.0d0 * eta rho = eta / 100.0d0 delta = 100.0d0 * eta**2 gamma = eta**2 / 100.0d0 zeta = 1000.0d0 / theta sigma = theta * delta / 1000.0d0 rvalue = 4099.0d0 rpower = 8388608.0d0 rpow1 = 0.5d0 * rpower rand1 = rpower - 3.0d0 c c perform dynamic allocation of some local arrays c allocate (a(n)) allocate (b(n)) allocate (p(n)) allocate (w(n)) allocate (ta(n)) allocate (tb(n)) allocate (y(n)) c c get norm of the input matrix and scale c factor = 0.0d0 ntot = n*(n+1) / 2 do i = 1, ntot factor = max(factor,abs(dd(i))) end do if (factor .eq. 0.0d0) return k = 0 anorm = 0.0d0 do i = 1, n do j = i, n k = k + 1 term = (dd(k)/factor)**2 if (i .eq. j) term = 0.5d0 * term anorm = anorm + term end do end do anorm = factor * sqrt(2.0d0*anorm) do i = 1, ntot dd(i) = dd(i) / anorm end do c c compute the tridiagonalization of the matrix c nn = n - 1 mi = 0 mi1 = n - 1 do i = 1, nn sum1 = 0.0d0 b(i) = 0.0d0 ji = i + 1 ipt = mi + i a(i) = dd(ipt) ipt = ipt + 1 bx = dd(ipt) do j = ji+1, n ipt = ipt + 1 sum1 = sum1 + dd(ipt)*dd(ipt) end do if (sum1 .lt. gamma) then b(i) = bx dd(mi+ji) = 0.0d0 else s = sqrt(sum1+bx*bx) sgn = 1.0d0 if (bx .lt. 0.0) sgn = -1.0d0 temp = abs(bx) w(ji) = sqrt(0.5d0*(1.0d0+(temp/s))) ipt = mi + ji dd(ipt) = w(ji) ii = i + 2 if (ii .le. n) then temp = sgn / (2.0d0*w(ji)*s) do j = ii, n ipt = ipt + 1 w(j) = temp * dd(ipt) dd(ipt) = w(j) end do end if b(i) = -sgn * s do j = ji, n p(j) = 0.0d0 end do mk = mi + mi1 mk1 = mi1 - 1 do k = ji, n ipt = mk + k do m = k, n bx = dd(ipt) p(k) = p(k) + bx*w(m) if (k .ne. m) p(m) = p(m) + bx*w(k) ipt = ipt + 1 end do mk = mk + mk1 mk1 = mk1 - 1 end do term = 0.0d0 do k = ji, n term = term + w(k)*p(k) end do do k = ji, n p(k) = p(k) - term*w(k) end do mj = mi + mi1 mj1 = mi1 - 1 do j = ji, n do k = j, n dd(mj+k) = dd(mj+k) - 2.0d0*(p(j)*w(k)+p(k)*w(j)) end do mj = mj + mj1 mj1 = mj1 - 1 end do end if mi = mi + mi1 mi1 = mi1 - 1 end do c c find the eigenvalues via the Sturm bisection method c a(n) = dd(mi+n) b(n) = 0.0d0 alimit = 1.0d0 do i = 1, n w(i) = b(i) b(i) = b(i) * b(i) end do do i = 1, nv ev(i) = alimit end do root = -alimit do i = 1, nv rootx = alimit do j = i, nv rootx = min(rootx,ev(j)) end do ev(i) = rootx trial = 0.5d0 * (root+ev(i)) do while (abs(trial-root).ge.eps .and. abs(trial-ev(i)).ge.eps) nomtch = n j = 1 do while (j .le. n) f0 = a(j) - trial do while (abs(f0) .ge. zeta) if (f0 .ge. 0.0d0) nomtch = nomtch - 1 j = j + 1 if (j .gt. n) goto 10 f0 = a(j) - trial - b(j-1)/f0 end do j = j + 2 nomtch = nomtch - 1 end do 10 continue if (nomtch .lt. i) then root = trial else ev(i) = trial nom = min(nv,nomtch) ev(nom) = trial end if trial = 0.5d0 * (root+ev(i)) end do end do c c find the eigenvectors via a backtransformation step c ia = -1 do i = 1, nv root = ev(i) do j = 1, n y(j) = 1.0d0 end do ia = ia + 1 if (i .ne. 1) then if (abs(ev(i-1)-root) .ge. eps) ia = 0 end if elim1 = a(1) - root elim2 = w(1) do j = 1, nn if (abs(elim1) .le. abs(w(j))) then ta(j) = w(j) tb(j) = a(j+1) - root p(j) = w(j+1) temp = 1.0d0 if (abs(w(j)) .gt. zeta) temp = elim1 / w(j) elim1 = elim2 - temp*tb(j) elim2 = -temp * w(j+1) else ta(j) = elim1 tb(j) = elim2 p(j) = 0.0d0 temp = w(j) / elim1 elim1 = a(j+1) - root - temp*elim2 elim2 = w(j+1) end if b(j) = temp end do ta(n) = elim1 tb(n) = 0.0d0 p(n) = 0.0d0 if (nn .ne. 0) p(nn) = 0.0d0 iter = 1 if (ia .ne. 0) goto 40 20 continue m = n + 1 do j = 1, n m = m - 1 done = .false. do while (.not. done) done = .true. k = n - m - 1 if (k .lt. 0) then elim1 = y(m) else if (k .eq. 0) then elim1 = y(m) - y(m+1)*tb(m) else elim1 = y(m) - y(m+1)*tb(m) - y(m+2)*p(m) end if if (abs(elim1) .le. sigma) then temp = ta(m) if (abs(temp) .lt. delta) temp = delta y(m) = elim1 / temp else do k = 1, n y(k) = y(k) / sigma end do done = .false. end if end do end do if (iter .eq. 2) goto 50 iter = iter + 1 30 continue elim1 = y(1) do j = 1, nn if (ta(j) .ne. w(j)) then y(j) = elim1 elim1 = y(j+1) - elim1*b(j) else y(j) = y(j+1) elim1 = elim1 - y(j+1)*b(j) end if end do y(n) = elim1 goto 20 40 continue do j = 1, n rand1 = mod(rvalue*rand1,rpower) y(j) = rand1/rpow1 - 1.0d0 end do goto 20 50 continue if (ia .ne. 0) then do j1 = 1, ia k = i - j1 temp = 0.0d0 do j = 1, n temp = temp + y(j)*vec(j,k) end do do j = 1, n y(j) = y(j) - temp*vec(j,k) end do end do end if if (iter .eq. 1) goto 30 elim1 = 0.0d0 do j = 1, n elim1 = max(elim1,abs(y(j))) end do temp = 0.0d0 do j = 1, n elim2 = y(j) / elim1 temp = temp + elim2*elim2 end do temp = 1.0d0 / (sqrt(temp)*elim1) do j = 1, n y(j) = y(j) * temp if (abs(y(j)) .lt. rho) y(j) = 0.0d0 end do do j = 1, n vec(j,i) = y(j) end do end do c c normalization of the eigenvalues and eigenvectors c do i = 1, nv do j = 1, n y(j) = vec(j,i) end do mk = (n*(n-1))/2 - 3 mk1 = 3 do j = 1, n-2 t = 0.0d0 m = n - j do k = m, n t = t + dd(mk+k)*y(k) end do do k = m, n epr = t * dd(mk+k) y(k) = y(k) - 2.0d0*epr end do mk = mk - mk1 mk1 = mk1 + 1 end do t = 0.0d0 do j = 1, n t = t + y(j)*y(j) end do xnorm = sqrt(t) do j = 1, n y(j) = y(j) / xnorm end do do j = 1, n vec(j,i) = y(j) end do end do do i = 1, n ev(i) = ev(i) * anorm end do c c perform deallocation of some local arrays c deallocate (a) deallocate (b) deallocate (p) deallocate (w) deallocate (ta) deallocate (tb) deallocate (y) return end c c c ################################################### c ## COPYRIGHT (C) 1995 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine diffeq -- differential equation integration ## c ## ## c ################################################################ c c c "diffeq" performs the numerical integration of an ordinary c differential equation using an adaptive stepsize method to c solve the corresponding coupled first-order equations of the c general form dyi/dx = f(x,y1,...,yn) for yi = y1,...,yn c c variables and parameters: c c nvar number of coupled first-order differential equations c y contains the values of the dependent variables c x1 value of the beginning integration limit c x2 value of the ending integration limit c eps relative accuracy required of the integration steps c h1 initial guess for the first integration stepsize c hmin minimum allowed integration stepsize c nok number of initially successful integration steps c nbad number of integration steps that required retry c c required external routines : c c gvalue subroutine to find the right-hand side of the c first-order differential equations c c subroutine diffeq (nvar,y,x1,x2,eps,h1,hmin,nok,nbad,gvalue) use iounit implicit none real*8 tiny parameter (tiny=1.0d-30) integer i,nvar,nok,nbad integer nstep,maxstep real*8 x,x1,x2,h,h1 real*8 eps,hnext real*8 hmin,hdid real*8 y(*) real*8, allocatable :: dydx(:) real*8, allocatable :: yscal(:) logical terminate character*7 status external gvalue c c c initialize starting limit, step size and status counters c terminate = .false. x = x1 h = sign(h1,x2-x1) nstep = 0 nok = 0 nbad = 0 maxstep = 1000 c c perform dynamic allocation of some local arrays c allocate (dydx(nvar)) allocate (yscal(nvar)) c c perform a series of individual integration steps c do while (.not. terminate) call gvalue (x,y,dydx) do i = 1, nvar yscal(i) = abs(y(i)) + abs(h*dydx(i)) + tiny end do c c set the final step to stop at the integration limit c if ((x+h-x2)*(x+h-x1) .gt. 0.0d0) h = x2 - x c c take a Bulirsch-Stoer integration step c call bsstep (nvar,x,dydx,y,h,eps,yscal,hdid,hnext,gvalue) c c mark the current step as either good or bad c if (hdid .eq. h) then nok = nok + 1 status = 'Success' else nbad = nbad + 1 status = ' Retry ' end if c c update stepsize and get information about the current step c h = hnext nstep = nstep + 1 call gdastat (nstep,x,y,status) c c test for convergence to the final integration limit c if ((x-x2)*(x2-x1) .ge. 0.0d0) then write (iout,10) 10 format (/,' DIFFEQ -- Normal Termination', & ' at Integration Limit') terminate = .true. end if c c test for a trial stepsize that is too small c if (abs(hnext) .lt. hmin) then write (iout,20) 20 format (/,' DIFFEQ -- Incomplete Integration', & ' due to SmallStep') terminate = .true. end if c c test for too many total integration steps c if (nstep .ge. maxstep) then write (iout,30) 30 format (/,' DIFFEQ -- Incomplete Integration', & ' due to IterLimit') terminate = .true. end if end do c c perform deallocation of some local arrays c deallocate (dydx) deallocate (yscal) return end c c c ############################################################## c ## ## c ## subroutine bsstep -- Bulirsch-Stoer integration step ## c ## ## c ############################################################## c c c "bsstep" takes a single Bulirsch-Stoer step with monitoring c of local truncation error to ensure accuracy c c literature reference: c c W. H. Press, S. A. Teukolsky, W. T. Vetterling and B. P. c Flannery, Numerical Recipes (Fortran), 2nd Ed., Cambridge c University Press, 1992, Section 16.4 c c subroutine bsstep (nvar,x,dydx,y,htry,eps,yscal,hdid,hnext,gvalue) use iounit implicit none integer kmaxx,imax real*8 safe1,safe2 real*8 redmax,redmin real*8 tiny,scalmx parameter (kmaxx=8) parameter (imax=kmaxx+1) parameter (safe1=0.25d0) parameter (safe2=0.7d0) parameter (redmax=1.0d-5) parameter (redmin=0.7d0) parameter (tiny=1.0d-30) parameter (scalmx=0.1d0) integer i,iq,k,kk,nvar integer km,kmax,kopt integer nseq(imax) real*8 eps,eps1,epsold real*8 h,hdid,hnext,htry real*8 errmax,fact,red real*8 scale,work,wrkmin real*8 x,xest,xnew real*8 dydx(*) real*8 y(*) real*8 yscal(*) real*8 a(imax) real*8 err(kmaxx) real*8 alf(kmaxx,kmaxx) real*8, allocatable :: yerr(:) real*8, allocatable :: ysav(:) real*8, allocatable :: yseq(:) logical first,reduct save a,alf,epsold,first save kmax,kopt,nseq,xnew external gvalue data first / .true. / data epsold / -1.0d0 / data nseq / 2,4,6,8,10,12,14,16,18 / c c c setup prior to the Bulirsch-Stoer integration step c if (eps .ne. epsold) then hnext = -1.0d29 xnew = -1.0d29 eps1 = safe1 * eps a(1) = 1.0d0 + dble(nseq(1)) do k = 1, kmaxx a(k+1) = a(k) + dble(nseq(k+1)) end do do iq = 2, kmaxx do k = 1, iq-1 alf(k,iq) = eps1**((a(k+1)-a(iq+1))/((a(iq+1)-a(1)+1.0d0) & *(2*k+1))) end do end do epsold = eps do kopt = 2, kmaxx-1 kmax = kopt if (a(kopt+1) .gt. a(kopt)*alf(kopt-1,kopt)) goto 10 end do 10 continue end if c c perform dynamic allocation of some local arrays c allocate (yerr(nvar)) allocate (ysav(nvar)) allocate (yseq(nvar)) c c make an integration step using Bulirsch-Stoer method c h = htry do i = 1, nvar ysav(i) = y(i) end do if (h.ne.hnext .or. x.ne.xnew) then first = .true. kopt = kmax end if reduct = .false. 20 continue do k = 1, kmax xnew = x + h if (xnew .eq. x) then write (iout,30) 30 format (' BSSTEP -- Underflow of Step Size') call fatal end if call mmid (nseq(k),h,nvar,x,dydx,ysav,yseq,gvalue) xest = (h/dble(nseq(k)))**2 call pzextr (k,nvar,xest,yseq,y,yerr) if (k .ne. 1) then errmax = tiny do i = 1, nvar errmax = max(errmax,abs(yerr(i)/yscal(i))) end do errmax = errmax / eps km = k - 1 err(km) = (errmax/safe1)**(1.0d0/(2*km+1)) end if if (k.ne.1 .and. (k.ge.kopt-1 .or. first)) then if (errmax .lt. 1.0d0) goto 50 if (k.eq.kmax .or. k.eq.kopt+1) then red = safe2 / err(km) goto 40 else if (k .eq. kopt) then if (alf(kopt-1,kopt) .lt. err(km)) then red = 1.0d0 / err(km) goto 40 end if else if (kopt .eq. kmax) then if (alf(km,kmax-1) .lt. err(km)) then red = alf(km,kmax-1) * safe2 / err(km) goto 40 end if else if (alf(km,kopt) .lt. err(km)) then red = alf(km,kopt-1) / err(km) goto 40 end if end if end do 40 continue red = min(red,redmin) red = max(red,redmax) h = h * red reduct = .true. goto 20 50 continue x = xnew hdid = h first = .false. wrkmin = 1.0d35 do kk = 1, km fact = max(err(kk),scalmx) work = fact * a(kk+1) if (work .lt. wrkmin) then scale = fact wrkmin = work kopt = kk + 1 end if end do hnext = h / scale if (kopt.ge.k .and. kopt.ne.kmax .and. .not.reduct) then fact = max(scale/alf(kopt-1,kopt),scalmx) if (a(kopt+1)*fact .le. wrkmin) then hnext = h / fact kopt = kopt + 1 end if end if c c perform deallocation of some local arrays c deallocate (yerr) deallocate (ysav) deallocate (yseq) return end c c c ########################################################### c ## ## c ## subroutine mmid -- takes a modified midpoint step ## c ## ## c ########################################################### c c c "mmid" implements a modified midpoint method to advance the c integration of a set of first order differential equations c c subroutine mmid (nstep,htot,nvar,xs,dydx,y,yout,gvalue) implicit none integer i,k integer nstep,nvar real*8 htot,h,h2 real*8 xs,x,temp real*8 dydx(*) real*8 y(*) real*8 yout(*) real*8, allocatable :: ym(:) real*8, allocatable :: yn(:) external gvalue c c c set substep size based on number of steps to be taken c h = htot / dble(nstep) h2 = 2.0d0 * h c c perform dynamic allocation of some local arrays c allocate (ym(nvar)) allocate (yn(nvar)) c c take the first substep and get values at ends of step c do i = 1, nvar ym(i) = y(i) yn(i) = y(i) + h*dydx(i) end do x = xs + h call gvalue (x,yn,yout) c c take the second and subsequent substeps c do k = 2, nstep do i = 1, nvar temp = ym(i) + h2*yout(i) ym(i) = yn(i) yn(i) = temp end do x = x + h call gvalue (x,yn,yout) end do c c complete the update of values for the last substep c do i = 1, nvar yout(i) = 0.5d0 * (ym(i)+yn(i)+h*yout(i)) end do c c perform deallocation of some local arrays c deallocate (ym) deallocate (yn) return end c c c ############################################################## c ## ## c ## subroutine pzextr -- polynomial extrapolation method ## c ## ## c ############################################################## c c c "pzextr" is a polynomial extrapolation routine used during c Bulirsch-Stoer integration of ordinary differential equations c c subroutine pzextr (iest,nvar,xest,yest,yz,dy) implicit none integer imax parameter (imax=13) integer i,j,iest,nvar real*8 xest,delta real*8 f1,f2,q real*8 x(imax) real*8 yz(*) real*8 dy(*) real*8 yest(*) real*8, allocatable :: d(:) real*8, allocatable, save :: qcol(:,:) save x c c c perform dynamic allocation of some local arrays c allocate (d(nvar)) if (.not. allocated(qcol)) allocate (qcol(nvar,imax)) c c polynomial extrapolation needed for Bulirsch-Stoer step c x(iest) = xest do j = 1, nvar dy(j) = yest(j) yz(j) = yest(j) end do if (iest .eq. 1) then do j = 1, nvar qcol(j,1) = yest(j) end do else do j = 1, nvar d(j) = yest(j) end do do i = 1, iest-1 delta = 1.0d0 / (x(iest-i)-xest) f1 = xest * delta f2 = x(iest-i) * delta do j = 1, nvar q = qcol(j,i) qcol(j,i) = dy(j) delta = d(j) - q dy(j) = f1 * delta d(j) = f2 * delta yz(j) = yz(j) + dy(j) end do end do do j = 1, nvar qcol(j,iest) = dy(j) end do end if c c perform deallocation of some local arrays c deallocate (d) return end c c c ################################################################ c ## ## c ## subroutine gdastat -- results for GDA integration step ## c ## ## c ################################################################ c c "gdastat" finds the energy, radius of gyration, and average M2 c for a GDA integration step; also saves the coordinates c c subroutine gdastat (nstep,beta,xx,status) use atoms use iounit use math use warp implicit none integer i,nvar integer nstep real*8 beta real*8 e,energy real*8 rg,m2ave real*8 xx(*) character*7 status c c c convert optimization parameters to coordinates and M2's c nvar = 0 do i = 1, n nvar = nvar + 1 x(i) = xx(nvar) nvar = nvar + 1 y(i) = xx(nvar) nvar = nvar + 1 z(i) = xx(nvar) end do do i = 1, n nvar = nvar + 1 m2(i) = abs(xx(nvar)) end do c c get some info about the current integration step c e = energy () call gyrate (rg) m2ave = 0.0d0 do i = 1, n m2ave = m2ave + m2(i) end do m2ave = m2ave / dble(n) write (iout,10) nstep,log(beta)/logten,e,rg, & log(m2ave)/logten,status 10 format (i6,2x,4f13.4,6x,a7) c c save the current coordinates to an external file c call optsave (nstep,e,xx) return end c c c ############################################################ c ## COPYRIGHT (C) 1995 by Yong Kong & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################ c ## ## c ## program diffuse -- find liquid self-diffusion constant ## c ## ## c ################################################################ c c c "diffuse" finds the self-diffusion constant for a homogeneous c liquid via the Einstein relation from a set of stored molecular c dynamics frames; molecular centers of mass are unfolded and mean c squared displacements are computed versus time separation c c the estimate for the self-diffusion constant in 10-5 cm**2/sec c is printed in the far right column of output and can be checked c by plotting mean squared displacements as a function of the time c separation; values for very large time separation are inaccurate c due to the small amount of data c c program diffuse use atomid use atoms use bound use inform use iounit use molcul use usage implicit none integer i,j,k,m integer nframe,iframe integer iarc,start,stop integer step,skip,size integer, allocatable :: list(:) integer, allocatable :: ntime(:) real*8 xmid,ymid,zmid real*8 xold,yold,zold real*8 xdiff,ydiff,zdiff real*8 xr,yr,zr,weigh real*8 tstep,dunits,delta real*8 xvalue,yvalue,zvalue real*8 rvalue,dvalue,counts real*8, allocatable :: xmsd(:) real*8, allocatable :: ymsd(:) real*8, allocatable :: zmsd(:) real*8, allocatable :: xcm(:,:) real*8, allocatable :: ycm(:,:) real*8, allocatable :: zcm(:,:) logical exist,query logical first character*240 record character*240 string c c c perform the standard initialization functions c call initial c c open the trajectory archive and read the initial frame c call getarc (iarc) c c get numbers of the coordinate frames to be processed c start = 1 stop = 100000 step = 1 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) start query = .false. end if call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) stop call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) step 10 continue if (query) then write (iout,20) 20 format (/,' Numbers of First & Last Frame and Step', & ' Increment : ',$) read (input,30) record 30 format (a240) read (record,*,err=40,end=40) start,stop,step 40 continue end if c c get the time increment between frames in picoseconds c tstep = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=50,end=50) tstep 50 continue if (tstep .le. 0.0d0) then write (iout,60) 60 format (/,' Enter the Time Increment in Picoseconds', & ' [1.0] : ',$) read (input,70) tstep 70 format (f20.0) end if if (tstep .le. 0.0d0) tstep = 1.0d0 c c get the atom parameters, lattice type and molecule count c call field call unitcell call lattice call katom call molecule c c perform dynamic allocation of some local arrays c size = 40 allocate (list(size)) c c find atoms and molecules to be excluded from consideration c call active if (nuse .eq. n) then do i = 1, size list(i) = 0 end do i = 0 do while (exist) call nextarg (string,exist) if (exist) then read (string,*,err=80,end=80) list(i+1) i = i + 1 end if end do 80 continue if (i .eq. 0) then write (iout,90) 90 format (/,' Numbers of any Atoms to be Excluded : ',$) read (input,100) record 100 format (a240) read (record,*,err=110,end=110) (list(i),i=1,size) 110 continue end if i = 1 do while (list(i) .ne. 0) list(i) = max(-n,min(n,list(i))) if (list(i) .gt. 0) then k = list(i) if (use(k)) then use(k) = .false. nuse = nuse - 1 end if i = i + 1 else list(i+1) = max(-n,min(n,list(i+1))) do k = abs(list(i)), abs(list(i+1)) if (use(k)) then use(k) = .false. nuse = nuse - 1 end if end do i = i + 2 end if end do end if c c perform deallocation of some local arrays c deallocate (list) c c alter the molecule list to include only active molecules c do i = 1, nmol do j = imol(1,i), imol(2,i) k = kmol(j) if (.not. use(k)) imol(1,i) = 0 end do end do k = 0 do i = 1, nmol if (imol(1,i) .ne. 0) then k = k + 1 imol(1,k) = imol(1,i) imol(2,k) = imol(2,i) molmass(k) = molmass(i) end if end do nmol = k write (iout,120) nmol 120 format (/,' Total Number of Molecules :',i16) c c count the number of coordinate frames in the archive file c abort = .false. rewind (unit=iarc) first = .true. nframe = 0 do while (.not. abort) call readcart (iarc,first) nframe = nframe + 1 end do nframe = nframe - 1 stop = min(nframe,stop) nframe = (stop-start)/step + 1 write (iout,130) nframe 130 format (/,' Number of Coordinate Frames :',i14) c c perform dynamic allocation of some local arrays c allocate (ntime(nframe)) allocate (xmsd(nframe)) allocate (ymsd(nframe)) allocate (zmsd(nframe)) allocate (xcm(nmol,nframe)) allocate (ycm(nmol,nframe)) allocate (zcm(nmol,nframe)) c c get the archived coordinates for each frame in turn c write (iout,140) 140 format (/,' Reading the Coordinates Archive File :',/) rewind (unit=iarc) first = .true. nframe = 0 iframe = start skip = start do while (iframe.ge.start .and. iframe.le.stop) do j = 1, skip-1 call readcart (iarc,first) end do iframe = iframe + step skip = step call readcart (iarc,first) if (n .eq. 0) goto 160 nframe = nframe + 1 if (mod(nframe,100) .eq. 0) then write (iout,150) nframe 150 format (4x,'Processing Coordinate Frame',i13) end if c c unfold each molecule to get its corrected center of mass c do i = 1, nmol xmid = 0.0d0 ymid = 0.0d0 zmid = 0.0d0 do j = imol(1,i), imol(2,i) k = kmol(j) weigh = mass(k) xmid = xmid + x(k)*weigh ymid = ymid + y(k)*weigh zmid = zmid + z(k)*weigh end do weigh = molmass(i) xmid = xmid / weigh ymid = ymid / weigh zmid = zmid / weigh if (nframe .eq. 1) then xold = xmid yold = ymid zold = zmid else xold = xcm(i,nframe-1) yold = ycm(i,nframe-1) zold = zcm(i,nframe-1) end if xr = xmid - xold yr = ymid - yold zr = zmid - zold if (use_bounds) call image (xr,yr,zr) xcm(i,nframe) = xold + xr ycm(i,nframe) = yold + yr zcm(i,nframe) = zold + zr end do end do 160 continue close (unit=iarc) if (mod(nframe,100) .ne. 0) then write (iout,170) nframe 170 format (4x,'Processing Coordinate Frame',i13) end if c c increment the squared displacements for each frame pair c do i = 1, nframe ntime(i) = 0 xmsd(i) = 0.0d0 ymsd(i) = 0.0d0 zmsd(i) = 0.0d0 end do do i = 1, nframe-1 do j = i+1, nframe m = j - i ntime(m) = ntime(m) + 1 do k = 1, nmol xdiff = xcm(k,j) - xcm(k,i) ydiff = ycm(k,j) - ycm(k,i) zdiff = zcm(k,j) - zcm(k,i) xmsd(m) = xmsd(m) + xdiff*xdiff ymsd(m) = ymsd(m) + ydiff*ydiff zmsd(m) = zmsd(m) + zdiff*zdiff end do end do end do c c perform deallocation of some local arrays c deallocate (xcm) deallocate (ycm) deallocate (zcm) c c get mean squared displacements and convert units; c conversion is from sq. Ang/ps to 10-5 sq. cm/sec c dunits = 10.0d0 do i = 1, nframe-1 counts = dble(nmol) * dble(ntime(i)) xmsd(i) = xmsd(i) * (dunits/counts) ymsd(i) = ymsd(i) * (dunits/counts) zmsd(i) = zmsd(i) * (dunits/counts) end do c c estimate the diffusion constant via the Einstein relation c write (iout,180) 180 format (/,' Mean Squared Displacements and Self-Diffusion', & ' Constant :', & //,5x,'Time Gap',6x,'X MSD',7x,'Y MSD',7x,'Z MSD', & 7x,'R MSD',4x,'Diff Const', & /,7x,'(ps)',9x,'(/2)',8x,'(/2)',8x,'(/2)',8x,'(/6)', & 5x,'(x 10^5)',/) do i = 1, nframe-1 delta = tstep * dble(i) xvalue = xmsd(i) / 2.0d0 yvalue = ymsd(i) / 2.0d0 zvalue = zmsd(i) / 2.0d0 rvalue = (xmsd(i) + ymsd(i) + zmsd(i)) / 6.0d0 dvalue = rvalue / delta write (iout,190) delta,xvalue,yvalue,zvalue,rvalue,dvalue 190 format (f12.2,4f12.2,f12.4) end do c c perform deallocation of some local arrays c deallocate (ntime) deallocate (xmsd) deallocate (ymsd) deallocate (zmsd) c c perform any final tasks before program exit c call final end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## module dipole -- bond dipoles in current structure ## c ## ## c ############################################################ c c c ndipole total number of dipoles in the system c idpl numbers of atoms that define each dipole c bdpl magnitude of each of the dipoles (Debye) c sdpl position of each dipole between defining atoms c c module dipole implicit none integer ndipole integer, allocatable :: idpl(:,:) real*8, allocatable :: bdpl(:) real*8, allocatable :: sdpl(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module disgeo -- distance geometry bounds & parameters ## c ## ## c ################################################################ c c c vdwmax maximum value of hard sphere sum for an atom pair c compact index of local distance compaction on embedding c pathmax maximum value of upper bound after smoothing c dbnd distance geometry upper and lower bounds matrix c georad hard sphere radii for distance geometry atoms c use_invert flag to use enantiomer closest to input structure c use_anneal flag to use simulated annealing refinement c c module disgeo implicit none real*8 vdwmax real*8 compact real*8 pathmax real*8, allocatable :: dbnd(:,:) real*8, allocatable :: georad(:) logical use_invert logical use_anneal save end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ############################################################### c ## ## c ## module disp -- damped dispersion in current structure ## c ## ## c ############################################################### c c c ndisp total number of dispersion sites in the system c idisp number of the atom for each dispersion site c csixpr pairwise sum of C6 dispersion coefficients c csix C6 dispersion coefficient value for each atom c adisp alpha dispersion damping value for each atom c c module disp implicit none integer ndisp integer, allocatable :: idisp(:) real*8 csixpr real*8, allocatable :: csix(:) real*8, allocatable :: adisp(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## program distgeom -- produce distance geometry structures ## c ## ## c ################################################################## c c c "distgeom" uses a metric matrix distance geometry procedure to c generate structures with interpoint distances that lie within c specified bounds, with chiral centers that maintain chirality, c and with torsional angles restrained to desired values; the c user also has the ability to interactively inspect and alter c the triangle smoothed bounds matrix prior to embedding c c program distgeom use angbnd use atomid use atoms use bndstr use couple use disgeo use files use inform use iounit use kvdws use math use refer use restrn use tors implicit none integer i,j,k,ja,kb integer ia,ib,ic,id integer swap,lext integer next,freeunit integer igeo,ngeo,nhyd integer r1,r2,r3,r4,b1,b2 real*8 cosine,weigh real*8 hbond1,hbond2 real*8 bndfac,angfac real*8 radi,rmsvalue real*8 wall,cpu real*8 rab,rbc,rac,t1,t2 real*8 qab,qbc,qcd,qac,qbd real*8 bndmin,bndmax real*8 tormin,tormax real*8 uppermax,big1,big2 real*8 cosmin,cosmax real*8 cosabc,sinabc real*8 cosbcd,sinbcd logical exist,header,done logical query,info,quit character*1 answer character*1 letter character*7 ext character*240 geofile character*240 title character*240 record character*240 string c c c get the input structure file for the embedding c call initial call getxyz c c set the lists of attached atoms and local interactions c call attach call active call bonds call angles call torsions c c get force field vdw radii and any modifications c call field call kvdw c c get distance bound and torsional angle restraints c call kgeom c c store the input structure for later comparison c call makeref (1) c c perform dynamic allocation of some global arrays c allocate (dbnd(n,n)) allocate (georad(n)) c c assign approximate radii based on the atom names c do i = 1, n letter = name(i)(1:1) if (name(i) .eq. 'CH ') then georad(i) = 1.5d0 else if (name(i) .eq. 'CH2') then georad(i) = 1.6d0 else if (name(i) .eq. 'CH3') then georad(i) = 1.7d0 else if (letter .eq. 'H') then georad(i) = 0.95d0 else if (letter .eq. 'C') then georad(i) = 1.45d0 else if (letter .eq. 'N') then georad(i) = 1.35d0 else if (letter .eq. 'O') then georad(i) = 1.35d0 else if (letter .eq. 'P') then georad(i) = 1.8d0 else if (letter .eq. 'S') then georad(i) = 1.8d0 else georad(i) = 0.5d0 end if end do c c optionally, assign atomic radii from force field vdw radii c c do i = 1, n c if (type(i) .ne. 0) then c if (vdwindex .eq. 'CLASS') then c georad(i) = rad(class(i)) c else c georad(i) = rad(type(i)) c end if c end if c end do c c find maximum value of vdw radii sum for an atom pair c big1 = 0.0d0 big2 = 0.0d0 do i = 1, n radi = georad(i) if (radi .gt. big1) then big2 = big1 big1 = radi else if (radi .gt. big2) then big2 = radi end if end do vdwmax = big1 + big2 c c set number of distance geometry structures to generate c ngeo = -1 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) ngeo 10 continue if (ngeo .le. 0) then write (iout,20) 20 format (/,' Number of Distance Geometry Structures', & ' Desired [1] : ',$) read (input,30) ngeo 30 format (i10) if (ngeo .le. 0) ngeo = 1 end if c c perform dynamic allocation of some global arrays c if (allocated(ichir)) deallocate(ichir) if (allocated(chir)) deallocate(chir) allocate (ichir(4,n)) allocate (chir(3,n)) c c enforce the original chirality of tetravalent atoms c nchir = 0 call nextarg (answer,exist) if (.not. exist) then write (iout,40) 40 format (/,' Impose Chirality Constraints on Tetrahedral', & ' Atoms [Y] : ',$) read (input,50) record 50 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .ne. 'N') then call nextarg (answer,exist) if (.not. exist) then write (iout,60) 60 format (/,' Use "Floating" Chirality for -XH2- and -XH3', & ' Groups [N] : ',$) read (input,70) record 70 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) do i = 1, n if (n12(i) .eq. 4) then nhyd = 0 if (answer .eq. 'Y') then do j = 1, 4 letter = name(i12(j,i))(1:1) if (letter .eq. 'H') nhyd = nhyd + 1 end do end if if (nhyd .lt. 2) then nchir = nchir + 1 do j = 1, 4 ichir(j,nchir) = i12(j,i) end do end if end if end do end if c c enforce the planarity or chirality of trigonal centers c call nextarg (answer,exist) if (.not. exist) then write (iout,80) 80 format (/,' Impose Planarity and/or Chirality of Trigonal', & ' Atoms [Y] : ',$) read (input,90) record 90 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .ne. 'N') then do i = 1, n if (n12(i) .eq. 3) then nchir = nchir + 1 do j = 1, 3 ichir(j,nchir) = i12(j,i) end do ichir(4,nchir) = i end if end do end if c c enforce torsional planarity on adjacent trigonal sites c call nextarg (answer,exist) if (.not. exist) then write (iout,100) 100 format (/,' Impose Torsional Planarity on Adjacent Trigonal', & ' Atoms [Y] : ',$) read (input,110) record 110 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .ne. 'N') then do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (n12(ia).eq.3 .and. n12(ib).eq.3) then do j = 1, n12(ia) ja = i12(j,ia) do k = 1, n12(ib) kb = i12(k,ib) if (ja.ne.ib .and. kb.ne.ia) then nchir = nchir + 1 ichir(1,nchir) = ja ichir(2,nchir) = kb ichir(3,nchir) = ia ichir(4,nchir) = ib end if end do end do end if end do end if c c optionally inspect and alter the smoothed bounds matrix c query = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,120) 120 format (/,' Do You Wish to Examine or Alter the Bounds', & ' Matrix [N] : ',$) read (input,130) record 130 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') query = .true. c c choose the global enantiomer nearest to the original c use_invert = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,140) 140 format (/,' Select the Enantiomer Closest to the Input', & ' Structure [N] : ',$) read (input,150) record 150 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') use_invert = .true. c c set the type of refinement to be used after embedding c use_anneal = .true. call nextarg (answer,exist) if (.not. exist) then write (iout,160) 160 format (/,' Refinement via Minimization or Annealing', & ' [M or A, =A] : ',$) read (input,170) record 170 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'M') use_anneal = .false. c c initialize chirality and planarity restraint values c call kchiral c c change the default distance restraint force constant c do i = 1, ndfix if (dfix(1,i) .eq. 100.0d0) dfix(1,i) = 1.0d0 end do c c print lists of the interatomic distance restraints c if (verbose) then header = .true. do i = 1, ndfix ia = idfix(1,i) ib = idfix(2,i) weigh = dfix(1,i) bndmin = dfix(2,i) bndmax = dfix(3,i) if (header) then header = .false. write (iout,180) 180 format (/,' Interatomic Distance Bound Restraints :', & //,12x,'Atom Numbers',7x,'LowerBound', & 4x,'UpperBound',7x,'Weight',/) end if if (weigh .eq. 1.0d0) then write (iout,190) i,ia,ib,bndmin,bndmax 190 format (i6,5x,2i6,3x,2f14.4) else write (iout,200) i,ia,ib,bndmin,bndmax,weigh 200 format (i6,5x,2i6,3x,3f14.4) end if end do c c print lists of the torsional angle restraints c header = .true. do i = 1, ntfix ia = itfix(1,i) ib = itfix(2,i) ic = itfix(3,i) id = itfix(4,i) weigh = tfix(1,i) tormin = tfix(2,i) tormax = tfix(3,i) if (header) then header = .false. write (iout,210) 210 format (/,' Intramolecular Torsional Angle Restraints :', & //,18x,'Atom Numbers',16x,'Torsion Range', & 9x,'Weight',/) end if write (iout,220) i,ia,ib,ic,id,tormin,tormax,weigh 220 format (i6,5x,4i6,3x,3f12.4) end do end if c c initialize the upper and lower bounds matrix c do i = 1, n dbnd(i,i) = 0.0d0 end do uppermax = 1000000.0d0 do i = 1, n do j = 1, i-1 dbnd(j,i) = uppermax end do end do do i = 1, n-1 radi = georad(i) do j = i+1, n dbnd(j,i) = radi + georad(j) end do end do c c set the upper and lower bounds for 1-2 distances c bndfac = 0.0d0 c bndfac = 0.01d0 do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) rab = sqrt((x(ia)-x(ib))**2 + (y(ia)-y(ib))**2 & + (z(ia)-z(ib))**2) bndmin = (1.0d0 - bndfac) * rab bndmax = (1.0d0 + bndfac) * rab if (ia .gt. ib) then dbnd(ia,ib) = bndmin dbnd(ib,ia) = bndmax else dbnd(ia,ib) = bndmax dbnd(ib,ia) = bndmin end if end do c c set the upper and lower bounds for 1-3 distances c angfac = 0.0d0 c angfac = 0.01d0 do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) rab = sqrt((x(ia)-x(ib))**2 + (y(ia)-y(ib))**2 & + (z(ia)-z(ib))**2) rbc = sqrt((x(ib)-x(ic))**2 + (y(ib)-y(ic))**2 & + (z(ib)-z(ic))**2) rac = sqrt((x(ia)-x(ic))**2 + (y(ia)-y(ic))**2 & + (z(ia)-z(ic))**2) cosine = (rab**2+rbc**2-rac**2) / (2.0d0*rab*rbc) cosmin = min(1.0d0,cosine+angfac) cosmax = max(-1.0d0,cosine-angfac) qab = min(dbnd(ia,ib),dbnd(ib,ia)) qbc = min(dbnd(ic,ib),dbnd(ib,ic)) bndmin = qab**2 + qbc**2 - 2.0d0*qab*qbc*cosmin bndmin = sqrt(max(0.0d0,bndmin)) qab = max(dbnd(ia,ib),dbnd(ib,ia)) qbc = max(dbnd(ic,ib),dbnd(ib,ic)) bndmax = qab**2 + qbc**2 - 2.0d0*qab*qbc*cosmax bndmax = sqrt(max(0.0d0,bndmax)) if (ia .gt. ic) then dbnd(ia,ic) = bndmin dbnd(ic,ia) = bndmax else dbnd(ia,ic) = bndmax dbnd(ic,ia) = bndmin end if end do c c set the upper and lower bounds for 1-4 distances c do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) cosmin = 1.0d0 cosmax = -1.0d0 do j = 1, ntfix r1 = itfix(1,j) r2 = itfix(2,j) r3 = itfix(3,j) r4 = itfix(4,j) if ((ia.eq.r1 .and. ib.eq.r2 .and. & ic.eq.r3 .and. id.eq.r4) .or. & (ia.eq.r4 .and. ib.eq.r3 .and. & ic.eq.r2 .and. id.eq.r1)) then t1 = tfix(2,j) / radian t2 = tfix(3,j) / radian if (t2.ge.0.0d0 .and. t1.le.0.0d0) then cosmin = 1.0d0 cosmax = min(cos(t1),cos(t2)) else if (t1.ge.0.0d0 .and. t2.le.0.0d0) then cosmin = max(cos(t1),cos(t2)) cosmax = -1.0d0 else if (t1.ge.0.0d0 .and. t2.ge.t1) then cosmin = cos(t1) cosmax = cos(t2) else if (t2.le.0.0d0 .and. t1.le.t2) then cosmin = cos(t2) cosmax = cos(t1) end if goto 230 end if end do 230 continue qab = min(dbnd(ia,ib),dbnd(ib,ia)) qbc = min(dbnd(ib,ic),dbnd(ic,ib)) qcd = min(dbnd(ic,id),dbnd(id,ic)) qac = min(dbnd(ia,ic),dbnd(ic,ia)) qbd = min(dbnd(ib,id),dbnd(id,ib)) cosabc = (qab**2+qbc**2-qac**2)/(2.0d0*qab*qbc) sinabc = sqrt(max(0.0d0,1.0d0-cosabc**2)) cosbcd = (qbc**2+qcd**2-qbd**2)/(2.0d0*qbc*qcd) sinbcd = sqrt(max(0.0d0,1.0d0-cosbcd**2)) bndmin = qab**2 + qbc**2 + qcd**2 & + 2.0d0*qab*qcd*cosabc*cosbcd & - 2.0d0*qab*qcd*sinabc*sinbcd*cosmin & - 2.0d0*qbc*(qab*cosabc+qcd*cosbcd) bndmin = sqrt(max(0.0d0,bndmin)) qab = max(dbnd(ia,ib),dbnd(ib,ia)) qbc = max(dbnd(ib,ic),dbnd(ic,ib)) qcd = max(dbnd(ic,id),dbnd(id,ic)) qac = max(dbnd(ia,ic),dbnd(ic,ia)) qbd = max(dbnd(ib,id),dbnd(id,ib)) cosabc = (qab**2+qbc**2-qac**2)/(2.0d0*qab*qbc) sinabc = sqrt(max(0.0d0,1.0d0-cosabc**2)) cosbcd = (qbc**2+qcd**2-qbd**2)/(2.0d0*qbc*qcd) sinbcd = sqrt(max(0.0d0,1.0d0-cosbcd**2)) bndmax = qab**2 + qbc**2 + qcd**2 & + 2.0d0*qab*qcd*cosabc*cosbcd & - 2.0d0*qab*qcd*sinabc*sinbcd*cosmax & - 2.0d0*qbc*(qab*cosabc+qcd*cosbcd) bndmax = sqrt(max(0.0d0,bndmax)) if (ia .gt. id) then dbnd(ia,id) = bndmin dbnd(id,ia) = bndmax else dbnd(ia,id) = bndmax dbnd(id,ia) = bndmin end if end do c c convert distance restraints into bounds matrix elements c do i = 1, ndfix ia = idfix(1,i) ib = idfix(2,i) bndmin = dfix(2,i) bndmax = dfix(3,i) if (ia .gt. ib) then dbnd(ia,ib) = bndmin dbnd(ib,ia) = bndmax else dbnd(ia,ib) = bndmax dbnd(ib,ia) = bndmin end if end do c c modify lower bounds to allow hydrogen bond formation c hbond1 = 1.7d0 hbond2 = 2.55d0 do i = 1, n letter = name(i)(1:1) if (letter.eq.'N' .or. letter.eq.'O') then do j = 1, n letter = name(j)(1:1) if (letter .eq. 'H') then k = i12(1,j) letter = name(k)(1:1) if (letter.eq.'N' .or. letter.eq.'O') then if (j .gt. i) then dbnd(j,i) = min(hbond1,dbnd(j,i)) else dbnd(i,j) = min(hbond1,dbnd(i,j)) end if if (k .gt. i) then dbnd(k,i) = min(hbond2,dbnd(k,i)) else dbnd(i,k) = min(hbond2,dbnd(i,k)) end if end if end if end do end if end do c c use the triangle inequalities to smooth the bounds c if (verbose .and. n.le.130) then title = 'Input Distance Bounds :' call grafic (n,dbnd,title) end if write (iout,240) 240 format (/,' Bounds Smoothing via Triangle and Inverse', & ' Triangle Inequality :') if (verbose) call settime call geodesic c call triangle if (verbose) then call gettime (wall,cpu) write (iout,250) wall 250 format (/,' Time Required for Bounds Smoothing :',4x, & f12.2,' seconds') end if c c allow interactive alteration of the bounds matrix c done = .false. do while (query .and. .not.done) done = .true. write (iout,260) 260 format (/,' Enter an Atom Pair to Display Bounds', & ' [=Done] : ',$) read (input,270) record 270 format (a240) read (record,*,err=320,end=320) b1,b2 done = .false. if (b1.lt.1 .or. b2.gt.n .or. b1.eq.b2) goto 320 if (b1 .gt. b2) then swap = b1 b1 = b2 b2 = swap end if write (iout,280) dbnd(b2,b1),dbnd(b1,b2) 280 format (/,' Lower Bound :',f8.3,8x,'Upper Bound :',f8.3) 290 continue write (iout,300) 300 format (/,' Enter New Bound Values [=Unchanged] : ',$) read (input,310) record 310 format (a240) read (record,*,err=320,end=320) bndmin,bndmax if (bndmin .gt. bndmax) goto 290 dbnd(b2,b1) = bndmin dbnd(b1,b2) = bndmax call trifix (b1,b2) 320 continue end do c c display the smoothed upper and lower bounds matrix c if (verbose .and. n.le.130) then title = 'Triangle Smoothed Bounds :' call grafic (n,dbnd,title) end if c c find the largest value of an upper bound between atoms c pathmax = 0.0d0 do i = 1, n do j = 1, i-1 if (pathmax .lt. dbnd(j,i)) pathmax = dbnd(j,i) end do end do write (iout,330) pathmax 330 format (/,' Largest Upper Bound Distance :',15x,f15.4) c c check for any atoms that have no distance restraints c quit = .false. do i = 1, n do j = 1, i-1 if (dbnd(j,i) .ne. uppermax) goto 350 end do do j = i+1, n if (dbnd(i,j) .ne. uppermax) goto 350 end do quit = .true. write (iout,340) i 340 format (/,' DISTGEOM -- Atom',i6,' has no Distance', & ' Constraints') 350 continue end do if (quit) call fatal c c generate the desired number of distance geometry structures c do j = 1, ngeo write (iout,360) j 360 format (/,' Generation via Distance Geometry of Structure',i5) call embed c c superpose the distance geometry structure on input structure c info = verbose verbose = .false. call impose (n,xref,yref,zref,n,x,y,z,rmsvalue) verbose = info c c write out the final optimized distance geometry structure c lext = 3 call numeral (j,ext,lext) geofile = filename(1:leng)//'.'//ext(1:lext) call version (geofile,'new') igeo = freeunit () open (unit=igeo,file=geofile,status='new') call prtxyz (igeo) close (unit=igeo) end do c c perform any final tasks before program exit c call final end c c c ################################################### c ## COPYRIGHT (C) 2005 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module dma -- QM spherical harmonic multipole moments ## c ## ## c ############################################################### c c c mp atomic monopole charge values from DMA c dpx atomic dipole moment x-component from DMA c dpy atomic dipole moment y-component from DMA c dpz atomic dipole moment z-component from DMA c q20 atomic Q20 quadrupole component from DMA (zz) c q21c atomic Q21c quadrupole component from DMA (xz) c q21s atomic Q21s quadrupole component from DMA (yz) c q22c atomic Q22c quadrupole component from DMA (xx-yy) c q22s atomic Q22s quadrupole component from DMA (xy) c c module dma implicit none real*8, allocatable :: mp(:) real*8, allocatable :: dpx(:) real*8, allocatable :: dpy(:) real*8, allocatable :: dpz(:) real*8, allocatable :: q20(:) real*8, allocatable :: q21c(:) real*8, allocatable :: q21s(:) real*8, allocatable :: q22c(:) real*8, allocatable :: q22s(:) save end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## program document -- make documentation lists from source ## c ## ## c ################################################################## c c c "document" generates a formatted description of all the routines c and modules, an index of routines called by each source file, a c list of all valid keywords, a list of include file dependencies c as needed by a Unix-style Makefile, or a formatted force field c parameter summary c c note the logical variable "sphinx" should be set true to make c output suitable for inclusion in the Tinker User's Guide built c via the Sphinx documentation generator c c program document use iounit implicit none integer maxline integer maxunit integer maxword integer maxfunc parameter (maxline=1000) parameter (maxunit=10000) parameter (maxword=10000) parameter (maxfunc=75) integer i,j,k,mode integer isrc,itxt,next integer nkey,nunit integer leng,size integer start,last integer freeunit integer trimtext integer nexttext integer, allocatable :: nline(:) integer, allocatable :: link(:) logical exist,done,sphinx character*20 module character*20 keyword character*20 keylast character*20 fname1,fname2 character*20 fname(maxfunc) character*20, allocatable :: key(:) character*240 srcfile character*240 txtfile character*240 record character*240 string character*230, allocatable :: routine(:) character*240, allocatable :: info(:,:) character*2048 field c c list of the Fortran functions in the Tinker package c data fname / 'ADJACENT', 'ANGGUESS', 'ANORM', 'BETACF', & 'BETAI', 'BMAX', 'BNDERR', 'BNDGUESS', & 'BOXMIN1', 'CHIRER', 'CHKAROM', 'CJKM', & 'D1D2', 'DEPTH', 'DIST2', 'DOT', & 'ENERGY', 'ERF', 'ERFC', 'ERFINV', & 'FREEUNIT', 'GAMMLN', 'GDA2', 'GEOMETRY', & 'INITERR', 'INVBETA', 'LOCERR', 'MAXWELL', & 'MCM1', 'MCMSTEP', 'MIDERR', 'MINIMIZ1', & 'MINIROT1', 'MINRIGID1', 'NEWTON1', 'NEWTROT1', & 'NEXTTEXT', 'NORMAL', 'NUMBER', 'OPBGUESS', & 'OPTFIT', 'OPTIMIZ1', 'OPTIROT1', 'OPTRIGID1', & 'PATH1', 'PAULING1', 'POTNRG', 'PRIORITY', & 'PROPERTY', 'PSS1', 'PSSRGD1', 'PSSROT1', & 'PTINCY', 'RANDOM', 'RMSFIT', 'ROTANG', & 'ROTCHECK', 'SADDLE1', 'SCAN1', 'SIGMOID', & 'SNIFFER1', 'TORFIT1', 'TORSER', 'TOTERR', & 'TRANSIT', 'TRIMTEXT', 'TRIPLE', 'URYGUESS', & 'VALFIT1', 'VALMIN1', 'VALRMS', 'VDWERR', & 'VECANG', 'WATSON1', 'XTALMIN1' / c c c select the type of documentation that is to be generated c call initial write (iout,10) 10 format (/,' The Tinker Documentation Utility Can :', & //,4x,'(1) List Routines Contained in a Source File', & /,4x,'(2) Generate List of Calls made by Routines', & /,4x,'(3) List Global Variables from a Module', & /,4x,'(4) Generate List of Tinker Keyword Options', & /,4x,'(5) Construct a Module Dependency List', & /,4x,'(6) Produce a Summary from a Parameter File') mode = 0 call nextarg (string,exist) if (exist) read (string,*,err=20,end=20) mode 20 continue do while (mode.lt.1 .or. mode.gt.6) write (iout,30) 30 format (/,' Enter the Number of the Desired Choice : ',$) read (input,40,err=20) mode 40 format (i10) end do c c get the filename and open the input source code file c if (mode .ne. 6) then isrc = freeunit () call nextarg (srcfile,exist) if (exist) then call suffix (srcfile,'txt','old') inquire (file=srcfile,exist=exist) end if do while (.not. exist) write (iout,50) 50 format (/,' Enter Name of Source Code Listing File : ',$) read (input,60) srcfile 60 format (a240) call suffix (srcfile,'txt','old') inquire (file=srcfile,exist=exist) end do open (unit=isrc,file=srcfile,status='old') end if c c choose to make output for Sphinx documentation generator c sphinx = .true. c c perform dynamic allocation of some local arrays c allocate (nline(maxunit)) allocate (link(maxunit)) allocate (routine(maxunit)) allocate (info(maxline,maxunit)) c c get a list of routines and descriptions from source code c if (mode .eq. 1) then nunit = 0 do while (.true.) read (isrc,70,err=100,end=100) record 70 format (a240) if (record(1:9) .eq. 'c ## ') then next = 10 call getword (record,module,next) call lowcase (module) call 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)) leng = trimtext (routine(nunit)) routine(nunit) = routine(nunit)(1:leng)//' '//module read (isrc,80,err=100,end=100) 80 format (///) k = 0 done = .false. do while (.not. done) read (isrc,90,err=100,end=100) record 90 format (a240) leng = trimtext (record) if (leng .lt. 7) then done = .true. else if (record(1:1) .eq. ' ') then done = .true. else k = k + 1 info(k,nunit) = record(7:leng)//' ' end if end do nline(nunit) = k end if end if end do 100 continue close (unit=isrc) call sort7 (nunit,routine,link) itxt = freeunit () txtfile = 'routines.doc' call version (txtfile,'new') open (unit=itxt,file=txtfile,status='new') do i = 1, nunit string = routine(i) leng = trimtext (string) if (sphinx) then write (itxt,110) string(1:leng) 110 format ('**',a,'**',/) else write (itxt,120) string(1:leng) 120 format (a,/) end if last = 0 j = link(i) do k = 1, nline(j) string = info(k,j) leng = trimtext (string) write (itxt,130) string(1:leng) 130 format (a) end do if (nline(j) .ne. 0) then write (itxt,140) 140 format () end if end do close (unit=itxt) write (iout,150) txtfile(1:trimtext(txtfile)) 150 format (/,' Source Documentation Written To : ',a) end if c c get a list of the calls made by each source code routine c if (mode .eq. 2) then nunit = 0 do while (.true.) read (isrc,160,err=170,end=170) record 160 format (a240) call upcase (record) if (record(1:1) .ne. 'C') then next = 1 call getword (record,module,next) if (module.eq.'SUBROUTINE' .or. module.eq.'FUNCTION' & .or. module.eq.'PROGRAM') then nunit = nunit + 1 call getword (record,routine(nunit),next) nline(nunit) = 0 else next = index (record,' CALL ') if (next .ne. 0) then next = next + 6 call getword (record,keyword,next) nline(nunit) = nline(nunit) + 1 info(nline(nunit),nunit) = keyword else do i = 1, maxfunc leng = trimtext (fname(i)) fname1 = fname(i)(1:leng)//'(' fname2 = fname(i)(1:leng)//' (' if (index(record,fname1(1:leng+1)).ne.0 .or. & index(record,fname2(1:leng+2)).ne.0) then nline(nunit) = nline(nunit) + 1 info(nline(nunit),nunit) = fname(i) end if end do end if end if end if end do 170 continue close (unit=isrc) call sort7 (nunit,routine,link) itxt = freeunit () txtfile = 'calls.doc' call version (txtfile,'new') open (unit=itxt,file=txtfile,status='new') do i = 1, nunit string = routine(i) leng = trimtext (string) j = link(i) call sort10 (nline(j),info(1,j)) write (itxt,180) string(1:leng) 180 format (a) do k = 1, nline(j) string = info(k,j) leng = trimtext (string) write (itxt,190) string(1:leng) 190 format (5x,a) end do end do close (unit=itxt) write (iout,200) txtfile(1:trimtext(txtfile)) 200 format (/,' Source Documentation Written To : ',a) end if c c get a list of global variables from contents of modules c if (mode .eq. 3) then nunit = 0 do while (.true.) read (isrc,210,err=240,end=240) record 210 format (a240) call upcase (record(1:17)) if (record(1:17) .eq. 'C ## MODULE ') then next = index (record,' --') if (next .ne. 0) then nunit = nunit + 1 leng = trimtext (record) call upcase (record(18:next-1)) string(1:next-11) = record(11:next-1) start = 17 string(start:240) = record(next+6:leng-4) routine(nunit) = string read (isrc,220,err=240,end=240) 220 format (///) k = 0 done = .false. do while (.not. done) read (isrc,230,err=240,end=240) record 230 format (a240) leng = trimtext (record) if (record(1:1) .eq. ' ') then done = .true. else if (leng .ge. 7) then k = k + 1 next = 7 call getword (record,string,next) record = record(next:leng) next = nexttext (record) leng = trimtext (record) start = 17 string(start:240) = record(next:leng) info(k,nunit) = string end if end do nline(nunit) = k end if end if end do 240 continue close (unit=isrc) call sort7 (nunit,routine,link) itxt = freeunit () txtfile = 'modules.doc' call version (txtfile,'new') open (unit=itxt,file=txtfile,status='new') do i = 1, nunit string = routine(i) leng = trimtext (string) if (sphinx) then size = trimtext(string(8:16)) write (itxt,250) string(8:7+size), & string(17:leng)//'**' 250 format (/,'**',a,' Module','^^^^^^^^',a, & //,'.. code-block:: text',/) else write (itxt,260) string(1:leng) 260 format (/,a) end if j = link(i) do k = 1, nline(j) string = info(k,j) leng = trimtext (string) if (sphinx) then write (itxt,270) string(1:leng) 270 format (' ',a) else write (itxt,280) string(1:leng) 280 format (a) end if end do end do close (unit=itxt) write (iout,290) txtfile(1:trimtext(txtfile)) 290 format (/,' Source Documentation Written To : ',a) end if c c perform deallocation of some local arrays c deallocate (nline) deallocate (link) deallocate (routine) deallocate (info) c c perform dynamic allocation of some local arrays c allocate (key(maxword)) c c get the keyword values from the source code listing c if (mode .eq. 4) then nkey = 0 do while (.true.) read (isrc,300,err=310,end=310) record 300 format (a240) next = index (record,'if (keyword(') if (next .ne. 0) then next = index (record,'.eq.') if (next .ne. 0) then next = index (record,'''') if (next .ne. 0) then next = next + 1 call getword (record,keyword,next) call upcase (keyword) nkey = nkey + 1 key(nkey) = keyword end if end if end if end do 310 continue close (unit=isrc) call sort6 (nkey,key) keylast = ' ' itxt = freeunit () txtfile = 'keyword.doc' call version (txtfile,'new') open (unit=itxt,file=txtfile,status='new') do i = 1, nkey keyword = key(i) leng = trimtext (keyword) if (keyword .ne. keylast) then write (itxt,320) keyword(1:leng) 320 format (a) keylast = keyword end if end do close (unit=itxt) write (iout,330) txtfile(1:trimtext(txtfile)) 330 format (/,' Keyword Listing Written To : ',a) end if c c get the used modules from the source code listing c if (mode .eq. 5) then nkey = 0 do while (.true.) read (isrc,340,err=350,end=350) record 340 format (a240) next = 1 call getword (record,keyword,next) if (keyword .eq. 'use') then call gettext (record,keyword,next) keyword = keyword(1:trimtext(keyword))//'.o' nkey = nkey + 1 key(nkey) = keyword end if end do 350 continue close (unit=isrc) call sort6 (nkey,key) keylast = ' ' leng = index (srcfile,'.') field = srcfile(1:leng-1)//'.o:' do i = 1, nkey keyword = key(i) leng = trimtext (keyword) if (keyword .ne. keylast) then last = trimtext (field) field = field(1:last)//' '//keyword(1:leng) keylast = keyword end if end do write (iout,360) 360 format (/,' File Dependencies in Makefile Format :',/) leng = trimtext (field) write (iout,370) field (1:leng) 370 format (a) end if c c perform deallocation of some local arrays c deallocate (key) c c get a force field parameter file and write a listing c if (mode .eq. 6) then call getprm itxt = freeunit () txtfile = 'parameter.txt' call version (txtfile,'new') open (unit=itxt,file=txtfile,status='new') call prtprm (itxt) close (unit=itxt) write (iout,380) txtfile(1:trimtext(txtfile)) 380 format (/,' Parameter Listing Written To : ',a) end if c c perform any final tasks before program exit c call final end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module domega -- derivative components over torsions ## c ## ## c ############################################################## c c c tesum total energy derivatives over torsions c teb bond stretch derivatives over torsions c tea angle bend derivatives over torsions c teba stretch-bend derivatives over torsions c teub Urey-Bradley derivatives over torsions c teaa angle-angle derivatives over torsions c teopb out-of-plane bend derivatives over torsions c teopd out-of-plane distance derivatives over torsions c teid improper dihedral derivatives over torsions c teit improper torsion derivatives over torsions c tet torsional derivatives over torsions c tept pi-system torsion derivatives over torsions c tebt stretch-torsion derivatives over torsions c teat angle-torsion derivatives over torsions c tett torsion-torsion derivatives over torsions c tev van der Waals derivatives over torsions c ter Pauli repulsion derivatives over torsions c tedsp dampled dispersion derivatives over torsions c tec charge-charge derivatives over torsions c tecd charge-dipole derivatives over torsions c ted dipole-dipole derivatives over torsions c tem atomic multipole derivatives over torsions c tep polarization derivatives over torsions c tect charge transfer derivatives over torsions c terxf reaction field derivatives over torsions c tes solvation derivatives over torsions c telf metal ligand field derivatives over torsions c teg geometric restraint derivatives over torsions c tex extra energy term derivatives over torsions c c module domega implicit none real*8, allocatable :: tesum(:) real*8, allocatable :: teb(:) real*8, allocatable :: tea(:) real*8, allocatable :: teba(:) real*8, allocatable :: teub(:) real*8, allocatable :: teaa(:) real*8, allocatable :: teopb(:) real*8, allocatable :: teopd(:) real*8, allocatable :: teid(:) real*8, allocatable :: teit(:) real*8, allocatable :: tet(:) real*8, allocatable :: tept(:) real*8, allocatable :: tebt(:) real*8, allocatable :: teat(:) real*8, allocatable :: tett(:) real*8, allocatable :: tev(:) real*8, allocatable :: ter(:) real*8, allocatable :: tedsp(:) real*8, allocatable :: tec(:) real*8, allocatable :: tecd(:) real*8, allocatable :: ted(:) real*8, allocatable :: tem(:) real*8, allocatable :: tep(:) real*8, allocatable :: tect(:) real*8, allocatable :: terxf(:) real*8, allocatable :: tes(:) real*8, allocatable :: telf(:) real*8, allocatable :: teg(:) real*8, allocatable :: tex(:) save end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ############################################################### c ## ## c ## module dsppot -- dispersion interaction scale factors ## c ## ## c ############################################################### c c c dsp2scale scale factor for 1-2 dispersion energy interactions c dsp3scale scale factor for 1-3 dispersion energy interactions c dsp4scale scale factor for 1-4 dispersion energy interactions c dsp5scale scale factor for 1-5 dispersion energy interactions c use_dcorr flag to use long range dispersion correction c c module dsppot implicit none real*8 dsp2scale real*8 dsp3scale real*8 dsp4scale real*8 dsp5scale logical use_dcorr save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## program dynamic -- run molecular or stochastic dynamics ## c ## ## c ################################################################# c c c "dynamic" computes a molecular or stochastic dynamics trajectory c in one of the standard statistical mechanical ensembles and using c any of several possible integration methods c c program dynamic use atoms use bath use bndstr use bound use inform use iounit use keys use mdstuf use potent use stodyn use usage implicit none integer i,next,mode integer istep,nstep real*8 dt,dtsave logical exist character*20 keyword character*240 record character*240 string c c c set up the structure and molecular mechanics calculation c call initial call getxyz call mechanic c c initialize the temperature, pressure and coupling baths c kelvin = 0.0d0 atmsph = 0.0d0 isothermal = .false. isobaric = .false. c c check for keywords containing any altered parameters c integrate = 'BEEMAN' do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:11) .eq. 'INTEGRATOR ') then call getword (record,integrate,next) call upcase (integrate) end if end do c c initialize the simulation length as number of time steps c nstep = -1 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) nstep 10 continue do while (nstep .lt. 0) write (iout,20) 20 format (/,' Enter the Number of Dynamics Steps to be', & ' Taken : ',$) read (input,30,err=40) nstep 30 format (i10) if (nstep .lt. 0) nstep = 0 40 continue end do c c get the length of the dynamics time step in picoseconds c dt = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=50,end=50) dt 50 continue do while (dt .lt. 0.0d0) write (iout,60) 60 format (/,' Enter the Time Step Length in Femtoseconds', & ' [1.0] : ',$) read (input,70,err=80) dt 70 format (f20.0) if (dt .le. 0.0d0) dt = 1.0d0 80 continue end do dt = 0.001d0 * dt c c enforce bounds on thermostat and barostat coupling times c tautemp = max(tautemp,dt) taupres = max(taupres,dt) c c set the time between trajectory snapshot coordinate saves c dtsave = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=90,end=90) dtsave 90 continue do while (dtsave .lt. 0.0d0) write (iout,100) 100 format (/,' Enter Time between Saves in Picoseconds', & ' [0.1] : ',$) read (input,110,err=120) dtsave 110 format (f20.0) if (dtsave .le. 0.0d0) dtsave = 0.1d0 120 continue end do iwrite = nint(dtsave/dt) c c get choice of statistical ensemble for periodic system c if (use_bounds) then mode = -1 call nextarg (string,exist) if (exist) read (string,*,err=130,end=130) mode 130 continue do while (mode.lt.1 .or. mode.gt.4) write (iout,140) 140 format (/,' Available Statistical Mechanical Ensembles :', & //,4x,'(1) Microcanonical (NVE)', & /,4x,'(2) Canonical (NVT)', & /,4x,'(3) Isoenthalpic-Isobaric (NPH)', & /,4x,'(4) Isothermal-Isobaric (NPT)', & //,' Enter the Number of the Desired Choice', & ' [1] : ',$) read (input,150,err=160) mode 150 format (i10) if (mode .le. 0) mode = 1 160 continue end do if (integrate.eq.'BUSSI' .or. integrate.eq.'NOSE-HOOVER' & .or. integrate.eq.'GHMC') then if (mode .ne. 4) then mode = 4 write (iout,170) 170 format (/,' Switching to NPT Ensemble as Required', & ' by Chosen Integrator') end if end if if (mode.eq.2 .or. mode.eq.4) then isothermal = .true. kelvin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=180,end=180) kelvin 180 continue do while (kelvin .le. 0.0d0) write (iout,190) 190 format (/,' Enter the Desired Temperature in Degrees', & ' K [298] : ',$) read (input,200,err=210) kelvin 200 format (f20.0) if (kelvin .le. 0.0d0) kelvin = 298.0d0 210 continue end do end if if (mode.eq.3 .or. mode.eq.4) then isobaric = .true. atmsph = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=220,end=220) atmsph 220 continue do while (atmsph .eq. -1.0d0) write (iout,230) 230 format (/,' Enter the Desired Pressure in Atm', & ' [1.0] : ',$) read (input,240,err=250) atmsph 240 format (f20.0) if (atmsph .eq. -1.0d0) atmsph = 1.0d0 250 continue end do end if end if c c use constant energy or temperature for nonperiodic system c if (.not. use_bounds) then mode = -1 call nextarg (string,exist) if (exist) read (string,*,err=260,end=260) mode 260 continue do while (mode.lt.1 .or. mode.gt.2) write (iout,270) 270 format (/,' Available Simulation Control Modes :', & //,4x,'(1) Constant Total Energy Value (E)', & /,4x,'(2) Constant Temperature via Thermostat (T)', & //,' Enter the Number of the Desired Choice', & ' [1] : ',$) read (input,280,err=290) mode 280 format (i10) if (mode .le. 0) mode = 1 290 continue end do if (mode .eq. 2) then isothermal = .true. kelvin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=300,end=300) kelvin 300 continue do while (kelvin .le. 0.0d0) write (iout,310) 310 format (/,' Enter the Desired Temperature in Degrees', & ' K [298] : ',$) read (input,320,err=330) kelvin 320 format (f20.0) if (kelvin .le. 0.0d0) kelvin = 298.0d0 330 continue end do end if end if c c perform the setup functions needed to run dynamics c call mdinit (dt) c c print out a header line for the dynamics computation c if (integrate .eq. 'VERLET') then write (iout,340) 340 format (/,' Molecular Dynamics Trajectory via', & ' Velocity Verlet Algorithm') else if (integrate .eq. 'BEEMAN') then write (iout,350) 350 format (/,' Molecular Dynamics Trajectory via', & ' Modified Beeman Algorithm') else if (integrate .eq. 'BAOAB') then write (iout,360) 360 format (/,' Constrained Stochastic Dynamics Trajectory', & ' via BAOAB Algorithm') else if (integrate .eq. 'BUSSI') then write (iout,370) 370 format (/,' Molecular Dynamics Trajectory via', & ' Bussi-Parrinello NPT Algorithm') else if (integrate .eq. 'NOSE-HOOVER') then write (iout,380) 380 format (/,' Molecular Dynamics Trajectory via', & ' Nose-Hoover NPT Algorithm') else if (integrate .eq. 'STOCHASTIC') then write (iout,390) 390 format (/,' Stochastic Dynamics Trajectory via', & ' Velocity Verlet Algorithm') else if (integrate .eq. 'GHMC') then write (iout,400) 400 format (/,' Stochastic Dynamics Trajectory via', & ' Generalized Hybrid Monte Carlo') else if (integrate .eq. 'RIGIDBODY') then write (iout,410) 410 format (/,' Molecular Dynamics Trajectory via', & ' Rigid Body Algorithm') else if (integrate .eq. 'RESPA') then write (iout,420) 420 format (/,' Molecular Dynamics Trajectory via', & ' r-RESPA MTS Algorithm') else write (iout,430) 430 format (/,' Molecular Dynamics Trajectory via', & ' Modified Beeman Algorithm') end if flush (iout) c c integrate equations of motion to take a time step c do istep = 1, nstep if (integrate .eq. 'VERLET') then call verlet (istep,dt) else if (integrate .eq. 'BEEMAN') then call beeman (istep,dt) else if (integrate .eq. 'BAOAB') then call baoab (istep,dt) else if (integrate .eq. 'BUSSI') then call bussi (istep,dt) else if (integrate .eq. 'NOSE-HOOVER') then call nose (istep,dt) else if (integrate .eq. 'STOCHASTIC') then call sdstep (istep,dt) else if (integrate .eq. 'GHMC') then call ghmcstep (istep,dt) else if (integrate .eq. 'RIGIDBODY') then call rgdstep (istep,dt) else if (integrate .eq. 'RESPA') then call respa (istep,dt) else call beeman (istep,dt) end if end do c c perform any final tasks before program exit c call final end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ################################################### c c ############################################################# c ## ## c ## subroutine eangang -- angle-angle cross term energy ## c ## ## c ############################################################# c c c "eangang" calculates the angle-angle potential energy c c subroutine eangang use angang use angbnd use angpot use atoms use bound use energi use group use math use usage implicit none integer i,k,iangang integer ia,ib,ic,id,ie real*8 e,angle real*8 eps,fgrp real*8 dt1,dt2 real*8 dot,cosine real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xie,yie,zie real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 xdb,ydb,zdb real*8 xeb,yeb,zeb real*8 rab2,rcb2 real*8 rdb2,reb2 logical proceed c c c zero out the angle-angle cross term energy c eaa = 0.0d0 if (nangang .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nangang,iaa,iang, !$OMP& use,x,y,z,anat,kaa,aaunit,eps,use_group,use_polymer) !$OMP& shared(eaa) !$OMP DO reduction(+:eaa) schedule(guided) c c calculate the angle-angle interaction energy term c do iangang = 1, nangang i = iaa(1,iangang) k = iaa(2,iangang) ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) id = iang(1,k) ie = iang(3,k) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,ie,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. use(ic) & .or. use(id) .or. use(ie)) c c get the coordinates of the atoms in the angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xie = x(ie) yie = y(ie) zie = z(ie) c c compute the values of the two bond angles c xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib xdb = xid - xib ydb = yid - yib zdb = zid - zib xeb = xie - xib yeb = yie - yib zeb = zie - zib if (use_polymer) then call image (xab,yab,zab) call image (xcb,ycb,zcb) call image (xdb,ydb,zdb) call image (xeb,yeb,zeb) end if rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,eps) reb2 = max(xeb*xeb+yeb*yeb+zeb*zeb,eps) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) dt1 = angle - anat(i) dot = xdb*xeb + ydb*yeb + zdb*zeb cosine = dot / sqrt(rdb2*reb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) dt2 = angle - anat(k) c c get the angle-angle interaction energy c e = aaunit * kaa(iangang) * dt1 * dt2 c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total angle-angle energy c eaa = eaa + e end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine eangang1 -- angle-angle energy & derivatives ## c ## ## c ################################################################# c c c "eangang1" calculates the angle-angle potential energy and c first derivatives with respect to Cartesian coordinates c c subroutine eangang1 use angang use angbnd use angpot use atoms use bound use deriv use energi use group use math use usage use virial implicit none integer i,k,iangang integer ia,ib,ic,id,ie real*8 e,angle real*8 eps,fgrp real*8 dot,cosine real*8 dt1,deddt1 real*8 dt2,deddt2 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xie,yie,zie real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 xdb,ydb,zdb real*8 xeb,yeb,zeb real*8 rab2,rcb2 real*8 rdb2,reb2 real*8 xp,yp,zp,rp real*8 xq,yq,zq,rq real*8 terma,termc real*8 termd,terme real*8 dedxia,dedyia,dedzia real*8 dedxib,dedyib,dedzib real*8 dedxic,dedyic,dedzic real*8 dedxid,dedyid,dedzid real*8 dedxie,dedyie,dedzie real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy logical proceed c c c zero out the angle-angle energy and first derivatives c eaa = 0.0d0 do i = 1, n deaa(1,i) = 0.0d0 deaa(2,i) = 0.0d0 deaa(3,i) = 0.0d0 end do if (nangang .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nangang,iaa,iang, !$OMP& use,x,y,z,anat,kaa,aaunit,eps,use_group,use_polymer) !$OMP& shared(eaa,deaa,vir) !$OMP DO reduction(+:eaa,deaa,vir) schedule(guided) c c find the energy of each angle-angle interaction c do iangang = 1, nangang i = iaa(1,iangang) k = iaa(2,iangang) ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) id = iang(1,k) ie = iang(3,k) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,ie,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. use(ic) & .or. use(id) .or. use(ie)) c c get the coordinates of the atoms in the angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xie = x(ie) yie = y(ie) zie = z(ie) c c compute the values of the two bond angles c xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib xdb = xid - xib ydb = yid - yib zdb = zid - zib xeb = xie - xib yeb = yie - yib zeb = zie - zib if (use_polymer) then call image (xab,yab,zab) call image (xcb,ycb,zcb) call image (xdb,ydb,zdb) call image (xeb,yeb,zeb) end if rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,eps) reb2 = max(xeb*xeb+yeb*yeb+zeb*zeb,eps) xp = ycb*zab - zcb*yab yp = zcb*xab - xcb*zab zp = xcb*yab - ycb*xab xq = yeb*zdb - zeb*ydb yq = zeb*xdb - xeb*zdb zq = xeb*ydb - yeb*xdb rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps)) rq = sqrt(max(xq*xq+yq*yq+zq*zq,eps)) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) dt1 = angle - anat(i) dot = xdb*xeb + ydb*yeb + zdb*zeb cosine = dot / sqrt(rdb2*reb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) dt2 = angle - anat(k) c c get the energy and master chain rule terms for derivatives c e = aaunit * kaa(iangang) * dt1 * dt2 deddt1 = radian * e / dt1 deddt2 = radian * e / dt2 c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp deddt1 = deddt1 * fgrp deddt2 = deddt2 * fgrp end if c c find chain rule terms for the first bond angle deviation c terma = -deddt1 / (rab2*rp) termc = deddt1 / (rcb2*rp) dedxia = terma * (yab*zp-zab*yp) dedyia = terma * (zab*xp-xab*zp) dedzia = terma * (xab*yp-yab*xp) dedxic = termc * (ycb*zp-zcb*yp) dedyic = termc * (zcb*xp-xcb*zp) dedzic = termc * (xcb*yp-ycb*xp) c c find chain rule terms for the second bond angle deviation c termd = -deddt2 / (rdb2*rq) terme = deddt2 / (reb2*rq) dedxid = termd * (ydb*zq-zdb*yq) dedyid = termd * (zdb*xq-xdb*zq) dedzid = termd * (xdb*yq-ydb*xq) dedxie = terme * (yeb*zq-zeb*yq) dedyie = terme * (zeb*xq-xeb*zq) dedzie = terme * (xeb*yq-yeb*xq) c c get the central atom derivative terms by difference c dedxib = -dedxia - dedxic - dedxid - dedxie dedyib = -dedyia - dedyic - dedyid - dedyie dedzib = -dedzia - dedzic - dedzid - dedzie c c increment the total angle-angle energy and derivatives c eaa = eaa + e deaa(1,ia) = deaa(1,ia) + dedxia deaa(2,ia) = deaa(2,ia) + dedyia deaa(3,ia) = deaa(3,ia) + dedzia deaa(1,ib) = deaa(1,ib) + dedxib deaa(2,ib) = deaa(2,ib) + dedyib deaa(3,ib) = deaa(3,ib) + dedzib deaa(1,ic) = deaa(1,ic) + dedxic deaa(2,ic) = deaa(2,ic) + dedyic deaa(3,ic) = deaa(3,ic) + dedzic deaa(1,id) = deaa(1,id) + dedxid deaa(2,id) = deaa(2,id) + dedyid deaa(3,id) = deaa(3,id) + dedzid deaa(1,ie) = deaa(1,ie) + dedxie deaa(2,ie) = deaa(2,ie) + dedyie deaa(3,ie) = deaa(3,ie) + dedzie c c increment the internal virial tensor components c vxx = xab*dedxia + xcb*dedxic + xdb*dedxid + xeb*dedxie vyx = yab*dedxia + ycb*dedxic + ydb*dedxid + yeb*dedxie vzx = zab*dedxia + zcb*dedxic + zdb*dedxid + zeb*dedxie vyy = yab*dedyia + ycb*dedyic + ydb*dedyid + yeb*dedyie vzy = zab*dedyia + zcb*dedyic + zdb*dedyid + zeb*dedyie vzz = zab*dedzia + zcb*dedzic + zdb*dedzid + zeb*dedzie 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine eangang2 -- angle-angle Hessian; numerical ## c ## ## c ############################################################### c c c "eangang2" calculates the angle-angle potential energy c second derivatives with respect to Cartesian coordinates c using finite difference methods c c subroutine eangang2 (i) use angang use angbnd use atoms use group use hessn implicit none integer i,j,k,iangang integer ia,ib,ic,id,ie real*8 eps,fgrp real*8 old,term real*8, allocatable :: de(:,:) real*8, allocatable :: d0(:,:) logical proceed logical twosided c c c set stepsize for derivatives and default group weight c eps = 1.0d-5 fgrp = 1.0d0 twosided = .false. if (n .le. 50) twosided = .true. c c perform dynamic allocation of some local arrays c allocate (de(3,n)) allocate (d0(3,n)) c c compute numerical angle-angle Hessian for current atom c do iangang = 1, nangang j = iaa(1,iangang) k = iaa(2,iangang) ia = iang(1,j) ib = iang(2,j) ic = iang(3,j) id = iang(1,k) ie = iang(3,k) c c decide whether to compute the current interaction c proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic & .or. i.eq.id .or. i.eq.ie) if (proceed .and. use_group) & call groups (proceed,fgrp,ia,ib,ic,id,ie,0) c c eliminate any duplicate atoms in the pair of angles c if (proceed) then if (id.eq.ia .or. id.eq.ic) then id = ie ie = 0 else if (ie.eq.ia .or. ie.eq.ic) then ie = 0 end if term = fgrp / eps c c find first derivatives for the base structure c if (.not. twosided) then call eangang2a (iangang,de) do j = 1, 3 d0(j,ia) = de(j,ia) d0(j,ib) = de(j,ib) d0(j,ic) = de(j,ic) d0(j,id) = de(j,id) if (ie .ne. 0) d0(j,ie) = de(j,ie) 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 eangang2a (iangang,de) do j = 1, 3 d0(j,ia) = de(j,ia) d0(j,ib) = de(j,ib) d0(j,ic) = de(j,ic) d0(j,id) = de(j,id) if (ie .ne. 0) d0(j,ie) = de(j,ie) end do end if x(i) = x(i) + eps call eangang2a (iangang,de) x(i) = old do j = 1, 3 hessx(j,ia) = hessx(j,ia) + term*(de(j,ia)-d0(j,ia)) hessx(j,ib) = hessx(j,ib) + term*(de(j,ib)-d0(j,ib)) hessx(j,ic) = hessx(j,ic) + term*(de(j,ic)-d0(j,ic)) hessx(j,id) = hessx(j,id) + term*(de(j,id)-d0(j,id)) if (ie .ne. 0) & hessx(j,ie) = hessx(j,ie) + term*(de(j,ie)-d0(j,ie)) 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 eangang2a (iangang,de) do j = 1, 3 d0(j,ia) = de(j,ia) d0(j,ib) = de(j,ib) d0(j,ic) = de(j,ic) d0(j,id) = de(j,id) if (ie .ne. 0) d0(j,ie) = de(j,ie) end do end if y(i) = y(i) + eps call eangang2a (iangang,de) y(i) = old do j = 1, 3 hessy(j,ia) = hessy(j,ia) + term*(de(j,ia)-d0(j,ia)) hessy(j,ib) = hessy(j,ib) + term*(de(j,ib)-d0(j,ib)) hessy(j,ic) = hessy(j,ic) + term*(de(j,ic)-d0(j,ic)) hessy(j,id) = hessy(j,id) + term*(de(j,id)-d0(j,id)) if (ie .ne. 0) & hessy(j,ie) = hessy(j,ie) + term*(de(j,ie)-d0(j,ie)) 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 eangang2a (iangang,de) do j = 1, 3 d0(j,ia) = de(j,ia) d0(j,ib) = de(j,ib) d0(j,ic) = de(j,ic) d0(j,id) = de(j,id) if (ie .ne. 0) d0(j,ie) = de(j,ie) end do end if z(i) = z(i) + eps call eangang2a (iangang,de) z(i) = old do j = 1, 3 hessz(j,ia) = hessz(j,ia) + term*(de(j,ia)-d0(j,ia)) hessz(j,ib) = hessz(j,ib) + term*(de(j,ib)-d0(j,ib)) hessz(j,ic) = hessz(j,ic) + term*(de(j,ic)-d0(j,ic)) hessz(j,id) = hessz(j,id) + term*(de(j,id)-d0(j,id)) if (ie .ne. 0) & hessz(j,ie) = hessz(j,ie) + term*(de(j,ie)-d0(j,ie)) end do end if end do c c perform deallocation of some local arrays c deallocate (de) deallocate (d0) return end c c c ################################################################ c ## ## c ## subroutine eangang2a -- angle-angle interaction derivs ## c ## ## c ################################################################ c c c "eangang2a" calculates the angle-angle first derivatives for c a single interaction with respect to Cartesian coordinates; c used in computation of finite difference second derivatives c c subroutine eangang2a (i,de) use angang use angbnd use angpot use atoms use bound use math implicit none integer i,j,k integer ia,ib,ic,id,ie real*8 angle real*8 eps,term real*8 dot,cosine real*8 dt1,deddt1 real*8 dt2,deddt2 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xie,yie,zie real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 xdb,ydb,zdb real*8 xeb,yeb,zeb real*8 rab2,rcb2 real*8 rdb2,reb2 real*8 xp,yp,zp,rp real*8 xq,yq,zq,rq real*8 terma,termc real*8 termd,terme real*8 dedxia,dedyia,dedzia real*8 dedxib,dedyib,dedzib real*8 dedxic,dedyic,dedzic real*8 dedxid,dedyid,dedzid real*8 dedxie,dedyie,dedzie real*8 de(3,*) c c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c set the coordinates of the involved atoms c j = iaa(1,i) k = iaa(2,i) ia = iang(1,j) ib = iang(2,j) ic = iang(3,j) id = iang(1,k) ie = iang(3,k) xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xie = x(ie) yie = y(ie) zie = z(ie) c c zero out the first derivative components c de(1,ia) = 0.0d0 de(2,ia) = 0.0d0 de(3,ia) = 0.0d0 de(1,ib) = 0.0d0 de(2,ib) = 0.0d0 de(3,ib) = 0.0d0 de(1,ic) = 0.0d0 de(2,ic) = 0.0d0 de(3,ic) = 0.0d0 de(1,id) = 0.0d0 de(2,id) = 0.0d0 de(3,id) = 0.0d0 de(1,ie) = 0.0d0 de(2,ie) = 0.0d0 de(3,ie) = 0.0d0 c c compute the values of the two bond angles c xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib xdb = xid - xib ydb = yid - yib zdb = zid - zib xeb = xie - xib yeb = yie - yib zeb = zie - zib if (use_polymer) then call image (xab,yab,zab) call image (xcb,ycb,zcb) call image (xdb,ydb,zdb) call image (xeb,yeb,zeb) end if rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,eps) reb2 = max(xeb*xeb+yeb*yeb+zeb*zeb,eps) xp = ycb*zab - zcb*yab yp = zcb*xab - xcb*zab zp = xcb*yab - ycb*xab xq = yeb*zdb - zeb*ydb yq = zeb*xdb - xeb*zdb zq = xeb*ydb - yeb*xdb rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps)) rq = sqrt(max(xq*xq+yq*yq+zq*zq,eps)) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) dt1 = angle - anat(j) dot = xdb*xeb + ydb*yeb + zdb*zeb cosine = dot / sqrt(rdb2*reb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) dt2 = angle - anat(k) c c get the energy and master chain rule terms for derivatives c term = radian * aaunit * kaa(i) deddt1 = term * dt2 deddt2 = term * dt1 c c find chain rule terms for the first bond angle deviation c terma = -deddt1 / (rab2*rp) termc = deddt1 / (rcb2*rp) dedxia = terma * (yab*zp-zab*yp) dedyia = terma * (zab*xp-xab*zp) dedzia = terma * (xab*yp-yab*xp) dedxic = termc * (ycb*zp-zcb*yp) dedyic = termc * (zcb*xp-xcb*zp) dedzic = termc * (xcb*yp-ycb*xp) c c find chain rule terms for the second bond angle deviation c termd = -deddt2 / (rdb2*rq) terme = deddt2 / (reb2*rq) dedxid = termd * (ydb*zq-zdb*yq) dedyid = termd * (zdb*xq-xdb*zq) dedzid = termd * (xdb*yq-ydb*xq) dedxie = terme * (yeb*zq-zeb*yq) dedyie = terme * (zeb*xq-xeb*zq) dedzie = terme * (xeb*yq-yeb*xq) c c get the central atom derivative terms by difference c dedxib = -dedxia - dedxic - dedxid - dedxie dedyib = -dedyia - dedyic - dedyid - dedyie dedzib = -dedzia - dedzic - dedzid - dedzie c c set the angle-angle interaction first derivatives c de(1,ia) = de(1,ia) + dedxia de(2,ia) = de(2,ia) + dedyia de(3,ia) = de(3,ia) + dedzia de(1,ib) = de(1,ib) + dedxib de(2,ib) = de(2,ib) + dedyib de(3,ib) = de(3,ib) + dedzib de(1,ic) = de(1,ic) + dedxic de(2,ic) = de(2,ic) + dedyic de(3,ic) = de(3,ic) + dedzic de(1,id) = de(1,id) + dedxid de(2,id) = de(2,id) + dedyid de(3,id) = de(3,id) + dedzid de(1,ie) = de(1,ie) + dedxie de(2,ie) = de(2,ie) + dedyie de(3,ie) = de(3,ie) + dedzie return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine eangang3 -- angle-angle energy and analysis ## c ## ## c ################################################################ c c c "eangang3" calculates the angle-angle potential energy; c also partitions the energy among the atoms c c subroutine eangang3 use action use analyz use angang use angbnd use angpot use atomid use atoms use bound use energi use group use inform use iounit use math use usage implicit none integer i,k,iangang integer ia,ib,ic,id,ie real*8 e,angle real*8 eps,fgrp real*8 dt1,dt2 real*8 dot,cosine real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xie,yie,zie real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 xdb,ydb,zdb real*8 xeb,yeb,zeb real*8 rab2,rcb2 real*8 rdb2,reb2 logical proceed logical header,huge c c c zero out the angle-angle cross term energy c neaa = 0 eaa = 0.0d0 do i = 1, n aeaa(i) = 0.0d0 end do if (nangang .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c print header information if debug output was requested c header = .true. if (debug .and. nangang.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Angle-Angle Interactions :', & //,' Type',10x,'Center',6x,'Angle1', & 6x,'Angle2',4x,'dAngle1', & 3x,'dAngle2',6x,'Energy',/) end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nangang,iaa,iang, !$OMP& use,x,y,z,anat,kaa,aaunit,eps,use_group,use_polymer, !$OMP& name,verbose,debug,header,iout) !$OMP& shared(eaa,neaa,aeaa) !$OMP DO reduction(+:eaa,neaa,aeaa) schedule(guided) c c find the energy of each angle-angle interaction c do iangang = 1, nangang i = iaa(1,iangang) k = iaa(2,iangang) ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) id = iang(1,k) ie = iang(3,k) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,ie,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. use(ic) & .or. use(id) .or. use(ie)) c c get the coordinates of the atoms in the angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xie = x(ie) yie = y(ie) zie = z(ie) c c compute the values of the two bond angles c xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib xdb = xid - xib ydb = yid - yib zdb = zid - zib xeb = xie - xib yeb = yie - yib zeb = zie - zib if (use_polymer) then call image (xab,yab,zab) call image (xcb,ycb,zcb) call image (xdb,ydb,zdb) call image (xeb,yeb,zeb) end if rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) rdb2 = max(xdb*xdb+ydb*ydb+zdb*zdb,eps) reb2 = max(xeb*xeb+yeb*yeb+zeb*zeb,eps) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) dt1 = angle - anat(i) dot = xdb*xeb + ydb*yeb + zdb*zeb cosine = dot / sqrt(rdb2*reb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) dt2 = angle - anat(k) c c get the angle-angle interaction energy c e = aaunit * kaa(iangang) * dt1 * dt2 c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total angle-angle energy c neaa = neaa + 1 eaa = eaa + e aeaa(ib) = aeaa(ib) + e c c print a message if the energy of this interaction is large c huge = (e .gt. 5.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Angle-Angle Interactions :', & //,' Type',10x,'Center',6x,'Angle1', & 6x,'Angle2',4x,'dAngle1', & 3x,'dAngle2',6x,'Energy',/) end if write (iout,30) ib,name(ib),ia,ic,id,ie,dt1,dt2,e 30 format (' AngAng',4x,i7,'-',a3,4i6,2f10.4,f12.4) end if end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine eangle -- angle bending potential energy ## c ## ## c ############################################################# c c c "eangle" calculates the angle bending potential energy; c projected in-plane angles at trigonal centers, special c linear or Fourier angle bending terms are optionally used c c subroutine eangle use angbnd use angpot use atoms use bound use energi use group use math use usage implicit none integer i,ia,ib,ic,id real*8 e,eps real*8 ideal,force real*8 fold,factor real*8 dot,cosine real*8 angle,fgrp real*8 dt,dt2,dt3,dt4 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 xip,yip,zip real*8 xap,yap,zap real*8 xcp,ycp,zcp real*8 rab2,rcb2 real*8 rap2,rcp2 real*8 xt,yt,zt real*8 rt2,delta logical proceed c c c zero out the angle bending energy component c ea = 0.0d0 if (nangle .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nangle,iang,anat,ak,afld, !$OMP& use,x,y,z,cang,qang,pang,sang,angtyp,angunit,eps,use_group, !$OMP& use_polymer) !$OMP& shared(ea) !$OMP DO reduction(+:ea) schedule(guided) c c calculate the bond angle bending energy term c do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) id = iang(4,i) ideal = anat(i) force = ak(i) c c decide whether to compute the current interaction c proceed = .true. if (angtyp(i) .eq. 'IN-PLANE') then if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) else if (use_group) call groups (proceed,fgrp,ia,ib,ic,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. use(ic)) end if c c get the coordinates of the atoms in the angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) c c compute the bond angle bending energy c if (angtyp(i) .ne. 'IN-PLANE') then xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib if (use_polymer) then call image (xab,yab,zab) call image (xcb,ycb,zcb) end if rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (angtyp(i) .eq. 'HARMONIC') then dt = angle - ideal dt2 = dt * dt dt3 = dt2 * dt dt4 = dt2 * dt2 e = angunit * force * dt2 & * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4) else if (angtyp(i) .eq. 'LINEAR') then factor = 2.0d0 * angunit * radian**2 e = factor * force * (1.0d0+cosine) else if (angtyp(i) .eq. 'FOURIER') then fold = afld(i) factor = 2.0d0 * angunit * (radian/fold)**2 cosine = cos((fold*angle-ideal)/radian) e = factor * force * (1.0d0+cosine) end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total bond angle bending energy c ea = ea + e c c compute the projected in-plane angle bend energy c else xid = x(id) yid = y(id) zid = z(id) xad = xia - xid yad = yia - yid zad = zia - zid xbd = xib - xid ybd = yib - yid zbd = zib - zid xcd = xic - xid ycd = yic - yid zcd = zic - zid if (use_polymer) then call image (xad,yad,zad) call image (xbd,ybd,zbd) call image (xcd,ycd,zcd) end if xt = yad*zcd - zad*ycd yt = zad*xcd - xad*zcd zt = xad*ycd - yad*xcd rt2 = xt*xt + yt*yt + zt*zt delta = -(xt*xbd + yt*ybd + zt*zbd) / rt2 xip = xib + xt*delta yip = yib + yt*delta zip = zib + zt*delta xap = xia - xip yap = yia - yip zap = zia - zip xcp = xic - xip ycp = yic - yip zcp = zic - zip if (use_polymer) then call image (xap,yap,zap) call image (xcp,ycp,zcp) end if rap2 = max(xap*xap+yap*yap+zap*zap,eps) rcp2 = max(xcp*xcp+ycp*ycp+zcp*zcp,eps) dot = xap*xcp + yap*ycp + zap*zcp cosine = dot / sqrt(rap2*rcp2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) dt = angle - ideal dt2 = dt * dt dt3 = dt2 * dt dt4 = dt2 * dt2 e = angunit * force * dt2 & * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4) c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total bond angle bending energy c ea = ea + e end if end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine eangle1 -- angle bend energy and derivatives ## c ## ## c ################################################################# c c c "eangle1" calculates the angle bending potential energy and c the first derivatives with respect to Cartesian coordinates; c projected in-plane angles at trigonal centers, special linear c or Fourier angle bending terms are optionally used c c subroutine eangle1 use angbnd use angpot use atoms use bound use deriv use energi use group use math use usage use virial implicit none integer i,ia,ib,ic,id real*8 e,eps real*8 ideal,force real*8 fold,factor,dot real*8 cosine,sine real*8 angle,fgrp real*8 dt,dt2,dt3,dt4 real*8 deddt,term real*8 terma,termc real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 xp,yp,zp,rp real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 xip,yip,zip real*8 xap,yap,zap real*8 xcp,ycp,zcp real*8 rab2,rcb2 real*8 rap2,rcp2 real*8 xt,yt,zt real*8 rt2,ptrt2 real*8 xm,ym,zm,rm real*8 delta,delta2 real*8 dedxia,dedyia,dedzia real*8 dedxib,dedyib,dedzib real*8 dedxic,dedyic,dedzic real*8 dedxid,dedyid,dedzid real*8 dedxip,dedyip,dedzip real*8 dpdxia,dpdyia,dpdzia real*8 dpdxic,dpdyic,dpdzic real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy logical proceed c c c zero out energy and first derivative components c ea = 0.0d0 do i = 1, n dea(1,i) = 0.0d0 dea(2,i) = 0.0d0 dea(3,i) = 0.0d0 end do if (nangle .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nangle,iang,anat,ak,afld, !$OMP& use,x,y,z,cang,qang,pang,sang,angtyp,angunit,eps,use_group, !$OMP& use_polymer) !$OMP& shared(ea,dea,vir) !$OMP DO reduction(+:ea,dea,vir) schedule(guided) c c calculate the bond angle bending energy term c do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) id = iang(4,i) ideal = anat(i) force = ak(i) c c decide whether to compute the current interaction c proceed = .true. if (angtyp(i) .eq. 'IN-PLANE') then if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) else if (use_group) call groups (proceed,fgrp,ia,ib,ic,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. use(ic)) end if c c get the coordinates of the atoms in the angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) c c compute the bond angle bending energy and gradient c if (angtyp(i) .ne. 'IN-PLANE') then xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib if (use_polymer) then call image (xab,yab,zab) call image (xcb,ycb,zcb) end if rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) xp = ycb*zab - zcb*yab yp = zcb*xab - xcb*zab zp = xcb*yab - ycb*xab rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps)) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) c c get the energy and master chain rule term for derivatives c if (angtyp(i) .eq. 'HARMONIC') then dt = angle - ideal dt2 = dt * dt dt3 = dt2 * dt dt4 = dt2 * dt2 e = angunit * force * dt2 & * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4) deddt = angunit * force * dt * radian & * (2.0d0 + 3.0d0*cang*dt + 4.0d0*qang*dt2 & + 5.0d0*pang*dt3 + 6.0d0*sang*dt4) else if (angtyp(i) .eq. 'LINEAR') then factor = 2.0d0 * angunit * radian**2 sine = sqrt(1.0d0-cosine*cosine) e = factor * force * (1.0d0+cosine) deddt = -factor * force * sine else if (angtyp(i) .eq. 'FOURIER') then fold = afld(i) factor = 2.0d0 * angunit * (radian/fold)**2 cosine = cos((fold*angle-ideal)/radian) sine = sin((fold*angle-ideal)/radian) e = factor * force * (1.0d0+cosine) deddt = -factor * force * fold * sine end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp deddt = deddt * fgrp end if c c compute derivative components for this interaction c terma = -deddt / (rab2*rp) termc = deddt / (rcb2*rp) dedxia = terma * (yab*zp-zab*yp) dedyia = terma * (zab*xp-xab*zp) dedzia = terma * (xab*yp-yab*xp) dedxic = termc * (ycb*zp-zcb*yp) dedyic = termc * (zcb*xp-xcb*zp) dedzic = termc * (xcb*yp-ycb*xp) dedxib = -dedxia - dedxic dedyib = -dedyia - dedyic dedzib = -dedzia - dedzic c c increment the total bond angle energy and derivatives c ea = ea + e dea(1,ia) = dea(1,ia) + dedxia dea(2,ia) = dea(2,ia) + dedyia dea(3,ia) = dea(3,ia) + dedzia dea(1,ib) = dea(1,ib) + dedxib dea(2,ib) = dea(2,ib) + dedyib dea(3,ib) = dea(3,ib) + dedzib dea(1,ic) = dea(1,ic) + dedxic dea(2,ic) = dea(2,ic) + dedyic dea(3,ic) = dea(3,ic) + dedzic c c increment the internal virial tensor components c vxx = xab*dedxia + xcb*dedxic vyx = yab*dedxia + ycb*dedxic vzx = zab*dedxia + zcb*dedxic vyy = yab*dedyia + ycb*dedyic vzy = zab*dedyia + zcb*dedyic vzz = zab*dedzia + zcb*dedzic 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 compute the projected in-plane angle energy and gradient c else xid = x(id) yid = y(id) zid = z(id) xad = xia - xid yad = yia - yid zad = zia - zid xbd = xib - xid ybd = yib - yid zbd = zib - zid xcd = xic - xid ycd = yic - yid zcd = zic - zid if (use_polymer) then call image (xad,yad,zad) call image (xbd,ybd,zbd) call image (xcd,ycd,zcd) end if xt = yad*zcd - zad*ycd yt = zad*xcd - xad*zcd zt = xad*ycd - yad*xcd rt2 = max(xt*xt+yt*yt+zt*zt,eps) delta = -(xt*xbd + yt*ybd + zt*zbd) / rt2 xip = xib + xt*delta yip = yib + yt*delta zip = zib + zt*delta xap = xia - xip yap = yia - yip zap = zia - zip xcp = xic - xip ycp = yic - yip zcp = zic - zip if (use_polymer) then call image (xap,yap,zap) call image (xcp,ycp,zcp) end if rap2 = max(xap*xap+yap*yap+zap*zap,eps) rcp2 = max(xcp*xcp+ycp*ycp+zcp*zcp,eps) xm = ycp*zap - zcp*yap ym = zcp*xap - xcp*zap zm = xcp*yap - ycp*xap rm = sqrt(max(xm*xm+ym*ym+zm*zm,eps)) dot = xap*xcp + yap*ycp + zap*zcp cosine = dot / sqrt(rap2*rcp2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) c c get the energy and master chain rule term for derivatives c dt = angle - ideal dt2 = dt * dt dt3 = dt2 * dt dt4 = dt2 * dt2 e = angunit * force * dt2 & * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4) deddt = angunit * force * dt * radian & * (2.0d0 + 3.0d0*cang*dt + 4.0d0*qang*dt2 & + 5.0d0*pang*dt3 + 6.0d0*sang*dt4) c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp deddt = deddt * fgrp end if c c chain rule terms for first derivative components c terma = -deddt / (rap2*rm) termc = deddt / (rcp2*rm) dedxia = terma * (yap*zm-zap*ym) dedyia = terma * (zap*xm-xap*zm) dedzia = terma * (xap*ym-yap*xm) dedxic = termc * (ycp*zm-zcp*ym) dedyic = termc * (zcp*xm-xcp*zm) dedzic = termc * (xcp*ym-ycp*xm) dedxip = -dedxia - dedxic dedyip = -dedyia - dedyic dedzip = -dedzia - dedzic c c chain rule components for the projection of the central atom c delta2 = 2.0d0 * delta ptrt2 = (dedxip*xt + dedyip*yt + dedzip*zt) / rt2 term = (zcd*ybd-ycd*zbd) + delta2*(yt*zcd-zt*ycd) dpdxia = delta*(ycd*dedzip-zcd*dedyip) + term*ptrt2 term = (xcd*zbd-zcd*xbd) + delta2*(zt*xcd-xt*zcd) dpdyia = delta*(zcd*dedxip-xcd*dedzip) + term*ptrt2 term = (ycd*xbd-xcd*ybd) + delta2*(xt*ycd-yt*xcd) dpdzia = delta*(xcd*dedyip-ycd*dedxip) + term*ptrt2 term = (yad*zbd-zad*ybd) + delta2*(zt*yad-yt*zad) dpdxic = delta*(zad*dedyip-yad*dedzip) + term*ptrt2 term = (zad*xbd-xad*zbd) + delta2*(xt*zad-zt*xad) dpdyic = delta*(xad*dedzip-zad*dedxip) + term*ptrt2 term = (xad*ybd-yad*xbd) + delta2*(yt*xad-xt*yad) dpdzic = delta*(yad*dedxip-xad*dedyip) + term*ptrt2 c c compute derivative components for this interaction c dedxia = dedxia + dpdxia dedyia = dedyia + dpdyia dedzia = dedzia + dpdzia dedxib = dedxip dedyib = dedyip dedzib = dedzip dedxic = dedxic + dpdxic dedyic = dedyic + dpdyic dedzic = dedzic + dpdzic dedxid = -dedxia - dedxib - dedxic dedyid = -dedyia - dedyib - dedyic dedzid = -dedzia - dedzib - dedzic c c increment the total bond angle energy and derivatives c ea = ea + e dea(1,ia) = dea(1,ia) + dedxia dea(2,ia) = dea(2,ia) + dedyia dea(3,ia) = dea(3,ia) + dedzia dea(1,ib) = dea(1,ib) + dedxib dea(2,ib) = dea(2,ib) + dedyib dea(3,ib) = dea(3,ib) + dedzib dea(1,ic) = dea(1,ic) + dedxic dea(2,ic) = dea(2,ic) + dedyic dea(3,ic) = dea(3,ic) + dedzic dea(1,id) = dea(1,id) + dedxid dea(2,id) = dea(2,id) + dedyid dea(3,id) = dea(3,id) + dedzid c c increment the internal virial tensor components c vxx = xad*dedxia + xbd*dedxib + xcd*dedxic vyx = yad*dedxia + ybd*dedxib + ycd*dedxic vzx = zad*dedxia + zbd*dedxib + zcd*dedxic vyy = yad*dedyia + ybd*dedyib + ycd*dedyic vzy = zad*dedyia + zbd*dedyib + zcd*dedyic vzz = zad*dedzia + zbd*dedzib + zcd*dedzic 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 if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine eangle2 -- atom-by-atom angle bend Hessian ## c ## ## c ############################################################### c c c "eangle2" calculates second derivatives of the angle bending c energy for a single atom using a mixture of analytical and c finite difference methods; projected in-plane angles at trigonal c centers, special linear or Fourier angle bending terms are c optionally used c c subroutine eangle2 (i) use angbnd use angpot use atoms use group use hessn implicit none integer i,j,k integer ia,ib,ic,id real*8 eps,fgrp real*8 old,term real*8, allocatable :: de(:,:) real*8, allocatable :: d0(:,:) logical proceed logical twosided c c c compute analytical angle bending Hessian elements c call eangle2a (i) c c set stepsize for derivatives and default group weight c eps = 1.0d-5 fgrp = 1.0d0 twosided = .false. if (n .le. 50) twosided = .true. c c perform dynamic allocation of some local arrays c allocate (de(3,n)) allocate (d0(3,n)) c c calculate numerical in-plane bend Hessian for current atom c do k = 1, nangle proceed = .false. if (angtyp(k) .eq. 'IN-PLANE') then ia = iang(1,k) ib = iang(2,k) ic = iang(3,k) id = iang(4,k) 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) end if if (proceed) then term = fgrp / eps c c find first derivatives for the base structure c if (.not. twosided) then call eangle2b (k,de) do j = 1, 3 d0(j,ia) = de(j,ia) d0(j,ib) = de(j,ib) d0(j,ic) = de(j,ic) d0(j,id) = de(j,id) 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 eangle2b (k,de) do j = 1, 3 d0(j,ia) = de(j,ia) d0(j,ib) = de(j,ib) d0(j,ic) = de(j,ic) d0(j,id) = de(j,id) end do end if x(i) = x(i) + eps call eangle2b (k,de) x(i) = old do j = 1, 3 hessx(j,ia) = hessx(j,ia) + term*(de(j,ia)-d0(j,ia)) hessx(j,ib) = hessx(j,ib) + term*(de(j,ib)-d0(j,ib)) hessx(j,ic) = hessx(j,ic) + term*(de(j,ic)-d0(j,ic)) hessx(j,id) = hessx(j,id) + term*(de(j,id)-d0(j,id)) 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 eangle2b (k,de) do j = 1, 3 d0(j,ia) = de(j,ia) d0(j,ib) = de(j,ib) d0(j,ic) = de(j,ic) d0(j,id) = de(j,id) end do end if y(i) = y(i) + eps call eangle2b (k,de) y(i) = old do j = 1, 3 hessy(j,ia) = hessy(j,ia) + term*(de(j,ia)-d0(j,ia)) hessy(j,ib) = hessy(j,ib) + term*(de(j,ib)-d0(j,ib)) hessy(j,ic) = hessy(j,ic) + term*(de(j,ic)-d0(j,ic)) hessy(j,id) = hessy(j,id) + term*(de(j,id)-d0(j,id)) 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 eangle2b (k,de) do j = 1, 3 d0(j,ia) = de(j,ia) d0(j,ib) = de(j,ib) d0(j,ic) = de(j,ic) d0(j,id) = de(j,id) end do end if z(i) = z(i) + eps call eangle2b (k,de) z(i) = old do j = 1, 3 hessz(j,ia) = hessz(j,ia) + term*(de(j,ia)-d0(j,ia)) hessz(j,ib) = hessz(j,ib) + term*(de(j,ib)-d0(j,ib)) hessz(j,ic) = hessz(j,ic) + term*(de(j,ic)-d0(j,ic)) hessz(j,id) = hessz(j,id) + term*(de(j,id)-d0(j,id)) end do end if end do c c perform deallocation of some local arrays c deallocate (de) deallocate (d0) return end c c c ################################################################## c ## ## c ## subroutine eangle2a -- angle bending Hessian; analytical ## c ## ## c ################################################################## c c c "eangle2a" calculates bond angle bending potential energy c second derivatives with respect to Cartesian coordinates c c subroutine eangle2a (iatom) use angbnd use angpot use atoms use bound use group use hessn use math implicit none integer i,iatom integer ia,ib,ic real*8 eps,seps real*8 ideal,force real*8 fold,factor,dot real*8 cosine,sine real*8 angle,fgrp real*8 dt,dt2,dt3,dt4 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 rab2,rcb2 real*8 xpo,ypo,zpo real*8 xp,yp,zp,rp,rp2 real*8 xrab,yrab,zrab real*8 xrcb,yrcb,zrcb real*8 xabp,yabp,zabp real*8 xcbp,ycbp,zcbp real*8 deddt,d2eddt2 real*8 terma,termc real*8 ddtdxia,ddtdyia,ddtdzia real*8 ddtdxib,ddtdyib,ddtdzib real*8 ddtdxic,ddtdyic,ddtdzic real*8 dxiaxia,dxiayia,dxiazia real*8 dxibxib,dxibyib,dxibzib real*8 dxicxic,dxicyic,dxiczic real*8 dyiayia,dyiazia,dziazia real*8 dyibyib,dyibzib,dzibzib real*8 dyicyic,dyiczic,dziczic real*8 dxibxia,dxibyia,dxibzia real*8 dyibxia,dyibyia,dyibzia real*8 dzibxia,dzibyia,dzibzia real*8 dxibxic,dxibyic,dxibzic real*8 dyibxic,dyibyic,dyibzic real*8 dzibxic,dzibyic,dzibzic real*8 dxiaxic,dxiayic,dxiazic real*8 dyiaxic,dyiayic,dyiazic real*8 dziaxic,dziayic,dziazic logical proceed,linear c c c set tolerance for minimum distance and angle values c eps = 0.0001d0 seps = sqrt(eps) c c calculate the bond angle bending energy term c do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ideal = anat(i) force = ak(i) c c decide whether to compute the current interaction c proceed = (iatom.eq.ia .or. iatom.eq.ib .or. iatom.eq.ic) if (proceed .and. use_group) & call groups (proceed,fgrp,ia,ib,ic,0,0,0) c c get the coordinates of the atoms in the angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) c c compute the bond angle bending Hessian elements c if (angtyp(i) .ne. 'IN-PLANE') then xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib if (use_polymer) then call image (xab,yab,zab) call image (xcb,ycb,zcb) end if rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) xp = ycb*zab - zcb*yab yp = zcb*xab - xcb*zab zp = xcb*yab - ycb*xab rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps)) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) c c get the master chain rule terms for derivatives c if (angtyp(i) .eq. 'HARMONIC') then dt = angle - ideal dt2 = dt * dt dt3 = dt2 * dt dt4 = dt3 * dt deddt = angunit * force * dt * radian & * (2.0d0 + 3.0d0*cang*dt + 4.0d0*qang*dt2 & + 5.0d0*pang*dt3 + 6.0d0*sang*dt4) d2eddt2 = angunit * force * radian**2 & * (2.0d0 + 6.0d0*cang*dt + 12.0d0*qang*dt2 & + 20.0d0*pang*dt3 + 30.0d0*sang*dt4) else if (angtyp(i) .eq. 'LINEAR') then factor = 2.0d0 * angunit * radian**2 sine = sqrt(1.0d0-cosine*cosine) deddt = -factor * force * sine d2eddt2 = -factor * force * cosine else if (angtyp(i) .eq. 'FOURIER') then fold = afld(i) factor = 2.0d0 * angunit * (radian**2/fold) cosine = cos((fold*angle-ideal)/radian) sine = sin((fold*angle-ideal)/radian) deddt = -factor * force * sine d2eddt2 = -factor * force * fold * cosine end if c c scale the interaction based on its group membership c if (use_group) then deddt = deddt * fgrp d2eddt2 = d2eddt2 * fgrp end if c c construct an orthogonal direction for linear angles c linear = .false. if (rp .le. seps) then linear = .true. if (xab.ne.0.0d0 .and. yab.ne.0.0d0) then xp = -yab yp = xab zp = 0.0d0 else if (xab.eq.0.0d0 .and. yab.eq.0.0d0) then xp = 1.0d0 yp = 0.0d0 zp = 0.0d0 else if (xab.ne.0.0d0 .and. yab.eq.0.0d0) then xp = 0.0d0 yp = 1.0d0 zp = 0.0d0 else if (xab.eq.0.0d0 .and. yab.ne.0.0d0) then xp = 1.0d0 yp = 0.0d0 zp = 0.0d0 end if rp = sqrt(xp*xp + yp*yp + zp*zp) end if c c first derivatives of bond angle with respect to coordinates c 10 continue terma = -1.0d0 / (rab2*rp) termc = 1.0d0 / (rcb2*rp) ddtdxia = terma * (yab*zp-zab*yp) ddtdyia = terma * (zab*xp-xab*zp) ddtdzia = terma * (xab*yp-yab*xp) ddtdxic = termc * (ycb*zp-zcb*yp) ddtdyic = termc * (zcb*xp-xcb*zp) ddtdzic = termc * (xcb*yp-ycb*xp) ddtdxib = -ddtdxia - ddtdxic ddtdyib = -ddtdyia - ddtdyic ddtdzib = -ddtdzia - ddtdzic c c abbreviations used in defining chain rule terms c xrab = 2.0d0 * xab / rab2 yrab = 2.0d0 * yab / rab2 zrab = 2.0d0 * zab / rab2 xrcb = 2.0d0 * xcb / rcb2 yrcb = 2.0d0 * ycb / rcb2 zrcb = 2.0d0 * zcb / rcb2 rp2 = 1.0d0 / (rp*rp) xabp = (yab*zp-zab*yp) * rp2 yabp = (zab*xp-xab*zp) * rp2 zabp = (xab*yp-yab*xp) * rp2 xcbp = (ycb*zp-zcb*yp) * rp2 ycbp = (zcb*xp-xcb*zp) * rp2 zcbp = (xcb*yp-ycb*xp) * rp2 c c chain rule terms for second derivative components c dxiaxia = terma*(xab*xcb-dot) + ddtdxia*(xcbp-xrab) dxiayia = terma*(zp+yab*xcb) + ddtdxia*(ycbp-yrab) dxiazia = terma*(zab*xcb-yp) + ddtdxia*(zcbp-zrab) dyiayia = terma*(yab*ycb-dot) + ddtdyia*(ycbp-yrab) dyiazia = terma*(xp+zab*ycb) + ddtdyia*(zcbp-zrab) dziazia = terma*(zab*zcb-dot) + ddtdzia*(zcbp-zrab) dxicxic = termc*(dot-xab*xcb) - ddtdxic*(xabp+xrcb) dxicyic = termc*(zp-ycb*xab) - ddtdxic*(yabp+yrcb) dxiczic = -termc*(yp+zcb*xab) - ddtdxic*(zabp+zrcb) dyicyic = termc*(dot-yab*ycb) - ddtdyic*(yabp+yrcb) dyiczic = termc*(xp-zcb*yab) - ddtdyic*(zabp+zrcb) dziczic = termc*(dot-zab*zcb) - ddtdzic*(zabp+zrcb) dxiaxic = terma*(yab*yab+zab*zab) - ddtdxia*xabp dxiayic = -terma*xab*yab - ddtdxia*yabp dxiazic = -terma*xab*zab - ddtdxia*zabp dyiaxic = -terma*xab*yab - ddtdyia*xabp dyiayic = terma*(xab*xab+zab*zab) - ddtdyia*yabp dyiazic = -terma*yab*zab - ddtdyia*zabp dziaxic = -terma*xab*zab - ddtdzia*xabp dziayic = -terma*yab*zab - ddtdzia*yabp dziazic = terma*(xab*xab+yab*yab) - ddtdzia*zabp c c get some second derivative chain rule terms by difference c dxibxia = -dxiaxia - dxiaxic dxibyia = -dxiayia - dyiaxic dxibzia = -dxiazia - dziaxic dyibxia = -dxiayia - dxiayic dyibyia = -dyiayia - dyiayic dyibzia = -dyiazia - dziayic dzibxia = -dxiazia - dxiazic dzibyia = -dyiazia - dyiazic dzibzia = -dziazia - dziazic dxibxic = -dxicxic - dxiaxic dxibyic = -dxicyic - dxiayic dxibzic = -dxiczic - dxiazic dyibxic = -dxicyic - dyiaxic dyibyic = -dyicyic - dyiayic dyibzic = -dyiczic - dyiazic dzibxic = -dxiczic - dziaxic dzibyic = -dyiczic - dziayic dzibzic = -dziczic - dziazic dxibxib = -dxibxia - dxibxic dxibyib = -dxibyia - dxibyic dxibzib = -dxibzia - dxibzic dyibyib = -dyibyia - dyibyic dyibzib = -dyibzia - dyibzic dzibzib = -dzibzia - dzibzic c c increment diagonal and off-diagonal Hessian elements c if (ia .eq. iatom) then hessx(1,ia) = hessx(1,ia) + deddt*dxiaxia & + d2eddt2*ddtdxia*ddtdxia hessx(2,ia) = hessx(2,ia) + deddt*dxiayia & + d2eddt2*ddtdxia*ddtdyia hessx(3,ia) = hessx(3,ia) + deddt*dxiazia & + d2eddt2*ddtdxia*ddtdzia hessy(1,ia) = hessy(1,ia) + deddt*dxiayia & + d2eddt2*ddtdyia*ddtdxia hessy(2,ia) = hessy(2,ia) + deddt*dyiayia & + d2eddt2*ddtdyia*ddtdyia hessy(3,ia) = hessy(3,ia) + deddt*dyiazia & + d2eddt2*ddtdyia*ddtdzia hessz(1,ia) = hessz(1,ia) + deddt*dxiazia & + d2eddt2*ddtdzia*ddtdxia hessz(2,ia) = hessz(2,ia) + deddt*dyiazia & + d2eddt2*ddtdzia*ddtdyia hessz(3,ia) = hessz(3,ia) + deddt*dziazia & + d2eddt2*ddtdzia*ddtdzia hessx(1,ib) = hessx(1,ib) + deddt*dxibxia & + d2eddt2*ddtdxia*ddtdxib hessx(2,ib) = hessx(2,ib) + deddt*dyibxia & + d2eddt2*ddtdxia*ddtdyib hessx(3,ib) = hessx(3,ib) + deddt*dzibxia & + d2eddt2*ddtdxia*ddtdzib hessy(1,ib) = hessy(1,ib) + deddt*dxibyia & + d2eddt2*ddtdyia*ddtdxib hessy(2,ib) = hessy(2,ib) + deddt*dyibyia & + d2eddt2*ddtdyia*ddtdyib hessy(3,ib) = hessy(3,ib) + deddt*dzibyia & + d2eddt2*ddtdyia*ddtdzib hessz(1,ib) = hessz(1,ib) + deddt*dxibzia & + d2eddt2*ddtdzia*ddtdxib hessz(2,ib) = hessz(2,ib) + deddt*dyibzia & + d2eddt2*ddtdzia*ddtdyib hessz(3,ib) = hessz(3,ib) + deddt*dzibzia & + d2eddt2*ddtdzia*ddtdzib hessx(1,ic) = hessx(1,ic) + deddt*dxiaxic & + d2eddt2*ddtdxia*ddtdxic hessx(2,ic) = hessx(2,ic) + deddt*dxiayic & + d2eddt2*ddtdxia*ddtdyic hessx(3,ic) = hessx(3,ic) + deddt*dxiazic & + d2eddt2*ddtdxia*ddtdzic hessy(1,ic) = hessy(1,ic) + deddt*dyiaxic & + d2eddt2*ddtdyia*ddtdxic hessy(2,ic) = hessy(2,ic) + deddt*dyiayic & + d2eddt2*ddtdyia*ddtdyic hessy(3,ic) = hessy(3,ic) + deddt*dyiazic & + d2eddt2*ddtdyia*ddtdzic hessz(1,ic) = hessz(1,ic) + deddt*dziaxic & + d2eddt2*ddtdzia*ddtdxic hessz(2,ic) = hessz(2,ic) + deddt*dziayic & + d2eddt2*ddtdzia*ddtdyic hessz(3,ic) = hessz(3,ic) + deddt*dziazic & + d2eddt2*ddtdzia*ddtdzic else if (ib .eq. iatom) then hessx(1,ib) = hessx(1,ib) + deddt*dxibxib & + d2eddt2*ddtdxib*ddtdxib hessx(2,ib) = hessx(2,ib) + deddt*dxibyib & + d2eddt2*ddtdxib*ddtdyib hessx(3,ib) = hessx(3,ib) + deddt*dxibzib & + d2eddt2*ddtdxib*ddtdzib hessy(1,ib) = hessy(1,ib) + deddt*dxibyib & + d2eddt2*ddtdyib*ddtdxib hessy(2,ib) = hessy(2,ib) + deddt*dyibyib & + d2eddt2*ddtdyib*ddtdyib hessy(3,ib) = hessy(3,ib) + deddt*dyibzib & + d2eddt2*ddtdyib*ddtdzib hessz(1,ib) = hessz(1,ib) + deddt*dxibzib & + d2eddt2*ddtdzib*ddtdxib hessz(2,ib) = hessz(2,ib) + deddt*dyibzib & + d2eddt2*ddtdzib*ddtdyib hessz(3,ib) = hessz(3,ib) + deddt*dzibzib & + d2eddt2*ddtdzib*ddtdzib hessx(1,ia) = hessx(1,ia) + deddt*dxibxia & + d2eddt2*ddtdxib*ddtdxia hessx(2,ia) = hessx(2,ia) + deddt*dxibyia & + d2eddt2*ddtdxib*ddtdyia hessx(3,ia) = hessx(3,ia) + deddt*dxibzia & + d2eddt2*ddtdxib*ddtdzia hessy(1,ia) = hessy(1,ia) + deddt*dyibxia & + d2eddt2*ddtdyib*ddtdxia hessy(2,ia) = hessy(2,ia) + deddt*dyibyia & + d2eddt2*ddtdyib*ddtdyia hessy(3,ia) = hessy(3,ia) + deddt*dyibzia & + d2eddt2*ddtdyib*ddtdzia hessz(1,ia) = hessz(1,ia) + deddt*dzibxia & + d2eddt2*ddtdzib*ddtdxia hessz(2,ia) = hessz(2,ia) + deddt*dzibyia & + d2eddt2*ddtdzib*ddtdyia hessz(3,ia) = hessz(3,ia) + deddt*dzibzia & + d2eddt2*ddtdzib*ddtdzia hessx(1,ic) = hessx(1,ic) + deddt*dxibxic & + d2eddt2*ddtdxib*ddtdxic hessx(2,ic) = hessx(2,ic) + deddt*dxibyic & + d2eddt2*ddtdxib*ddtdyic hessx(3,ic) = hessx(3,ic) + deddt*dxibzic & + d2eddt2*ddtdxib*ddtdzic hessy(1,ic) = hessy(1,ic) + deddt*dyibxic & + d2eddt2*ddtdyib*ddtdxic hessy(2,ic) = hessy(2,ic) + deddt*dyibyic & + d2eddt2*ddtdyib*ddtdyic hessy(3,ic) = hessy(3,ic) + deddt*dyibzic & + d2eddt2*ddtdyib*ddtdzic hessz(1,ic) = hessz(1,ic) + deddt*dzibxic & + d2eddt2*ddtdzib*ddtdxic hessz(2,ic) = hessz(2,ic) + deddt*dzibyic & + d2eddt2*ddtdzib*ddtdyic hessz(3,ic) = hessz(3,ic) + deddt*dzibzic & + d2eddt2*ddtdzib*ddtdzic else if (ic .eq. iatom) then hessx(1,ic) = hessx(1,ic) + deddt*dxicxic & + d2eddt2*ddtdxic*ddtdxic hessx(2,ic) = hessx(2,ic) + deddt*dxicyic & + d2eddt2*ddtdxic*ddtdyic hessx(3,ic) = hessx(3,ic) + deddt*dxiczic & + d2eddt2*ddtdxic*ddtdzic hessy(1,ic) = hessy(1,ic) + deddt*dxicyic & + d2eddt2*ddtdyic*ddtdxic hessy(2,ic) = hessy(2,ic) + deddt*dyicyic & + d2eddt2*ddtdyic*ddtdyic hessy(3,ic) = hessy(3,ic) + deddt*dyiczic & + d2eddt2*ddtdyic*ddtdzic hessz(1,ic) = hessz(1,ic) + deddt*dxiczic & + d2eddt2*ddtdzic*ddtdxic hessz(2,ic) = hessz(2,ic) + deddt*dyiczic & + d2eddt2*ddtdzic*ddtdyic hessz(3,ic) = hessz(3,ic) + deddt*dziczic & + d2eddt2*ddtdzic*ddtdzic hessx(1,ib) = hessx(1,ib) + deddt*dxibxic & + d2eddt2*ddtdxic*ddtdxib hessx(2,ib) = hessx(2,ib) + deddt*dyibxic & + d2eddt2*ddtdxic*ddtdyib hessx(3,ib) = hessx(3,ib) + deddt*dzibxic & + d2eddt2*ddtdxic*ddtdzib hessy(1,ib) = hessy(1,ib) + deddt*dxibyic & + d2eddt2*ddtdyic*ddtdxib hessy(2,ib) = hessy(2,ib) + deddt*dyibyic & + d2eddt2*ddtdyic*ddtdyib hessy(3,ib) = hessy(3,ib) + deddt*dzibyic & + d2eddt2*ddtdyic*ddtdzib hessz(1,ib) = hessz(1,ib) + deddt*dxibzic & + d2eddt2*ddtdzic*ddtdxib hessz(2,ib) = hessz(2,ib) + deddt*dyibzic & + d2eddt2*ddtdzic*ddtdyib hessz(3,ib) = hessz(3,ib) + deddt*dzibzic & + d2eddt2*ddtdzic*ddtdzib hessx(1,ia) = hessx(1,ia) + deddt*dxiaxic & + d2eddt2*ddtdxic*ddtdxia hessx(2,ia) = hessx(2,ia) + deddt*dyiaxic & + d2eddt2*ddtdxic*ddtdyia hessx(3,ia) = hessx(3,ia) + deddt*dziaxic & + d2eddt2*ddtdxic*ddtdzia hessy(1,ia) = hessy(1,ia) + deddt*dxiayic & + d2eddt2*ddtdyic*ddtdxia hessy(2,ia) = hessy(2,ia) + deddt*dyiayic & + d2eddt2*ddtdyic*ddtdyia hessy(3,ia) = hessy(3,ia) + deddt*dziayic & + d2eddt2*ddtdyic*ddtdzia hessz(1,ia) = hessz(1,ia) + deddt*dxiazic & + d2eddt2*ddtdzic*ddtdxia hessz(2,ia) = hessz(2,ia) + deddt*dyiazic & + d2eddt2*ddtdzic*ddtdyia hessz(3,ia) = hessz(3,ia) + deddt*dziazic & + d2eddt2*ddtdzic*ddtdzia end if c c construct a second orthogonal direction for linear angles c if (linear) then linear = .false. xpo = xp ypo = yp zpo = zp xp = ypo*zab - zpo*yab yp = zpo*xab - xpo*zab zp = xpo*yab - ypo*xab rp = sqrt(xp*xp + yp*yp + zp*zp) goto 10 end if end if end if end do return end c c c ################################################################# c ## ## c ## subroutine eangle2b -- in-plane bend Hessian; numerical ## c ## ## c ################################################################# c c c "eangle2b" computes projected in-plane bending first derivatives c for a single angle with respect to Cartesian coordinates; c used in computation of finite difference second derivatives c c subroutine eangle2b (i,de) use angbnd use angpot use atoms use bound use math implicit none integer i,ia,ib,ic,id real*8 eps,ideal,force real*8 dot,cosine,angle real*8 dt,dt2,dt3,dt4 real*8 deddt,term real*8 terma,termc real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 xip,yip,zip real*8 xap,yap,zap real*8 xcp,ycp,zcp real*8 rap2,rcp2 real*8 xt,yt,zt real*8 rt2,ptrt2 real*8 xm,ym,zm,rm real*8 delta,delta2 real*8 dedxia,dedyia,dedzia real*8 dedxib,dedyib,dedzib real*8 dedxic,dedyic,dedzic real*8 dedxid,dedyid,dedzid real*8 dedxip,dedyip,dedzip real*8 dpdxia,dpdyia,dpdzia real*8 dpdxic,dpdyic,dpdzic real*8 de(3,*) c c c set the atom numbers and parameters for this angle c ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) id = iang(4,i) ideal = anat(i) force = ak(i) c c get the coordinates of the atoms in the angle c xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) c c zero out the first derivative components c de(1,ia) = 0.0d0 de(2,ia) = 0.0d0 de(3,ia) = 0.0d0 de(1,ib) = 0.0d0 de(2,ib) = 0.0d0 de(3,ib) = 0.0d0 de(1,ic) = 0.0d0 de(2,ic) = 0.0d0 de(3,ic) = 0.0d0 de(1,id) = 0.0d0 de(2,id) = 0.0d0 de(3,id) = 0.0d0 c c compute the projected in-plane angle gradient c xad = xia - xid yad = yia - yid zad = zia - zid xbd = xib - xid ybd = yib - yid zbd = zib - zid xcd = xic - xid ycd = yic - yid zcd = zic - zid if (use_polymer) then call image (xad,yad,zad) call image (xbd,ybd,zbd) call image (xcd,ycd,zcd) end if xt = yad*zcd - zad*ycd yt = zad*xcd - xad*zcd zt = xad*ycd - yad*xcd rt2 = max(xt*xt+yt*yt+zt*zt,eps) delta = -(xt*xbd + yt*ybd + zt*zbd) / rt2 xip = xib + xt*delta yip = yib + yt*delta zip = zib + zt*delta xap = xia - xip yap = yia - yip zap = zia - zip xcp = xic - xip ycp = yic - yip zcp = zic - zip if (use_polymer) then call image (xap,yap,zap) call image (xcp,ycp,zcp) end if rap2 = max(xap*xap+yap*yap+zap*zap,eps) rcp2 = max(xcp*xcp+ycp*ycp+zcp*zcp,eps) xm = ycp*zap - zcp*yap ym = zcp*xap - xcp*zap zm = xcp*yap - ycp*xap rm = sqrt(max(xm*xm+ym*ym+zm*zm,eps)) dot = xap*xcp + yap*ycp + zap*zcp cosine = dot / sqrt(rap2*rcp2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) c c get the master chain rule term for derivatives c dt = angle - ideal dt2 = dt * dt dt3 = dt2 * dt dt4 = dt2 * dt2 deddt = angunit * force * dt * radian & * (2.0d0 + 3.0d0*cang*dt + 4.0d0*qang*dt2 & + 5.0d0*pang*dt3 + 6.0d0*sang*dt4) c c chain rule terms for first derivative components c terma = -deddt / (rap2*rm) termc = deddt / (rcp2*rm) dedxia = terma * (yap*zm-zap*ym) dedyia = terma * (zap*xm-xap*zm) dedzia = terma * (xap*ym-yap*xm) dedxic = termc * (ycp*zm-zcp*ym) dedyic = termc * (zcp*xm-xcp*zm) dedzic = termc * (xcp*ym-ycp*xm) dedxip = -dedxia - dedxic dedyip = -dedyia - dedyic dedzip = -dedzia - dedzic c c chain rule components for the projection of the central atom c delta2 = 2.0d0 * delta ptrt2 = (dedxip*xt + dedyip*yt + dedzip*zt) / rt2 term = (zcd*ybd-ycd*zbd) + delta2*(yt*zcd-zt*ycd) dpdxia = delta*(ycd*dedzip-zcd*dedyip) + term*ptrt2 term = (xcd*zbd-zcd*xbd) + delta2*(zt*xcd-xt*zcd) dpdyia = delta*(zcd*dedxip-xcd*dedzip) + term*ptrt2 term = (ycd*xbd-xcd*ybd) + delta2*(xt*ycd-yt*xcd) dpdzia = delta*(xcd*dedyip-ycd*dedxip) + term*ptrt2 term = (yad*zbd-zad*ybd) + delta2*(zt*yad-yt*zad) dpdxic = delta*(zad*dedyip-yad*dedzip) + term*ptrt2 term = (zad*xbd-xad*zbd) + delta2*(xt*zad-zt*xad) dpdyic = delta*(xad*dedzip-zad*dedxip) + term*ptrt2 term = (xad*ybd-yad*xbd) + delta2*(yt*xad-xt*yad) dpdzic = delta*(yad*dedxip-xad*dedyip) + term*ptrt2 c c compute derivative components for this interaction c dedxia = dedxia + dpdxia dedyia = dedyia + dpdyia dedzia = dedzia + dpdzia dedxib = dedxip dedyib = dedyip dedzib = dedzip dedxic = dedxic + dpdxic dedyic = dedyic + dpdyic dedzic = dedzic + dpdzic dedxid = -dedxia - dedxib - dedxic dedyid = -dedyia - dedyib - dedyic dedzid = -dedzia - dedzib - dedzic c c set the in-plane angle bending first derivatives c de(1,ia) = dedxia de(2,ia) = dedyia de(3,ia) = dedzia de(1,ib) = dedxib de(2,ib) = dedyib de(3,ib) = dedzib de(1,ic) = dedxic de(2,ic) = dedyic de(3,ic) = dedzic de(1,id) = dedxid de(2,id) = dedyid de(3,id) = dedzid return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine eangle3 -- angle bending energy & analysis ## c ## ## c ############################################################### c c c "eangle3" calculates the angle bending potential energy, also c partitions the energy among the atoms; projected in-plane c angles at trigonal centers, spceial linear or Fourier angle c bending terms are optionally used c c subroutine eangle3 use action use analyz use angbnd use angpot use atomid use atoms use bound use energi use group use inform use iounit use math use usage implicit none integer i,ia,ib,ic,id real*8 e,eps real*8 ideal,force real*8 fold,factor real*8 dot,cosine real*8 angle,fgrp real*8 dt,dt2,dt3,dt4 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 xip,yip,zip real*8 xap,yap,zap real*8 xcp,ycp,zcp real*8 rab2,rcb2 real*8 rap2,rcp2 real*8 xt,yt,zt real*8 rt2,delta logical proceed logical header,huge character*9 label c c c zero out the angle bending energy and partitioning terms c nea = 0 ea = 0.0d0 do i = 1, n aea(i) = 0.0d0 end do if (nangle .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c print header information if debug output was requested c header = .true. if (debug .and. nangle.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Angle Bending Interactions :', & //,' Type',18x,'Atom Names',18x, & 'Ideal',4x,'Actual',6x,'Energy',/) end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nangle,iang,anat,ak,afld, !$OMP& use,x,y,z,cang,qang,pang,sang,angtyp,angunit,eps,use_group, !$OMP& use_polymer,name,verbose,debug,header,iout) !$OMP& shared(ea,nea,aea) !$OMP DO reduction(+:ea,nea,aea) schedule(guided) c c calculate the bond angle bending energy term c do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) id = iang(4,i) ideal = anat(i) force = ak(i) c c decide whether to compute the current interaction c proceed = .true. if (angtyp(i) .eq. 'IN-PLANE') then if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) else if (use_group) call groups (proceed,fgrp,ia,ib,ic,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. use(ic)) end if c c get the coordinates of the atoms in the angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) c c compute the bond angle bending energy c if (angtyp(i) .ne. 'IN-PLANE') then xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib if (use_polymer) then call image (xab,yab,zab) call image (xcb,ycb,zcb) end if rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (angtyp(i) .eq. 'HARMONIC') then dt = angle - ideal dt2 = dt * dt dt3 = dt2 * dt dt4 = dt2 * dt2 e = angunit * force * dt2 & * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4) else if (angtyp(i) .eq. 'LINEAR') then factor = 2.0d0 * angunit * radian**2 e = factor * force * (1.0d0+cosine) else if (angtyp(i) .eq. 'FOURIER') then fold = afld(i) factor = 2.0d0 * angunit * (radian/fold)**2 cosine = cos((fold*angle-ideal)/radian) e = factor * force * (1.0d0+cosine) end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total bond angle bending energy c nea = nea + 1 ea = ea + e aea(ib) = aea(ib) + e c c print a message if the energy of this interaction is large c huge = (e .gt. 5.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Angle Bending', & ' Interactions :', & //,' Type',18x,'Atom Names',18x, & 'Ideal',4x,'Actual',6x,'Energy',/) end if label = 'Angle ' if (angtyp(i) .eq. 'LINEAR') then label = 'Angle-Lin' else if (angtyp(i) .eq. 'FOURIER') then label = 'Angle-Cos' ideal = (ideal+180.0d0) / fold if (angle-ideal .gt. 180.0d0/fold) & ideal = ideal + 360.0d0/fold end if write (iout,30) label,ia,name(ia),ib,name(ib), & ic,name(ic),ideal,angle,e 30 format (1x,a9,1x,i7,'-',a3,i7,'-',a3,i7, & '-',a3,2x,2f10.4,f12.4) end if c c compute the projected in-plane angle bend energy c else xid = x(id) yid = y(id) zid = z(id) xad = xia - xid yad = yia - yid zad = zia - zid xbd = xib - xid ybd = yib - yid zbd = zib - zid xcd = xic - xid ycd = yic - yid zcd = zic - zid if (use_polymer) then call image (xad,yad,zad) call image (xbd,ybd,zbd) call image (xcd,ycd,zcd) end if xt = yad*zcd - zad*ycd yt = zad*xcd - xad*zcd zt = xad*ycd - yad*xcd rt2 = xt*xt + yt*yt + zt*zt delta = -(xt*xbd + yt*ybd + zt*zbd) / rt2 xip = xib + xt*delta yip = yib + yt*delta zip = zib + zt*delta xap = xia - xip yap = yia - yip zap = zia - zip xcp = xic - xip ycp = yic - yip zcp = zic - zip if (use_polymer) then call image (xap,yap,zap) call image (xcp,ycp,zcp) end if rap2 = max(xap*xap+yap*yap+zap*zap,eps) rcp2 = max(xcp*xcp+ycp*ycp+zcp*zcp,eps) dot = xap*xcp + yap*ycp + zap*zcp cosine = dot / sqrt(rap2*rcp2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) dt = angle - ideal dt2 = dt * dt dt3 = dt2 * dt dt4 = dt2 * dt2 e = angunit * force * dt2 & * (1.0d0+cang*dt+qang*dt2+pang*dt3+sang*dt4) c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total bond angle bending energy c nea = nea + 1 ea = ea + e aea(ib) = aea(ib) + e c c print a message if the energy of this interaction is large c huge = (e .gt. 5.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual Angle Bending', & ' Interactions :', & //,' Type',18x,'Atom Names',18x, & 'Ideal',4x,'Actual',6x,'Energy',/) end if write (iout,50) ia,name(ia),ib,name(ib),ic, & name(ic),ideal,angle,e 50 format (' Angle-IP',2x,i7,'-',a3,i7,'-',a3,i7, & '-',a3,2x,2f10.4,f12.4) end if end if end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ########################################################## c ## COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder ## c ## All Rights Reserved ## c ########################################################## c c ############################################################### c ## ## c ## subroutine eangtor -- angle-torsion cross term energy ## c ## ## c ############################################################### c c c "eangtor" calculates the angle-torsion potential energy c c subroutine eangtor use angtor use atoms use angbnd use bound use energi use group use math use torpot use tors use usage implicit none integer i,k,iangtor integer ia,ib,ic,id real*8 e,e1,e2 real*8 eps,fgrp real*8 rba,rcb,rdc real*8 rt2,ru2,rtru real*8 dot,dt real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 v1,v2,v3 real*8 c1,c2,c3 real*8 s1,s2,s3 real*8 sine,cosine real*8 sine2,cosine2 real*8 sine3,cosine3 real*8 phi1,phi2,phi3 real*8 angle,cosang real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc logical proceed c c c zero out the energy due to extra potential terms c eat = 0.0d0 if (nangtor .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nangtor,iat,itors,kant,anat, !$OMP& tors1,tors2,tors3,use,x,y,z,atorunit,eps,use_group,use_polymer) !$OMP& shared(eat) !$OMP DO reduction(+:eat) schedule(guided) c c calculate the angle-torsion interaction energy term c do iangtor = 1, nangtor i = iat(1,iangtor) ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) c c compute the value of the torsional angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rba = sqrt(max(xba*xba+yba*yba+zba*zba,eps)) rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) rdc = sqrt(max(xdc*xdc+ydc*ydc+zdc*zdc,eps)) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2*ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) c c compute multiple angle trigonometry and phase terms c c1 = tors1(3,i) s1 = tors1(4,i) c2 = tors2(3,i) s2 = tors2(4,i) c3 = tors3(3,i) s3 = tors3(4,i) cosine2 = cosine*cosine - sine*sine sine2 = 2.0d0 * cosine * sine cosine3 = cosine*cosine2 - sine*sine2 sine3 = cosine*sine2 + sine*cosine2 phi1 = 1.0d0 + (cosine*c1 + sine*s1) phi2 = 1.0d0 + (cosine2*c2 + sine2*s2) phi3 = 1.0d0 + (cosine3*c3 + sine3*s3) c c get the angle-torsion values for the first angle c v1 = kant(1,iangtor) v2 = kant(2,iangtor) v3 = kant(3,iangtor) k = iat(2,iangtor) dot = xba*xcb + yba*ycb + zba*zcb cosang = -dot / (rba*rcb) angle = radian * acos(cosang) dt = angle - anat(k) e1 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3) c c get the angle-torsion values for the second angle c v1 = kant(4,iangtor) v2 = kant(5,iangtor) v3 = kant(6,iangtor) k = iat(3,iangtor) dot = xcb*xdc + ycb*ydc + zcb*zdc cosang = -dot / (rcb*rdc) angle = radian * acos(cosang) dt = angle - anat(k) e2 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3) c c scale the interaction based on its group membership c if (use_group) then e1 = e1 * fgrp e2 = e2 * fgrp end if c c increment the total angle-torsion energy c e = e1 + e2 eat = eat + e end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ########################################################## c ## COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder ## c ## All Rights Reserved ## c ########################################################## c c ############################################################## c ## ## c ## subroutine eangtor1 -- angle-torsion energy & derivs ## c ## ## c ############################################################## c c c "eangtor1" calculates the angle-torsion energy and first c derivatives with respect to Cartesian coordinates c c subroutine eangtor1 use angbnd use angtor use atoms use bound use deriv use energi use group use math use torpot use tors use usage use virial implicit none integer i,k,iangtor integer ia,ib,ic,id real*8 e,e1,e2 real*8 eps,fgrp real*8 ddt,dedphi real*8 rba,rcb,rdc real*8 rba2,rcb2,rdc2 real*8 rt,ru,rtru real*8 rt2,ru2 real*8 dot,dt real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 v1,v2,v3 real*8 c1,c2,c3 real*8 s1,s2,s3 real*8 sine,cosine real*8 sine2,cosine2 real*8 sine3,cosine3 real*8 phi1,phi2,phi3 real*8 dphi1,dphi2,dphi3 real*8 angle,cosang real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 xca,yca,zca real*8 xdb,ydb,zdb real*8 terma,termb real*8 termc,termd real*8 dedxt,dedyt,dedzt real*8 dedxu,dedyu,dedzu real*8 dedxia,dedyia,dedzia real*8 dedxib,dedyib,dedzib real*8 dedxic,dedyic,dedzic real*8 dedxid,dedyid,dedzid real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy logical proceed c c c zero out the angle-torsion energy and first derivatives c eat = 0.0d0 do i = 1, n deat(1,i) = 0.0d0 deat(2,i) = 0.0d0 deat(3,i) = 0.0d0 end do if (nangtor .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nangtor,iat,itors,kant,anat, !$OMP& tors1,tors2,tors3,use,x,y,z,atorunit,eps,use_group,use_polymer) !$OMP& shared(eat,deat,vir) !$OMP DO reduction(+:eat,deat,vir) schedule(guided) c c calculate the angle-torsion energy and first derviatives c do iangtor = 1, nangtor i = iat(1,iangtor) ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) c c compute the value of the torsional angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rba2 = max(xba*xba+yba*yba+zba*zba,eps) rba = sqrt(rba2) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) rcb = sqrt(rcb2) rdc2 = max(xdc*xdc+ydc*ydc+zdc*zdc,eps) rdc = sqrt(rdc2) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) rt = sqrt(rt2) ru2 = max(xu*xu+yu*yu+zu*zu,eps) ru = sqrt(ru2) rtru = rt * ru xca = xic - xia yca = yic - yia zca = zic - zia xdb = xid - xib ydb = yid - yib zdb = zid - zib if (use_polymer) then call image (xca,yca,zca) call image (xdb,ydb,zdb) end if cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) c c compute multiple angle trigonometry and phase terms c c1 = tors1(3,i) s1 = tors1(4,i) c2 = tors2(3,i) s2 = tors2(4,i) c3 = tors3(3,i) s3 = tors3(4,i) cosine2 = cosine*cosine - sine*sine sine2 = 2.0d0 * cosine * sine cosine3 = cosine*cosine2 - sine*sine2 sine3 = cosine*sine2 + sine*cosine2 phi1 = 1.0d0 + (cosine*c1 + sine*s1) phi2 = 1.0d0 + (cosine2*c2 + sine2*s2) phi3 = 1.0d0 + (cosine3*c3 + sine3*s3) dphi1 = (cosine*s1 - sine*c1) dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2) dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3) c c set the angle-torsion parameters for the first angle c v1 = kant(1,iangtor) v2 = kant(2,iangtor) v3 = kant(3,iangtor) k = iat(2,iangtor) dot = xba*xcb + yba*ycb + zba*zcb cosang = -dot / (rba*rcb) angle = radian * acos(cosang) dt = angle - anat(k) e1 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3) dedphi = atorunit * dt * (v1*dphi1 + v2*dphi2 + v3*dphi3) ddt = atorunit * radian * (v1*phi1 + v2*phi2 + v3*phi3) c c scale the interaction based on its group membership c if (use_group) then e1 = e1 * fgrp dedphi = dedphi * fgrp ddt = ddt * fgrp end if c c compute derivative components for this interaction c dedxt = dedphi * (zcb*yt-ycb*zt) / (rt2*rcb) dedyt = dedphi * (xcb*zt-zcb*xt) / (rt2*rcb) dedzt = dedphi * (ycb*xt-xcb*yt) / (rt2*rcb) dedxu = dedphi * (ycb*zu-zcb*yu) / (ru2*rcb) dedyu = dedphi * (zcb*xu-xcb*zu) / (ru2*rcb) dedzu = dedphi * (xcb*yu-ycb*xu) / (ru2*rcb) c c increment chain rule components for the first angle c terma = -ddt / (rba2*rt) termc = ddt / (rcb2*rt) dedxia = terma*(zba*yt-yba*zt) + zcb*dedyt - ycb*dedzt dedyia = terma*(xba*zt-zba*xt) + xcb*dedzt - zcb*dedxt dedzia = terma*(yba*xt-xba*yt) + ycb*dedxt - xcb*dedyt dedxib = terma*(yba*zt-zba*yt) + termc*(zcb*yt-ycb*zt) & + yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu dedyib = terma*(zba*xt-xba*zt) + termc*(xcb*zt-zcb*xt) & + zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu dedzib = terma*(xba*yt-yba*xt) + termc*(ycb*xt-xcb*yt) & + xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu dedxic = termc*(ycb*zt-zcb*yt) + zba*dedyt & - yba*dedzt + ydb*dedzu - zdb*dedyu dedyic = termc*(zcb*xt-xcb*zt) + xba*dedzt & - zba*dedxt + zdb*dedxu - xdb*dedzu dedzic = termc*(xcb*yt-ycb*xt) + yba*dedxt & - xba*dedyt + xdb*dedyu - ydb*dedxu dedxid = zcb*dedyu - ycb*dedzu dedyid = xcb*dedzu - zcb*dedxu dedzid = ycb*dedxu - xcb*dedyu c c get the angle-torsion values for the second angle c v1 = kant(4,iangtor) v2 = kant(5,iangtor) v3 = kant(6,iangtor) k = iat(3,iangtor) dot = xcb*xdc + ycb*ydc + zcb*zdc cosang = -dot / (rcb*rdc) angle = radian * acos(cosang) dt = angle - anat(k) e2 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3) dedphi = atorunit * dt * (v1*dphi1 + v2*dphi2 + v3*dphi3) ddt = atorunit * radian * (v1*phi1 + v2*phi2 + v3*phi3) c c scale the interaction based on its group membership c if (use_group) then e2 = e2 * fgrp dedphi = dedphi * fgrp ddt = ddt * fgrp end if c c compute derivative components for this interaction c dedxt = dedphi * (zcb*yt-ycb*zt) / (rt2*rcb) dedyt = dedphi * (xcb*zt-zcb*xt) / (rt2*rcb) dedzt = dedphi * (ycb*xt-xcb*yt) / (rt2*rcb) dedxu = dedphi * (ycb*zu-zcb*yu) / (ru2*rcb) dedyu = dedphi * (zcb*xu-xcb*zu) / (ru2*rcb) dedzu = dedphi * (xcb*yu-ycb*xu) / (ru2*rcb) c c increment chain rule components for the second angle c termb = -ddt / (rcb2*ru) termd = ddt / (rdc2*ru) dedxia = dedxia + zcb*dedyt - ycb*dedzt dedyia = dedyia + xcb*dedzt - zcb*dedxt dedzia = dedzia + ycb*dedxt - xcb*dedyt dedxib = dedxib + termb*(zcb*yu-ycb*zu) + yca*dedzt & - zca*dedyt + zdc*dedyu - ydc*dedzu dedyib = dedyib + termb*(xcb*zu-zcb*xu) + zca*dedxt & - xca*dedzt + xdc*dedzu - zdc*dedxu dedzib = dedzib + termb*(ycb*xu-xcb*yu) + xca*dedyt & - yca*dedxt + ydc*dedxu - xdc*dedyu dedxic = dedxic + termb*(ycb*zu-zcb*yu) & + termd*(zdc*yu-ydc*zu) + zba*dedyt & - yba*dedzt + ydb*dedzu - zdb*dedyu dedyic = dedyic + termb*(zcb*xu-xcb*zu) & + termd*(xdc*zu-zdc*xu) + xba*dedzt & - zba*dedxt + zdb*dedxu - xdb*dedzu dedzic = dedzic + termb*(xcb*yu-ycb*xu) & + termd*(ydc*xu-xdc*yu) + yba*dedxt & - xba*dedyt + xdb*dedyu - ydb*dedxu dedxid = dedxid + termd*(ydc*zu-zdc*yu) & + zcb*dedyu - ycb*dedzu dedyid = dedyid + termd*(zdc*xu-xdc*zu) & + xcb*dedzu - zcb*dedxu dedzid = dedzid + termd*(xdc*yu-ydc*xu) & + ycb*dedxu - xcb*dedyu c c increment the angle-torsion energy and gradient c e = e1 + e2 eat = eat + e deat(1,ia) = deat(1,ia) + dedxia deat(2,ia) = deat(2,ia) + dedyia deat(3,ia) = deat(3,ia) + dedzia deat(1,ib) = deat(1,ib) + dedxib deat(2,ib) = deat(2,ib) + dedyib deat(3,ib) = deat(3,ib) + dedzib deat(1,ic) = deat(1,ic) + dedxic deat(2,ic) = deat(2,ic) + dedyic deat(3,ic) = deat(3,ic) + dedzic deat(1,id) = deat(1,id) + dedxid deat(2,id) = deat(2,id) + dedyid deat(3,id) = deat(3,id) + dedzid c c increment the internal virial tensor components c vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ########################################################## c ## COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder ## c ## All Rights Reserved ## c ########################################################## c c ############################################################### c ## ## c ## subroutine eangtor2 -- atomwise angle-torsion Hessian ## c ## ## c ############################################################### c c c "eangtor2" calculates the angle-torsion potential energy c second derivatives with respect to Cartesian coordinates c c subroutine eangtor2 (i) use angbnd use angtor use atoms use bound use group use hessn use math use torpot use tors implicit none integer i,j,k,iangtor integer ia,ib,ic,id real*8 eps,fgrp real*8 dedphi,d2edphi2 real*8 rba,rcb,rdc real*8 rba2,rcb2,rdc2 real*8 rt,ru,rtru real*8 rt2,ru2 real*8 dot,dt,d2dt real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 v1,v2,v3 real*8 c1,c2,c3 real*8 s1,s2,s3 real*8 terma,termb real*8 termc,termd real*8 sine,cosine real*8 sine2,cosine2 real*8 sine3,cosine3 real*8 angle,cosang real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 xca,yca,zca real*8 xdb,ydb,zdb real*8 xab,yab,zab real*8 xbc,ybc,zbc real*8 xrab,yrab,zrab real*8 xrcb,yrcb,zrcb real*8 xabp,yabp,zabp real*8 xcbp,ycbp,zcbp real*8 xrbc,yrbc,zrbc real*8 xrdc,yrdc,zrdc real*8 xbcp,ybcp,zbcp real*8 xdcp,ydcp,zdcp real*8 phi1,phi2,phi3 real*8 dphi1,dphi2,dphi3 real*8 d2phi1,d2phi2,d2phi3 real*8 dphidxt,dphidyt,dphidzt real*8 dphidxu,dphidyu,dphidzu real*8 dphidxia,dphidyia,dphidzia real*8 dphidxib,dphidyib,dphidzib real*8 dphidxic,dphidyic,dphidzic real*8 dphidxid,dphidyid,dphidzid real*8 xycb2,xzcb2,yzcb2 real*8 rcbxt,rcbyt,rcbzt,rcbt2 real*8 rcbxu,rcbyu,rcbzu,rcbu2 real*8 dphidxibt,dphidyibt,dphidzibt real*8 dphidxibu,dphidyibu,dphidzibu real*8 dphidxict,dphidyict,dphidzict real*8 dphidxicu,dphidyicu,dphidzicu real*8 dxia,dyia,dzia real*8 dxib,dyib,dzib real*8 dxic,dyic,dzic real*8 dxid,dyid,dzid real*8 dxiaxia,dyiayia,dziazia real*8 dxibxib,dyibyib,dzibzib real*8 dxicxic,dyicyic,dziczic real*8 dxidxid,dyidyid,dzidzid real*8 dxiayia,dxiazia,dyiazia real*8 dxibyib,dxibzib,dyibzib real*8 dxicyic,dxiczic,dyiczic real*8 dxidyid,dxidzid,dyidzid real*8 dxiaxib,dxiayib,dxiazib real*8 dyiaxib,dyiayib,dyiazib real*8 dziaxib,dziayib,dziazib real*8 dxiaxic,dxiayic,dxiazic real*8 dyiaxic,dyiayic,dyiazic real*8 dziaxic,dziayic,dziazic real*8 dxiaxid,dxiayid,dxiazid real*8 dyiaxid,dyiayid,dyiazid real*8 dziaxid,dziayid,dziazid real*8 dxibxic,dxibyic,dxibzic real*8 dyibxic,dyibyic,dyibzic real*8 dzibxic,dzibyic,dzibzic real*8 dxibxid,dxibyid,dxibzid real*8 dyibxid,dyibyid,dyibzid real*8 dzibxid,dzibyid,dzibzid real*8 dxicxid,dxicyid,dxiczid real*8 dyicxid,dyicyid,dyiczid real*8 dzicxid,dzicyid,dziczid real*8 domegadxia,domegadyia,domegadzia real*8 domegadxib,domegadyib,domegadzib real*8 domegadxic,domegadyic,domegadzic real*8 domegadxid,domegadyid,domegadzid real*8 doxiaxia,doyiayia,doziazia real*8 doxibxib,doyibyib,dozibzib real*8 doxicxic,doyicyic,doziczic real*8 doxidxid,doyidyid,dozidzid real*8 doxiayia,doxiazia,doyiazia real*8 doxibyib,doxibzib,doyibzib real*8 doxicyic,doxiczic,doyiczic real*8 doxidyid,doxidzid,doyidzid real*8 doxiaxic,doxiayic,doxiazic real*8 doyiaxic,doyiayic,doyiazic real*8 doziaxic,doziayic,doziazic real*8 doxibxic,doxibyic,doxibzic real*8 doyibxic,doyibyic,doyibzic real*8 dozibxic,dozibyic,dozibzic real*8 doxibxid,doxibyid,doxibzid real*8 doyibxid,doyibyid,doyibzid real*8 dozibxid,dozibyid,dozibzid real*8 doxicxid,doxicyid,doxiczid real*8 doyicxid,doyicyid,doyiczid real*8 dozicxid,dozicyid,doziczid real*8 doxibxia,doxibyia,doxibzia real*8 doyibxia,doyibyia,doyibzia real*8 dozibxia,dozibyia,dozibzia real*8 doxicxib,doxicyib,doxiczib real*8 doyicxib,doyicyib,doyiczib real*8 dozicxib,dozicyib,doziczib logical proceed c c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c calculate the angle-torsion interaction Hessian elements c do iangtor = 1, nangtor j = iat(1,iangtor) ia = itors(1,j) ib = itors(2,j) ic = itors(3,j) id = itors(4,j) c c decide whether to compute the current interaction c 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) c c compute the value of the torsional angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic xab = -xba yab = -yba zab = -zba xbc = -xcb ybc = -ycb zbc = -zcb if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) call image (xab,yab,zab) call image (xbc,ybc,zbc) end if rba2 = max(xba*xba+yba*yba+zba*zba,eps) rba = sqrt(rba2) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) rcb = sqrt(rcb2) rdc2 = max(xdc*xdc+ydc*ydc+zdc*zdc,eps) rdc = sqrt(rdc2) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) rt = sqrt(rt2) ru2 = max(xu*xu+yu*yu+zu*zu,eps) ru = sqrt(ru2) rtru = rt * ru xca = xic - xia yca = yic - yia zca = zic - zia xdb = xid - xib ydb = yid - yib zdb = zid - zib if (use_polymer) then call image (xca,yca,zca) call image (xdb,ydb,zdb) end if cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) c c compute multiple angle trigonometry and phase terms c c1 = tors1(3,i) s1 = tors1(4,i) c2 = tors2(3,i) s2 = tors2(4,i) c3 = tors3(3,i) s3 = tors3(4,i) cosine2 = cosine*cosine - sine*sine sine2 = 2.0d0 * cosine * sine cosine3 = cosine*cosine2 - sine*sine2 sine3 = cosine*sine2 + sine*cosine2 phi1 = 1.0d0 + (cosine*c1 + sine*s1) phi2 = 1.0d0 + (cosine2*c2 + sine2*s2) phi3 = 1.0d0 + (cosine3*c3 + sine3*s3) dphi1 = (cosine*s1 - sine*c1) dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2) dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3) d2phi1 = -(cosine*c1 + sine*s1) d2phi2 = -4.0d0 * (cosine2*c2 + sine2*s2) d2phi3 = -9.0d0 * (cosine3*c3 + sine3*s3) c c set the angle-torsion parameters for the first angle c v1 = kant(1,iangtor) v2 = kant(2,iangtor) v3 = kant(3,iangtor) k = iat(2,iangtor) dot = xab*xcb + yab*ycb + zab*zcb cosang = dot / (rba*rcb) angle = radian * acos(cosang) dt = angle - anat(k) dedphi = atorunit * (v1*dphi1 + v2*dphi2 + v3*dphi3) d2edphi2 = atorunit * dt & * (v1*d2phi1 + v2* d2phi2 + v3*d2phi3) d2dt = atorunit * radian * (v1*phi1 + v2*phi2 + v3*phi3) c c scale the interaction based on its group membership c if (use_group) then dedphi = dedphi * fgrp d2edphi2 = d2edphi2 * fgrp d2dt = d2dt * fgrp end if c c first and second derivative components for the first angle c terma = -1.0d0 / (rba2*rt) termc = 1.0d0 / (rcb2*rt) domegadxia = terma * (zba*yt-yba*zt) domegadyia = terma * (xba*zt-zba*xt) domegadzia = terma * (yba*xt-xba*yt) domegadxic = termc * (ycb*zt-zcb*yt) domegadyic = termc * (zcb*xt-xcb*zt) domegadzic = termc * (xcb*yt-ycb*xt) domegadxib = -domegadxia - domegadxic domegadyib = -domegadyia - domegadyic domegadzib = -domegadzia - domegadzic c c abbreviations used in defining chain rule terms c xrab = 2.0d0 * xab / rba2 yrab = 2.0d0 * yab / rba2 zrab = 2.0d0 * zab / rba2 xrcb = 2.0d0 * xcb / rcb2 yrcb = 2.0d0 * ycb / rcb2 zrcb = 2.0d0 * zcb / rcb2 xabp = (yab*zt-zab*yt) / rt2 yabp = (zab*xt-xab*zt) / rt2 zabp = (xab*yt-yab*xt) / rt2 xcbp = (ycb*zt-zcb*yt) / rt2 ycbp = (zcb*xt-xcb*zt) / rt2 zcbp = (xcb*yt-ycb*xt) / rt2 c c chain rule terms for second derivative components c doxiaxia = terma*(xab*xcb-dot) + domegadxia*(xcbp-xrab) doxiayia = terma*(zt+yab*xcb) + domegadxia*(ycbp-yrab) doxiazia = terma*(zab*xcb-yt) + domegadxia*(zcbp-zrab) doyiayia = terma*(yab*ycb-dot) + domegadyia*(ycbp-yrab) doyiazia = terma*(xt+zab*ycb) + domegadyia*(zcbp-zrab) doziazia = terma*(zab*zcb-dot) + domegadzia*(zcbp-zrab) doxicxic = termc*(dot-xab*xcb) - domegadxic*(xabp+xrcb) doxicyic = termc*(zt-ycb*xab) - domegadxic*(yabp+yrcb) doxiczic = -termc*(yt+zcb*xab) - domegadxic*(zabp+zrcb) doyicyic = termc*(dot-yab*ycb) - domegadyic*(yabp+yrcb) doyiczic = termc*(xt-zcb*yab) - domegadyic*(zabp+zrcb) doziczic = termc*(dot-zab*zcb) - domegadzic*(zabp+zrcb) doxiaxic = terma*(yab*yab+zab*zab) - domegadxia*xabp doxiayic = -terma*xab*yab - domegadxia*yabp doxiazic = -terma*xab*zab - domegadxia*zabp doyiaxic = -terma*xab*yab - domegadyia*xabp doyiayic = terma*(xab*xab+zab*zab) - domegadyia*yabp doyiazic = -terma*yab*zab - domegadyia*zabp doziaxic = -terma*xab*zab - domegadzia*xabp doziayic = -terma*yab*zab - domegadzia*yabp doziazic = terma*(xab*xab+yab*yab) - domegadzia*zabp c c get some second derivative chain rule terms by difference c doxibxia = -doxiaxia - doxiaxic doxibyia = -doxiayia - doyiaxic doxibzia = -doxiazia - doziaxic doyibxia = -doxiayia - doxiayic doyibyia = -doyiayia - doyiayic doyibzia = -doyiazia - doziayic dozibxia = -doxiazia - doxiazic dozibyia = -doyiazia - doyiazic dozibzia = -doziazia - doziazic doxibxic = -doxicxic - doxiaxic doxibyic = -doxicyic - doxiayic doxibzic = -doxiczic - doxiazic doyibxic = -doxicyic - doyiaxic doyibyic = -doyicyic - doyiayic doyibzic = -doyiczic - doyiazic dozibxic = -doxiczic - doziaxic dozibyic = -doyiczic - doziayic dozibzic = -doziczic - doziazic doxibxib = -doxibxia - doxibxic doxibyib = -doxibyia - doxibyic doxibzib = -doxibzia - doxibzic doyibyib = -doyibyia - doyibyic doyibzib = -doyibzia - doyibzic dozibzib = -dozibzia - dozibzic c c scale the first derivatives of the first angle c domegadxia = domegadxia * radian domegadyia = domegadyia * radian domegadzia = domegadzia * radian domegadxic = domegadxic * radian domegadyic = domegadyic * radian domegadzic = domegadzic * radian domegadxib = domegadxib * radian domegadyib = domegadyib * radian domegadzib = domegadzib * radian c c scale the second derivatives of the first angle c doxiaxia = doxiaxia * d2dt doxiayia = doxiayia * d2dt doxiazia = doxiazia * d2dt doyiayia = doyiayia * d2dt doyiazia = doyiazia * d2dt doziazia = doziazia * d2dt doxicxic = doxicxic * d2dt doxicyic = doxicyic * d2dt doxiczic = doxiczic * d2dt doyicyic = doyicyic * d2dt doyiczic = doyiczic * d2dt doziczic = doziczic * d2dt doxiaxic = doxiaxic * d2dt doxiayic = doxiayic * d2dt doxiazic = doxiazic * d2dt doyiaxic = doyiaxic * d2dt doyiayic = doyiayic * d2dt doyiazic = doyiazic * d2dt doziaxic = doziaxic * d2dt doziayic = doziayic * d2dt doziazic = doziazic * d2dt doxibxia = doxibxia * d2dt doxibyia = doxibyia * d2dt doxibzia = doxibzia * d2dt doyibxia = doyibxia * d2dt doyibyia = doyibyia * d2dt doyibzia = doyibzia * d2dt dozibxia = dozibxia * d2dt dozibyia = dozibyia * d2dt dozibzia = dozibzia * d2dt doxibxic = doxibxic * d2dt doxibyic = doxibyic * d2dt doxibzic = doxibzic * d2dt doyibxic = doyibxic * d2dt doyibyic = doyibyic * d2dt doyibzic = doyibzic * d2dt dozibxic = dozibxic * d2dt dozibyic = dozibyic * d2dt dozibzic = dozibzic * d2dt doxibxib = doxibxib * d2dt doxibyib = doxibyib * d2dt doxibzib = doxibzib * d2dt doyibyib = doyibyib * d2dt doyibzib = doyibzib * d2dt dozibzib = dozibzib * d2dt c c abbreviations for first derivative chain rule terms c dphidxt = (yt*zcb-ycb*zt) / (rt2*rcb) dphidyt = (zt*xcb-zcb*xt) / (rt2*rcb) dphidzt = (xt*ycb-xcb*yt) / (rt2*rcb) dphidxu = -(yu*zcb-ycb*zu) / (ru2*rcb) dphidyu = -(zu*xcb-zcb*xu) / (ru2*rcb) dphidzu = -(xu*ycb-xcb*yu) / (ru2*rcb) c c abbreviations for second derivative chain rule terms c xycb2 = xcb*xcb + ycb*ycb xzcb2 = xcb*xcb + zcb*zcb yzcb2 = ycb*ycb + zcb*zcb rcbxt = -2.0d0 * rcb * dphidxt rcbyt = -2.0d0 * rcb * dphidyt rcbzt = -2.0d0 * rcb * dphidzt rcbt2 = rcb * rt2 rcbxu = 2.0d0 * rcb * dphidxu rcbyu = 2.0d0 * rcb * dphidyu rcbzu = 2.0d0 * rcb * dphidzu rcbu2 = rcb * ru2 dphidxibt = yca*dphidzt - zca*dphidyt dphidxibu = zdc*dphidyu - ydc*dphidzu dphidyibt = zca*dphidxt - xca*dphidzt dphidyibu = xdc*dphidzu - zdc*dphidxu dphidzibt = xca*dphidyt - yca*dphidxt dphidzibu = ydc*dphidxu - xdc*dphidyu dphidxict = zba*dphidyt - yba*dphidzt dphidxicu = ydb*dphidzu - zdb*dphidyu dphidyict = xba*dphidzt - zba*dphidxt dphidyicu = zdb*dphidxu - xdb*dphidzu dphidzict = yba*dphidxt - xba*dphidyt dphidzicu = xdb*dphidyu - ydb*dphidxu c c intermediate terms for first derivative components c dphidxia = zcb*dphidyt - ycb*dphidzt dphidyia = xcb*dphidzt - zcb*dphidxt dphidzia = ycb*dphidxt - xcb*dphidyt dphidxib = dphidxibt + dphidxibu dphidyib = dphidyibt + dphidyibu dphidzib = dphidzibt + dphidzibu dphidxic = dphidxict + dphidxicu dphidyic = dphidyict + dphidyicu dphidzic = dphidzict + dphidzicu dphidxid = zcb*dphidyu - ycb*dphidzu dphidyid = xcb*dphidzu - zcb*dphidxu dphidzid = ycb*dphidxu - xcb*dphidyu c c chain rule terms for first derivative components c dxia = dedphi * dphidxia dyia = dedphi * dphidyia dzia = dedphi * dphidzia dxib = dedphi * dphidxib dyib = dedphi * dphidyib dzib = dedphi * dphidzib dxic = dedphi * dphidxic dyic = dedphi * dphidyic dzic = dedphi * dphidzic dxid = dedphi * dphidxid dyid = dedphi * dphidyid dzid = dedphi * dphidzid dedphi = dedphi * dt c c chain rule terms for second derivative components c dxiaxia = rcbxt*dphidxia dxiayia = rcbxt*dphidyia - zcb*rcb/rt2 dxiazia = rcbxt*dphidzia + ycb*rcb/rt2 dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2 dxiayic = rcbxt*dphidyict - dphidzt & - (xba*zcb*xcb+zba*yzcb2)/rcbt2 dxiazic = rcbxt*dphidzict + dphidyt & + (xba*ycb*xcb+yba*yzcb2)/rcbt2 dxiaxid = 0.0d0 dxiayid = 0.0d0 dxiazid = 0.0d0 dyiayia = rcbyt*dphidyia dyiazia = rcbyt*dphidzia - xcb*rcb/rt2 dyiaxib = rcbyt*dphidxibt - dphidzt & - (yca*zcb*ycb+zca*xzcb2)/rcbt2 dyiaxic = rcbyt*dphidxict + dphidzt & + (yba*zcb*ycb+zba*xzcb2)/rcbt2 dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2 dyiazic = rcbyt*dphidzict - dphidxt & - (yba*xcb*ycb+xba*xzcb2)/rcbt2 dyiaxid = 0.0d0 dyiayid = 0.0d0 dyiazid = 0.0d0 dziazia = rcbzt*dphidzia dziaxib = rcbzt*dphidxibt + dphidyt & + (zca*ycb*zcb+yca*xycb2)/rcbt2 dziayib = rcbzt*dphidyibt - dphidxt & - (zca*xcb*zcb+xca*xycb2)/rcbt2 dziaxic = rcbzt*dphidxict - dphidyt & - (zba*ycb*zcb+yba*xycb2)/rcbt2 dziayic = rcbzt*dphidyict + dphidxt & + (zba*xcb*zcb+xba*xycb2)/rcbt2 dziazic = rcbzt*dphidzict + zcb*zt/rcbt2 dziaxid = 0.0d0 dziayid = 0.0d0 dziazid = 0.0d0 dxibxic = -xcb*dphidxib/(rcb*rcb) & - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2 & - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2 dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu & - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2 & - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2 & + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2 & + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2 dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2 dxibyid = rcbyu*dphidxibu - dphidzu & - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2 dxibzid = rcbzu*dphidxibu + dphidyu & + (zdc*ycb*zcb+ydc*xycb2)/rcbu2 dyibzib = ycb*dphidzib/(rcb*rcb) & - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2 & - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2 & + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2 & + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2 dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu & + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2 & - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2 dyibyic = -ycb*dphidyib/(rcb*rcb) & - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2 & - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2 & - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2 & + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2 dyibxid = rcbxu*dphidyibu + dphidzu & + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2 dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2 dyibzid = rcbzu*dphidyibu - dphidxu & - (zdc*xcb*zcb+xdc*xycb2)/rcbu2 dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu & - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2 & + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2 dzibzic = -zcb*dphidzib/(rcb*rcb) & - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2 & - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2 & - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2 & + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2 dzibxid = rcbxu*dphidzibu - dphidyu & - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2 dzibyid = rcbyu*dphidzibu + dphidxu & + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2 dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2 dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2 dxicyid = rcbyu*dphidxicu + dphidzu & + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2 dxiczid = rcbzu*dphidxicu - dphidyu & - (zdb*ycb*zcb+ydb*xycb2)/rcbu2 dyicxid = rcbxu*dphidyicu - dphidzu & - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2 dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2 dyiczid = rcbzu*dphidyicu + dphidxu & + (zdb*xcb*zcb+xdb*xycb2)/rcbu2 dzicxid = rcbxu*dphidzicu + dphidyu & + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2 dzicyid = rcbyu*dphidzicu - dphidxu & - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2 dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2 dxidxid = rcbxu*dphidxid dxidyid = rcbxu*dphidyid + zcb*rcb/ru2 dxidzid = rcbxu*dphidzid - ycb*rcb/ru2 dyidyid = rcbyu*dphidyid dyidzid = rcbyu*dphidzid + xcb*rcb/ru2 dzidzid = rcbzu*dphidzid c c get some second derivative chain rule terms by difference c dxiaxib = -dxiaxia - dxiaxic - dxiaxid dxiayib = -dxiayia - dxiayic - dxiayid dxiazib = -dxiazia - dxiazic - dxiazid dyiayib = -dyiayia - dyiayic - dyiayid dyiazib = -dyiazia - dyiazic - dyiazid dziazib = -dziazia - dziazic - dziazid dxibxib = -dxiaxib - dxibxic - dxibxid dxibyib = -dyiaxib - dxibyic - dxibyid dxibzib = -dxiazib - dzibxic - dzibxid dxibzic = -dziaxib - dxibzib - dxibzid dyibyib = -dyiayib - dyibyic - dyibyid dyibzic = -dziayib - dyibzib - dyibzid dzibzib = -dziazib - dzibzic - dzibzid dzibyic = -dyiazib - dyibzib - dzibyid dxicxic = -dxiaxic - dxibxic - dxicxid dxicyic = -dyiaxic - dyibxic - dxicyid dxiczic = -dziaxic - dzibxic - dxiczid dyicyic = -dyiayic - dyibyic - dyicyid dyiczic = -dziayic - dzibyic - dyiczid dziczic = -dziazic - dzibzic - dziczid c c increment diagonal and off-diagonal Hessian elements c if (i .eq. ia) then hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia + doxiaxia & + d2edphi2*dphidxia*dphidxia & + 2.0d0*domegadxia*dxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia + doxiayia & + d2edphi2*dphidxia*dphidyia & + domegadxia*dyia + domegadyia*dxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia + doxiazia & + d2edphi2*dphidxia*dphidzia & + domegadxia*dzia + domegadzia*dxia hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia + doxiayia & + d2edphi2*dphidxia*dphidyia & + domegadyia*dxia + domegadxia*dyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia + doyiayia & + d2edphi2*dphidyia*dphidyia & + 2.0d0*domegadyia*dyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia + doyiazia & + d2edphi2*dphidyia*dphidzia & + domegadyia*dzia + domegadzia*dyia hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia + doxiazia & + d2edphi2*dphidxia*dphidzia & + domegadxia*dzia + domegadzia*dxia hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia + doyiazia & + d2edphi2*dphidyia*dphidzia & + domegadyia*dzia + domegadzia*dyia hessz(3,ia) = hessz(3,ia) + dedphi*dziazia + doziazia & + d2edphi2*dphidzia*dphidzia & + 2.0d0*domegadzia*dzia hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib + doxibxia & + d2edphi2*dphidxia*dphidxib & + domegadxia*dxib + domegadxib*dxia hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib + doxibyia & + d2edphi2*dphidyia*dphidxib & + domegadyia*dxib + domegadxib*dyia hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib + doxibzia & + d2edphi2*dphidzia*dphidxib & + domegadzia*dxib + domegadxib*dzia hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib + doyibxia & + d2edphi2*dphidxia*dphidyib & + domegadxia*dyib + domegadyib*dxia hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib + doyibyia & + d2edphi2*dphidyia*dphidyib & + domegadyia*dyib + domegadyib*dyia hessz(2,ib) = hessz(2,ib) + dedphi*dziayib + doyibzia & + d2edphi2*dphidzia*dphidyib & + domegadzia*dyib + domegadyib*dzia hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib + dozibxia & + d2edphi2*dphidxia*dphidzib & + domegadxia*dzib + domegadzib*dxia hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib + dozibyia & + d2edphi2*dphidyia*dphidzib & + domegadyia*dzib + domegadzib*dyia hessz(3,ib) = hessz(3,ib) + dedphi*dziazib + dozibzia & + d2edphi2*dphidzia*dphidzib & + domegadzia*dzib + domegadzib*dzia hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic + doxiaxic & + d2edphi2*dphidxia*dphidxic & + domegadxia*dxic + domegadxic*dxia hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic + doyiaxic & + d2edphi2*dphidyia*dphidxic & + domegadyia*dxic + domegadxic*dyia hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic + doziaxic & + d2edphi2*dphidzia*dphidxic & + domegadzia*dxic + domegadxic*dzia hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic + doxiayic & + d2edphi2*dphidxia*dphidyic & + domegadxia*dyic + domegadyic*dxia hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic + doyiayic & + d2edphi2*dphidyia*dphidyic & + domegadyia*dyic + domegadyic*dyia hessz(2,ic) = hessz(2,ic) + dedphi*dziayic + doziayic & + d2edphi2*dphidzia*dphidyic & + domegadzia*dyic + domegadyic*dzia hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic + doxiazic & + d2edphi2*dphidxia*dphidzic & + domegadxia*dzic + domegadzic*dxia hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic + doyiazic & + d2edphi2*dphidyia*dphidzic & + domegadyia*dzic + domegadzic*dyia hessz(3,ic) = hessz(3,ic) + dedphi*dziazic + doziazic & + d2edphi2*dphidzia*dphidzic & + domegadzia*dzic + domegadzic*dzia hessx(1,id) = hessx(1,id) + dedphi*dxiaxid & + d2edphi2*dphidxia*dphidxid & + domegadxia*dxid hessy(1,id) = hessy(1,id) + dedphi*dyiaxid & + d2edphi2*dphidyia*dphidxid & + domegadyia*dxid hessz(1,id) = hessz(1,id) + dedphi*dziaxid & + d2edphi2*dphidzia*dphidxid & + domegadzia*dxid hessx(2,id) = hessx(2,id) + dedphi*dxiayid & + d2edphi2*dphidxia*dphidyid & + domegadxia*dyid hessy(2,id) = hessy(2,id) + dedphi*dyiayid & + d2edphi2*dphidyia*dphidyid & + domegadyia*dyid hessz(2,id) = hessz(2,id) + dedphi*dziayid & + d2edphi2*dphidzia*dphidyid & + domegadzia*dyid hessx(3,id) = hessx(3,id) + dedphi*dxiazid & + d2edphi2*dphidxia*dphidzid & + domegadxia*dzid hessy(3,id) = hessy(3,id) + dedphi*dyiazid & + d2edphi2*dphidyia*dphidzid & + domegadyia*dzid hessz(3,id) = hessz(3,id) + dedphi*dziazid & + d2edphi2*dphidzia*dphidzid & + domegadzia*dzid else if (i .eq. ib) then hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib + doxibxib & + d2edphi2*dphidxib*dphidxib & + 2.0d0*domegadxib*dxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib + doxibyib & + d2edphi2*dphidxib*dphidyib & + domegadxib*dyib + domegadyib*dxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib + doxibzib & + d2edphi2*dphidxib*dphidzib & + domegadxib*dzib + domegadzib*dxib hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib + doxibyib & + d2edphi2*dphidxib*dphidyib & + domegadxib*dyib + domegadyib*dxib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib + doyibyib & + d2edphi2*dphidyib*dphidyib & + 2.0d0*domegadyib*dyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib + doyibzib & + d2edphi2*dphidyib*dphidzib & + domegadyib*dzib + domegadzib*dyib hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib + doxibzib & + d2edphi2*dphidxib*dphidzib & + domegadxib*dzib + domegadzib*dxib hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib + doyibzib & + d2edphi2*dphidyib*dphidzib & + domegadyib*dzib + domegadzib*dyib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib + dozibzib & + d2edphi2*dphidzib*dphidzib & + 2.0*domegadzib*dzib hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib + doxibxia & + d2edphi2*dphidxib*dphidxia & + domegadxia*dxib + domegadxib*dxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib + doyibxia & + d2edphi2*dphidyib*dphidxia & + domegadxia*dyib + domegadyib*dxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib + dozibxia & + d2edphi2*dphidzib*dphidxia & + domegadxia*dzib + domegadzib*dxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib + doxibyia & + d2edphi2*dphidxib*dphidyia & + domegadyia*dxib + domegadxib*dyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib + doyibyia & + d2edphi2*dphidyib*dphidyia & + domegadyia*dyib + domegadyib*dyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib + dozibyia & + d2edphi2*dphidzib*dphidyia & + domegadyia*dzib + domegadzib*dyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib + doxibzia & + d2edphi2*dphidxib*dphidzia & + domegadzia*dxib + domegadxib*dzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayib + doyibzia & + d2edphi2*dphidyib*dphidzia & + domegadzia*dyib + domegadyib*dzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazib + dozibzia & + d2edphi2*dphidzib*dphidzia & + domegadzia*dzib + domegadzib*dzia hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic + doxibxic & + d2edphi2*dphidxib*dphidxic & + domegadxib*dxic + domegadxic*dxib hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic + doyibxic & + d2edphi2*dphidyib*dphidxic & + domegadyib*dxic + domegadxic*dyib hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic + dozibxic & + d2edphi2*dphidzib*dphidxic & + domegadzib*dxic + domegadxic*dzib hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic + doxibyic & + d2edphi2*dphidxib*dphidyic & + domegadxib*dyic + domegadyic*dxib hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic + doyibyic & + d2edphi2*dphidyib*dphidyic & + domegadyib*dyic + domegadyic*dyib hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic + dozibyic & + d2edphi2*dphidzib*dphidyic & + domegadzib*dyic + domegadyic*dzib hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic + doxibzic & + d2edphi2*dphidxib*dphidzic & + domegadxib*dzic + domegadzic*dxib hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic + doyibzic & + d2edphi2*dphidyib*dphidzic & + domegadyib*dzic + domegadzic*dyib hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic + dozibzic & + d2edphi2*dphidzib*dphidzic & + domegadzib*dzic + domegadzic*dzib hessx(1,id) = hessx(1,id) + dedphi*dxibxid & + d2edphi2*dphidxib*dphidxid & + domegadxib*dxid hessy(1,id) = hessy(1,id) + dedphi*dyibxid & + d2edphi2*dphidyib*dphidxid & + domegadyib*dxid hessz(1,id) = hessz(1,id) + dedphi*dzibxid & + d2edphi2*dphidzib*dphidxid & + domegadzib*dxid hessx(2,id) = hessx(2,id) + dedphi*dxibyid & + d2edphi2*dphidxib*dphidyid & + domegadxib*dyid hessy(2,id) = hessy(2,id) + dedphi*dyibyid & + d2edphi2*dphidyib*dphidyid & + domegadyib*dyid hessz(2,id) = hessz(2,id) + dedphi*dzibyid & + d2edphi2*dphidzib*dphidyid & + domegadzib*dyid hessx(3,id) = hessx(3,id) + dedphi*dxibzid & + d2edphi2*dphidxib*dphidzid & + domegadxib*dzid hessy(3,id) = hessy(3,id) + dedphi*dyibzid & + d2edphi2*dphidyib*dphidzid & + domegadyib*dzid hessz(3,id) = hessz(3,id) + dedphi*dzibzid & + d2edphi2*dphidzib*dphidzid & + domegadzib*dzid else if (i .eq. ic) then hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic + doxicxic & + d2edphi2*dphidxic*dphidxic & + 2.0d0*domegadxic*dxic hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic + doxicyic & + d2edphi2*dphidxic*dphidyic & + domegadxic*dyic + domegadyic*dxic hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic + doxiczic & + d2edphi2*dphidxic*dphidzic & + domegadxic*dzic + domegadzic*dxic hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic + doxicyic & + d2edphi2*dphidxic*dphidyic & + domegadxic*dyic + domegadyic*dxic hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic + doyicyic & + d2edphi2*dphidyic*dphidyic & + 2.0d0*domegadyic*dyic hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic + doyiczic & + d2edphi2*dphidyic*dphidzic & + domegadyic*dzic + domegadzic*dyic hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic + doxiczic & + d2edphi2*dphidxic*dphidzic & + domegadxic*dzic + domegadzic*dxic hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic + doyiczic & + d2edphi2*dphidyic*dphidzic & + domegadyic*dzic + domegadzic*dyic hessz(3,ic) = hessz(3,ic) + dedphi*dziczic + doziczic & + d2edphi2*dphidzic*dphidzic & + 2.0d0*domegadzic*dzic hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic + doxiaxic & + d2edphi2*dphidxic*dphidxia & + domegadxia*dxic + domegadxic*dxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic + doxiayic & + d2edphi2*dphidyic*dphidxia & + domegadxia*dyic + domegadyic*dxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic + doxiazic & + d2edphi2*dphidzic*dphidxia & + domegadxia*dzic + domegadzic*dxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic + doyiaxic & + d2edphi2*dphidxic*dphidyia & + domegadyia*dxic + domegadxic*dyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic + doyiayic & + d2edphi2*dphidyic*dphidyia & + domegadyia*dyic + domegadyic*dyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic + doyiazic & + d2edphi2*dphidzic*dphidyia & + domegadyia*dzic + domegadzic*dyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic + doziaxic & + d2edphi2*dphidxic*dphidzia & + domegadzia*dxic + domegadxic*dzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayic + doziayic & + d2edphi2*dphidyic*dphidzia & + domegadzia*dyic + domegadyic*dzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazic + doziazic & + d2edphi2*dphidzic*dphidzia & + domegadzia*dzic + domegadzic*dzia hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic + doxibxic & + d2edphi2*dphidxic*dphidxib & + domegadxib*dxic + domegadxic*dxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic + doxibyic & + d2edphi2*dphidyic*dphidxib & + domegadxib*dyic + domegadyic*dxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic + doxibzic & + d2edphi2*dphidzic*dphidxib & + domegadxib*dzic + domegadzic*dxib hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic + doyibxic & + d2edphi2*dphidxic*dphidyib & + domegadyib*dxic + domegadxic*dyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic + doyibyic & + d2edphi2*dphidyic*dphidyib & + domegadyib*dyic + domegadyic*dyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic + doyibzic & + d2edphi2*dphidzic*dphidyib & + domegadyib*dzic + domegadzic*dyib hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic + dozibxic & + d2edphi2*dphidxic*dphidzib & + domegadzib*dxic + domegadxic*dzib hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic + dozibyic & + d2edphi2*dphidyic*dphidzib & + domegadzib*dyic + domegadyic*dzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic + dozibzic & + d2edphi2*dphidzic*dphidzib & + domegadzib*dzic + domegadzic*dzib hessx(1,id) = hessx(1,id) + dedphi*dxicxid & + d2edphi2*dphidxic*dphidxid & + domegadxic*dxid hessy(1,id) = hessy(1,id) + dedphi*dyicxid & + d2edphi2*dphidyic*dphidxid & + domegadyic*dxid hessz(1,id) = hessz(1,id) + dedphi*dzicxid & + d2edphi2*dphidzic*dphidxid & + domegadzic*dxid hessx(2,id) = hessx(2,id) + dedphi*dxicyid & + d2edphi2*dphidxic*dphidyid & + domegadxic*dyid hessy(2,id) = hessy(2,id) + dedphi*dyicyid & + d2edphi2*dphidyic*dphidyid & + domegadyic*dyid hessz(2,id) = hessz(2,id) + dedphi*dzicyid & + d2edphi2*dphidzic*dphidyid & + domegadzic*dyid hessx(3,id) = hessx(3,id) + dedphi*dxiczid & + d2edphi2*dphidxic*dphidzid & + domegadxic*dzid hessy(3,id) = hessy(3,id) + dedphi*dyiczid & + d2edphi2*dphidyic*dphidzid & + domegadyic*dzid hessz(3,id) = hessz(3,id) + dedphi*dziczid & + d2edphi2*dphidzic*dphidzid & + domegadzic*dzid else if (i .eq. id) then hessx(1,id) = hessx(1,id) + dedphi*dxidxid & + d2edphi2*dphidxid*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dxidyid & + d2edphi2*dphidxid*dphidyid hessz(1,id) = hessz(1,id) + dedphi*dxidzid & + d2edphi2*dphidxid*dphidzid hessx(2,id) = hessx(2,id) + dedphi*dxidyid & + d2edphi2*dphidxid*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyidyid & + d2edphi2*dphidyid*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dyidzid & + d2edphi2*dphidyid*dphidzid hessx(3,id) = hessx(3,id) + dedphi*dxidzid & + d2edphi2*dphidxid*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyidzid & + d2edphi2*dphidyid*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dzidzid & + d2edphi2*dphidzid*dphidzid hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid & + d2edphi2*dphidxid*dphidxia & + domegadxia*dxid hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid & + d2edphi2*dphidyid*dphidxia & + domegadxia*dyid hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid & + d2edphi2*dphidzid*dphidxia & + domegadxia*dzid hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid & + d2edphi2*dphidxid*dphidyia & + domegadyia*dxid hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid & + d2edphi2*dphidyid*dphidyia & + domegadyia*dyid hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid & + d2edphi2*dphidzid*dphidyia & + domegadyia*dzid hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid & + d2edphi2*dphidxid*dphidzia & + domegadzia*dxid hessy(3,ia) = hessy(3,ia) + dedphi*dziayid & + d2edphi2*dphidyid*dphidzia & + domegadzia*dyid hessz(3,ia) = hessz(3,ia) + dedphi*dziazid & + d2edphi2*dphidzid*dphidzia & + domegadzia*dzid hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid & + d2edphi2*dphidxid*dphidxib & + domegadxib*dxid hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid & + d2edphi2*dphidyid*dphidxib & + domegadxib*dyid hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid & + d2edphi2*dphidzid*dphidxib & + domegadxib*dzid hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid & + d2edphi2*dphidxid*dphidyib & + domegadyib*dxid hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid & + d2edphi2*dphidyid*dphidyib & + domegadyib*dyid hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid & + d2edphi2*dphidzid*dphidyib & + domegadyib*dzid hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid & + d2edphi2*dphidxid*dphidzib & + domegadzib*dxid hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid & + d2edphi2*dphidyid*dphidzib & + domegadzib*dyid hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid & + d2edphi2*dphidzid*dphidzib & + domegadzib*dzid hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid & + d2edphi2*dphidxid*dphidxic & + domegadxic*dxid hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid & + d2edphi2*dphidyid*dphidxic & + domegadxic*dyid hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid & + d2edphi2*dphidzid*dphidxic & + domegadxic*dzid hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid & + d2edphi2*dphidxid*dphidyic & + domegadyic*dxid hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid & + d2edphi2*dphidyid*dphidyic & + domegadyic*dyid hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid & + d2edphi2*dphidzid*dphidyic & + domegadyic*dzid hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid & + d2edphi2*dphidxid*dphidzic & + domegadzic*dxid hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid & + d2edphi2*dphidyid*dphidzic & + domegadzic*dyid hessz(3,ic) = hessz(3,ic) + dedphi*dziczid & + d2edphi2*dphidzid*dphidzic & + domegadzic*dzid end if c c get the angle-torsion values for the second angle c v1 = kant(4,iangtor) v2 = kant(5,iangtor) v3 = kant(6,iangtor) k = iat(3,iangtor) dot = xbc*xdc + ybc*ydc + zbc*zdc cosang = dot / (rcb*rdc) angle = radian * acos(cosang) dt = angle - anat(k) dedphi = atorunit * (v1*dphi1 + v2*dphi2 + v3*dphi3) d2edphi2 = atorunit * dt & * (v1*d2phi1 + v2* d2phi2 + v3*d2phi3) d2dt = atorunit * radian * (v1*phi1 + v2*phi2 + v3*phi3) c c scale the interaction based on its group membership c if (use_group) then dedphi = dedphi * fgrp d2edphi2 = d2edphi2 * fgrp d2dt = d2dt * fgrp end if c c first and second derivative components for the second angle c termb = -1.0d0 / (rcb2*ru) termd = 1.0d0 / (rdc2*ru) domegadxib = termb * (ybc*zu - zbc*yu) domegadyib = termb * (zbc*xu - xbc*zu) domegadzib = termb * (xbc*yu - ybc*xu) domegadxid = termd * (ydc*zu - zdc*yu) domegadyid = termd * (zdc*xu - xdc*zu) domegadzid = termd * (xdc*yu - ydc*xu) domegadxic = -domegadxib - domegadxid domegadyic = -domegadyib - domegadyid domegadzic = -domegadzib - domegadzid c c abbreviations used in defining chain rule terms c xrbc = 2.0d0 * xbc / rcb2 yrbc = 2.0d0 * ybc / rcb2 zrbc = 2.0d0 * zbc / rcb2 xrdc = 2.0d0 * xdc / rdc2 yrdc = 2.0d0 * ydc / rdc2 zrdc = 2.0d0 * zdc / rdc2 xbcp = (ybc*zu-zbc*yu) / ru2 ybcp = (zbc*xu-xbc*zu) / ru2 zbcp = (xbc*yu-ybc*xu) / ru2 xdcp = (ydc*zu-zdc*yu) / ru2 ydcp = (zdc*xu-xdc*zu) / ru2 zdcp = (xdc*yu-ydc*xu) / ru2 c c chain rule terms for second derivative components c doxibxib = termb*(xbc*xdc-dot) + domegadxib*(xdcp-xrbc) doxibyib = termb*(zu+ybc*xdc) + domegadxib*(ydcp-yrbc) doxibzib = termb*(zbc*xdc-yu) + domegadxib*(zdcp-zrbc) doyibyib = termb*(ybc*ydc-dot) + domegadyib*(ydcp-yrbc) doyibzib = termb*(xu+zbc*ydc) + domegadyib*(zdcp-zrbc) dozibzib = termb*(zbc*zdc-dot) + domegadzib*(zdcp-zrbc) doxidxid = termd*(dot-xbc*xdc) - domegadxid*(xbcp+xrdc) doxidyid = termd*(zu-ydc*xbc) - domegadxid*(ybcp+yrdc) doxidzid = -termd*(yu+zdc*xbc) - domegadxid*(zbcp+zrdc) doyidyid = termd*(dot-ybc*ydc) - domegadyid*(ybcp+yrdc) doyidzid = termd*(xu-zdc*ybc) - domegadyid*(zbcp+zrdc) dozidzid = termd*(dot-zbc*zdc) - domegadzid*(zbcp+zrdc) doxibxid = termb*(ybc*ybc+zbc*zbc) - domegadxib*xbcp doxibyid = -termb*xbc*ybc - domegadxib*ybcp doxibzid = -termb*xbc*zbc - domegadxib*zbcp doyibxid = -termb*xbc*ybc - domegadyib*xbcp doyibyid = termb*(xbc*xbc+zbc*zbc) - domegadyib*ybcp doyibzid = -termb*ybc*zbc - domegadyib*zbcp dozibxid = -termb*xbc*zbc - domegadzib*xbcp dozibyid = -termb*ybc*zbc - domegadzib*ybcp dozibzid = termb*(xbc*xbc+ybc*ybc) - domegadzib*zbcp c c get some second derivative chain rule terms by difference c doxicxib = -doxibxib - doxibxid doxicyib = -doxibyib - doyibxid doxiczib = -doxibzib - dozibxid doyicxib = -doxibyib - doxibyid doyicyib = -doyibyib - doyibyid doyiczib = -doyibzib - dozibyid dozicxib = -doxibzib - doxibzid dozicyib = -doyibzib - doyibzid doziczib = -dozibzib - dozibzid doxicxid = -doxidxid - doxibxid doxicyid = -doxidyid - doxibyid doxiczid = -doxidzid - doxibzid doyicxid = -doxidyid - doyibxid doyicyid = -doyidyid - doyibyid doyiczid = -doyidzid - doyibzid dozicxid = -doxidzid - dozibxid dozicyid = -doyidzid - dozibyid doziczid = -dozidzid - dozibzid doxicxic = -doxicxib - doxicxid doxicyic = -doxicyib - doxicyid doxiczic = -doxiczib - doxiczid doyicyic = -doyicyib - doyicyid doyiczic = -doyiczib - doyiczid doziczic = -doziczib - doziczid c c scale the first-derivatives of the second angle c domegadxib = domegadxib * radian domegadyib = domegadyib * radian domegadzib = domegadzib * radian domegadxid = domegadxid * radian domegadyid = domegadyid * radian domegadzid = domegadzid * radian domegadxic = domegadxic * radian domegadyic = domegadyic * radian domegadzic = domegadzic * radian c c scale the second-derivatives of the second angle c doxibxib = doxibxib * d2dt doxibyib = doxibyib * d2dt doxibzib = doxibzib * d2dt doyibyib = doyibyib * d2dt doyibzib = doyibzib * d2dt dozibzib = dozibzib * d2dt doxidxid = doxidxid * d2dt doxidyid = doxidyid * d2dt doxidzid = doxidzid * d2dt doyidyid = doyidyid * d2dt doyidzid = doyidzid * d2dt dozidzid = dozidzid * d2dt doxibxid = doxibxid * d2dt doxibyid = doxibyid * d2dt doxibzid = doxibzid * d2dt doyibxid = doyibxid * d2dt doyibyid = doyibyid * d2dt doyibzid = doyibzid * d2dt dozibxid = dozibxid * d2dt dozibyid = dozibyid * d2dt dozibzid = dozibzid * d2dt doxicxib = doxicxib * d2dt doxicyib = doxicyib * d2dt doxiczib = doxiczib * d2dt doyicxib = doyicxib * d2dt doyicyib = doyicyib * d2dt doyiczib = doyiczib * d2dt dozicxib = dozicxib * d2dt dozicyib = dozicyib * d2dt doziczib = doziczib * d2dt doxicxid = doxicxid * d2dt doxicyid = doxicyid * d2dt doxiczid = doxiczid * d2dt doyicxid = doyicxid * d2dt doyicyid = doyicyid * d2dt doyiczid = doyiczid * d2dt dozicxid = dozicxid * d2dt dozicyid = dozicyid * d2dt doziczid = doziczid * d2dt doxicxic = doxicxic * d2dt doxicyic = doxicyic * d2dt doxiczic = doxiczic * d2dt doyicyic = doyicyic * d2dt doyiczic = doyiczic * d2dt doziczic = doziczic * d2dt c c chain rule terms for first derivative components c dxia = dedphi * dphidxia dyia = dedphi * dphidyia dzia = dedphi * dphidzia dxib = dedphi * dphidxib dyib = dedphi * dphidyib dzib = dedphi * dphidzib dxic = dedphi * dphidxic dyic = dedphi * dphidyic dzic = dedphi * dphidzic dxid = dedphi * dphidxid dyid = dedphi * dphidyid dzid = dedphi * dphidzid dedphi = dedphi * dt c c increment diagonal and off-diagonal Hessian elements c if (i .eq. ia) then hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia & + d2edphi2*dphidxia*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia & + d2edphi2*dphidxia*dphidyia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia & + d2edphi2*dphidxia*dphidzia hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia & + d2edphi2*dphidxia*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia & + d2edphi2*dphidyia*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia & + d2edphi2*dphidyia*dphidzia hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia & + d2edphi2*dphidxia*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia & + d2edphi2*dphidyia*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazia & + d2edphi2*dphidzia*dphidzia hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib & + d2edphi2*dphidxia*dphidxib & + domegadxib*dxia hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib & + d2edphi2*dphidyia*dphidxib & + domegadxib*dyia hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib & + d2edphi2*dphidzia*dphidxib & + domegadxib*dzia hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib & + d2edphi2*dphidxia*dphidyib & + domegadyib*dxia hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib & + d2edphi2*dphidyia*dphidyib & + domegadyib*dyia hessz(2,ib) = hessz(2,ib) + dedphi*dziayib & + d2edphi2*dphidzia*dphidyib & + domegadyib*dzia hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib & + d2edphi2*dphidxia*dphidzib & + domegadzib*dxia hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib & + d2edphi2*dphidyia*dphidzib & + domegadzib*dyia hessz(3,ib) = hessz(3,ib) + dedphi*dziazib & + d2edphi2*dphidzia*dphidzib & + domegadzib*dzia hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic & + d2edphi2*dphidxia*dphidxic & + domegadxic*dxia hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic & + d2edphi2*dphidyia*dphidxic & + domegadxic*dyia hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic & + d2edphi2*dphidzia*dphidxic & + domegadxic*dzia hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic & + d2edphi2*dphidxia*dphidyic & + domegadyic*dxia hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic & + d2edphi2*dphidyia*dphidyic & + domegadyic*dyia hessz(2,ic) = hessz(2,ic) + dedphi*dziayic & + d2edphi2*dphidzia*dphidyic & + domegadyic*dzia hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic & + d2edphi2*dphidxia*dphidzic & + domegadzic*dxia hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic & + d2edphi2*dphidyia*dphidzic & + domegadzic*dyia hessz(3,ic) = hessz(3,ic) + dedphi*dziazic & + d2edphi2*dphidzia*dphidzic & + domegadzic*dzia hessx(1,id) = hessx(1,id) + dedphi*dxiaxid & + d2edphi2*dphidxia*dphidxid & + domegadxid*dxia hessy(1,id) = hessy(1,id) + dedphi*dyiaxid & + d2edphi2*dphidyia*dphidxid & + domegadxid*dyia hessz(1,id) = hessz(1,id) + dedphi*dziaxid & + d2edphi2*dphidzia*dphidxid & + domegadxid*dzia hessx(2,id) = hessx(2,id) + dedphi*dxiayid & + d2edphi2*dphidxia*dphidyid & + domegadyid*dxia hessy(2,id) = hessy(2,id) + dedphi*dyiayid & + d2edphi2*dphidyia*dphidyid & + domegadyid*dyia hessz(2,id) = hessz(2,id) + dedphi*dziayid & + d2edphi2*dphidzia*dphidyid & + domegadyid*dzia hessx(3,id) = hessx(3,id) + dedphi*dxiazid & + d2edphi2*dphidxia*dphidzid & + domegadzid*dxia hessy(3,id) = hessy(3,id) + dedphi*dyiazid & + d2edphi2*dphidyia*dphidzid & + domegadzid*dyia hessz(3,id) = hessz(3,id) + dedphi*dziazid & + d2edphi2*dphidzia*dphidzid & + domegadzid*dzia else if (i .eq. ib) then hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib + doxibxib & + d2edphi2*dphidxib*dphidxib & + 2.0d0*domegadxib*dxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib + doxibyib & + d2edphi2*dphidxib*dphidyib & + domegadxib*dyib + domegadyib*dxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib + doxibzib & + d2edphi2*dphidxib*dphidzib & + domegadxib*dzib + domegadzib*dxib hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib + doxibyib & + d2edphi2*dphidxib*dphidyib & + domegadxib*dyib + domegadyib*dxib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib + doyibyib & + d2edphi2*dphidyib*dphidyib & + 2.0d0*domegadyib*dyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib + doyibzib & + d2edphi2*dphidyib*dphidzib & + domegadyib*dzib + domegadzib*dyib hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib + doxibzib & + d2edphi2*dphidxib*dphidzib & + domegadxib*dzib + domegadzib*dxib hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib + doyibzib & + d2edphi2*dphidyib*dphidzib & + domegadyib*dzib + domegadzib*dyib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib + dozibzib & + d2edphi2*dphidzib*dphidzib & + 2.0d0*domegadzib*dzib hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib & + d2edphi2*dphidxib*dphidxia & + domegadxib*dxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib & + d2edphi2*dphidyib*dphidxia & + domegadyib*dxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib & + d2edphi2*dphidzib*dphidxia & + domegadzib*dxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib & + d2edphi2*dphidxib*dphidyia & + domegadxib*dyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib & + d2edphi2*dphidyib*dphidyia & + domegadyib*dyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib & + d2edphi2*dphidzib*dphidyia & + domegadzib*dyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib & + d2edphi2*dphidxib*dphidzia & + domegadxib*dzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayib & + d2edphi2*dphidyib*dphidzia & + domegadyib*dzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazib & + d2edphi2*dphidzib*dphidzia & + domegadzib*dzia hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic + doxicxib & + d2edphi2*dphidxib*dphidxic & + domegadxib*dxic + domegadxic*dxib hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic + doxicyib & + d2edphi2*dphidyib*dphidxic & + domegadyib*dxic + domegadxic*dyib hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic + doxiczib & + d2edphi2*dphidzib*dphidxic & + domegadzib*dxic + domegadxic*dzib hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic + doyicxib & + d2edphi2*dphidxib*dphidyic & + domegadxib*dyic + domegadyic*dxib hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic + doyicyib & + d2edphi2*dphidyib*dphidyic & + domegadyib*dyic + domegadyic*dyib hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic + doyiczib & + d2edphi2*dphidzib*dphidyic & + domegadzib*dyic + domegadyic*dzib hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic + dozicxib & + d2edphi2*dphidxib*dphidzic & + domegadxib*dzic + domegadzic*dxib hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic + dozicyib & + d2edphi2*dphidyib*dphidzic & + domegadyib*dzic + domegadzic*dyib hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic + doziczib & + d2edphi2*dphidzib*dphidzic & + domegadzib*dzic + domegadzic*dzib hessx(1,id) = hessx(1,id) + dedphi*dxibxid + doxibxid & + d2edphi2*dphidxib*dphidxid & + domegadxib*dxid + domegadxid*dxib hessy(1,id) = hessy(1,id) + dedphi*dyibxid + doyibxid & + d2edphi2*dphidyib*dphidxid & + domegadyib*dxid + domegadxid*dyib hessz(1,id) = hessz(1,id) + dedphi*dzibxid + dozibxid & + d2edphi2*dphidzib*dphidxid & + domegadzib*dxid + domegadxid*dzib hessx(2,id) = hessx(2,id) + dedphi*dxibyid + doxibyid & + d2edphi2*dphidxib*dphidyid & + domegadxib*dyid + domegadyid*dxib hessy(2,id) = hessy(2,id) + dedphi*dyibyid + doyibyid & + d2edphi2*dphidyib*dphidyid & + domegadyib*dyid + domegadyid*dyib hessz(2,id) = hessz(2,id) + dedphi*dzibyid + dozibyid & + d2edphi2*dphidzib*dphidyid & + domegadzib*dyid + domegadyid*dzib hessx(3,id) = hessx(3,id) + dedphi*dxibzid + doxibzid & + d2edphi2*dphidxib*dphidzid & + domegadxib*dzid + domegadzid*dxib hessy(3,id) = hessy(3,id) + dedphi*dyibzid + doyibzid & + d2edphi2*dphidyib*dphidzid & + domegadyib*dzid + domegadzid*dyib hessz(3,id) = hessz(3,id) + dedphi*dzibzid + dozibzid & + d2edphi2*dphidzib*dphidzid & + domegadzib*dzid + domegadzid*dzib else if (i .eq. ic) then hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic + doxicxic & + d2edphi2*dphidxic*dphidxic & + 2.0d0*domegadxic*dxic hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic + doxicyic & + d2edphi2*dphidxic*dphidyic & + domegadxic*dyic + domegadyic*dxic hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic + doxiczic & + d2edphi2*dphidxic*dphidzic & + domegadxic*dzic + domegadzic*dxic hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic + doxicyic & + d2edphi2*dphidxic*dphidyic & + domegadxic*dyic + domegadyic*dxic hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic + doyicyic & + d2edphi2*dphidyic*dphidyic & + 2.0d0*domegadyic*dyic hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic + doyiczic & + d2edphi2*dphidyic*dphidzic & + domegadyic*dzic + domegadzic*dyic hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic + doxiczic & + d2edphi2*dphidxic*dphidzic & + domegadxic*dzic + domegadzic*dxic hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic + doyiczic & + d2edphi2*dphidyic*dphidzic & + domegadyic*dzic + domegadzic*dyic hessz(3,ic) = hessz(3,ic) + dedphi*dziczic + doziczic & + d2edphi2*dphidzic*dphidzic & + 2.0d0*domegadzic*dzic hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic & + d2edphi2*dphidxic*dphidxia & + domegadxic*dxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic & + d2edphi2*dphidyic*dphidxia & + domegadyic*dxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic & + d2edphi2*dphidzic*dphidxia & + domegadzic*dxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic & + d2edphi2*dphidxic*dphidyia & + domegadxic*dyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic & + d2edphi2*dphidyic*dphidyia & + domegadyic*dyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic & + d2edphi2*dphidzic*dphidyia & + domegadzic*dyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic & + d2edphi2*dphidxic*dphidzia & + domegadxic*dzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayic & + d2edphi2*dphidyic*dphidzia & + domegadyic*dzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazic & + d2edphi2*dphidzic*dphidzia & + domegadzic*dzia hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic + doxicxib & + d2edphi2*dphidxic*dphidxib & + domegadxib*dxic + domegadxic*dxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic + doyicxib & + d2edphi2*dphidyic*dphidxib & + domegadxib*dyic + domegadyic*dxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic + dozicxib & + d2edphi2*dphidzic*dphidxib & + domegadxib*dzic + domegadzic*dxib hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic + doxicyib & + d2edphi2*dphidxic*dphidyib & + domegadyib*dxic + domegadxic*dyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic + doyicyib & + d2edphi2*dphidyic*dphidyib & + domegadyib*dyic + domegadyic*dyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic + dozicyib & + d2edphi2*dphidzic*dphidyib & + domegadyib*dzic + domegadzic*dyib hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic + doxiczib & + d2edphi2*dphidxic*dphidzib & + domegadzib*dxic + domegadxic*dzib hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic + doyiczib & + d2edphi2*dphidyic*dphidzib & + domegadzib*dyic + domegadyic*dzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic + doziczib & + d2edphi2*dphidzic*dphidzib & + domegadzib*dzic + domegadzic*dzib hessx(1,id) = hessx(1,id) + dedphi*dxicxid + doxicxid & + d2edphi2*dphidxic*dphidxid & + domegadxic*dxid + domegadxid*dxic hessy(1,id) = hessy(1,id) + dedphi*dyicxid + doyicxid & + d2edphi2*dphidyic*dphidxid & + domegadyic*dxid + domegadxid*dyic hessz(1,id) = hessz(1,id) + dedphi*dzicxid + dozicxid & + d2edphi2*dphidzic*dphidxid & + domegadzic*dxid + domegadxid*dzic hessx(2,id) = hessx(2,id) + dedphi*dxicyid + doxicyid & + d2edphi2*dphidxic*dphidyid & + domegadxic*dyid + domegadyid*dxic hessy(2,id) = hessy(2,id) + dedphi*dyicyid + doyicyid & + d2edphi2*dphidyic*dphidyid & + domegadyic*dyid + domegadyid*dyic hessz(2,id) = hessz(2,id) + dedphi*dzicyid + dozicyid & + d2edphi2*dphidzic*dphidyid & + domegadzic*dyid + domegadyid*dzic hessx(3,id) = hessx(3,id) + dedphi*dxiczid + doxiczid & + d2edphi2*dphidxic*dphidzid & + domegadxic*dzid + domegadzid*dxic hessy(3,id) = hessy(3,id) + dedphi*dyiczid + doyiczid & + d2edphi2*dphidyic*dphidzid & + domegadyic*dzid + domegadzid*dyic hessz(3,id) = hessz(3,id) + dedphi*dziczid + doziczid & + d2edphi2*dphidzic*dphidzid & + domegadzic*dzid + domegadzid*dzic else if (i .eq. id) then hessx(1,id) = hessx(1,id) + dedphi*dxidxid + doxidxid & + d2edphi2*dphidxid*dphidxid & + 2.0d0*domegadxid*dxid hessy(1,id) = hessy(1,id) + dedphi*dxidyid + doxidyid & + d2edphi2*dphidxid*dphidyid & + domegadxid*dyid + domegadyid*dxid hessz(1,id) = hessz(1,id) + dedphi*dxidzid + doxidzid & + d2edphi2*dphidxid*dphidzid & + domegadxid*dzid + domegadzid*dxid hessx(2,id) = hessx(2,id) + dedphi*dxidyid + doxidyid & + d2edphi2*dphidxid*dphidyid & + domegadxid*dyid + domegadyid*dxid hessy(2,id) = hessy(2,id) + dedphi*dyidyid + doyidyid & + d2edphi2*dphidyid*dphidyid & + 2.0d0*domegadyid*dyid hessz(2,id) = hessz(2,id) + dedphi*dyidzid + doyidzid & + d2edphi2*dphidyid*dphidzid & + domegadyid*dzid + domegadzid*dyid hessx(3,id) = hessx(3,id) + dedphi*dxidzid + doxidzid & + d2edphi2*dphidxid*dphidzid & + domegadxid*dzid + domegadzid*dxid hessy(3,id) = hessy(3,id) + dedphi*dyidzid + doyidzid & + d2edphi2*dphidyid*dphidzid & + domegadyid*dzid + domegadzid*dyid hessz(3,id) = hessz(3,id) + dedphi*dzidzid + dozidzid & + d2edphi2*dphidzid*dphidzid & + 2.0d0*domegadzid*dzid hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid & + d2edphi2*dphidxid*dphidxia & + domegadxid*dxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid & + d2edphi2*dphidyid*dphidxia & + domegadyid*dxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid & + d2edphi2*dphidzid*dphidxia & + domegadzid*dxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid & + d2edphi2*dphidxid*dphidyia & + domegadxid*dyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid & + d2edphi2*dphidyid*dphidyia & + domegadyid*dyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid & + d2edphi2*dphidzid*dphidyia & + domegadzid*dyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid & + d2edphi2*dphidxid*dphidzia & + domegadxid*dzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayid & + d2edphi2*dphidyid*dphidzia & + domegadyid*dzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazid & + d2edphi2*dphidzid*dphidzia & + domegadzid*dzia hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid + doxibxid & + d2edphi2*dphidxid*dphidxib & + domegadxib*dxid + domegadxid*dxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid + doxibyid & + d2edphi2*dphidyid*dphidxib & + domegadxib*dyid + domegadyid*dxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid + doxibzid & + d2edphi2*dphidzid*dphidxib & + domegadxib*dzid + domegadzid*dxib hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid + doyibxid & + d2edphi2*dphidxid*dphidyib & + domegadyib*dxid + domegadxid*dyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid + doyibyid & + d2edphi2*dphidyid*dphidyib & + domegadyib*dyid + domegadyid*dyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid + doyibzid & + d2edphi2*dphidzid*dphidyib & + domegadyib*dzid + domegadzid*dyib hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid + dozibxid & + d2edphi2*dphidxid*dphidzib & + domegadzib*dxid + domegadxid*dzib hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid + dozibyid & + d2edphi2*dphidyid*dphidzib & + domegadzib*dyid + domegadyid*dzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid + dozibzid & + d2edphi2*dphidzid*dphidzib & + domegadzib*dzid + domegadzid*dzib hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid + doxicxid & + d2edphi2*dphidxid*dphidxic & + domegadxic*dxid + domegadxid*dxic hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid + doxicyid & + d2edphi2*dphidyid*dphidxic & + domegadxic*dyid + domegadyid*dxic hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid + doxiczid & + d2edphi2*dphidzid*dphidxic & + domegadxic*dzid + domegadzid*dxic hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid + doyicxid & + d2edphi2*dphidxid*dphidyic & + domegadyic*dxid + domegadxid*dyic hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid + doyicyid & + d2edphi2*dphidyid*dphidyic & + domegadyic*dyid + domegadyid*dyic hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid + doyiczid & + d2edphi2*dphidzid*dphidyic & + domegadyic*dzid + domegadzid*dyic hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid + dozicxid & + d2edphi2*dphidxid*dphidzic & + domegadzic*dxid + domegadxid*dzic hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid + dozicyid & + d2edphi2*dphidyid*dphidzic & + domegadzic*dyid + domegadyid*dzic hessz(3,ic) = hessz(3,ic) + dedphi*dziczid + doziczid & + d2edphi2*dphidzid*dphidzic & + domegadzic*dzid + domegadzid*dzic end if end if end do return end c c c ########################################################## c ## COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder ## c ## All Rights Reserved ## c ########################################################## c c ################################################################ c ## ## c ## subroutine eangtor3 -- angle-torsion energy & analysis ## c ## ## c ################################################################ c c c "eangtor3" calculates the angle-torsion potential energy; c also partitions the energy terms among the atoms c c subroutine eangtor3 use action use analyz use angbnd use angtor use atomid use atoms use bound use energi use group use inform use iounit use math use torpot use tors use usage implicit none integer i,k,iangtor integer ia,ib,ic,id real*8 e,e1,e2 real*8 eps,fgrp real*8 rba,rcb,rdc real*8 rt2,ru2,rtru real*8 dot,dt,tangle real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 v1,v2,v3 real*8 c1,c2,c3 real*8 s1,s2,s3 real*8 sine,cosine real*8 sine2,cosine2 real*8 sine3,cosine3 real*8 phi1,phi2,phi3 real*8 angle,cosang real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc logical proceed logical header,huge c c c zero out the energy due to extra potential terms c neat = 0 eat = 0.0d0 do i = 1, n aeat(i) = 0.0d0 end do if (nangtor .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c print header information if debug output was requested c header = .true. if (debug .and. nangtor.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Angle-Torsion Interactions :', & //,' Type',25x,'Atom Names',21x,'Angle', & 6x,'Energy',/) end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nangtor,iat,itors,kant, !$OMP& anat,tors1,tors2,tors3,use,x,y,z,atorunit,eps,use_group, !$OMP& use_polymer,name,verbose,debug,header,iout) !$OMP& shared(eat,neat,aeat) !$OMP DO reduction(+:eat,neat,aeat) schedule(guided) c c calculate the angle-torsion interaction energy term c do iangtor = 1, nangtor i = iat(1,iangtor) ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) c c compute the value of the torsional angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rba = sqrt(max(xba*xba+yba*yba+zba*zba,eps)) rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) rdc = sqrt(max(xdc*xdc+ydc*ydc+zdc*zdc,eps)) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2*ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) tangle = radian * acos(cosine) if (sine .lt. 0.0d0) tangle = -tangle c c compute multiple angle trigonometry and phase terms c c1 = tors1(3,i) s1 = tors1(4,i) c2 = tors2(3,i) s2 = tors2(4,i) c3 = tors3(3,i) s3 = tors3(4,i) cosine2 = cosine*cosine - sine*sine sine2 = 2.0d0 * cosine * sine cosine3 = cosine*cosine2 - sine*sine2 sine3 = cosine*sine2 + sine*cosine2 phi1 = 1.0d0 + (cosine*c1 + sine*s1) phi2 = 1.0d0 + (cosine2*c2 + sine2*s2) phi3 = 1.0d0 + (cosine3*c3 + sine3*s3) c c get the angle-torsion values for the first angle c v1 = kant(1,iangtor) v2 = kant(2,iangtor) v3 = kant(3,iangtor) k = iat(2,iangtor) dot = xba*xcb + yba*ycb + zba*zcb cosang = -dot / (rba*rcb) angle = radian * acos(cosang) dt = angle - anat(k) e1 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3) c c get the angle-torsion values for the second angle c v1 = kant(4,iangtor) v2 = kant(5,iangtor) v3 = kant(6,iangtor) k = iat(3,iangtor) dot = xcb*xdc + ycb*ydc + zcb*zdc cosang = -dot / (rcb*rdc) angle = radian * acos(cosang) dt = angle - anat(k) e2 = atorunit * dt * (v1*phi1 + v2*phi2 + v3*phi3) c c scale the interaction based on its group membership c if (use_group) then e1 = e1 * fgrp e2 = e2 * fgrp end if c c increment the total angle-torsion energy c neat = neat + 1 e = e1 + e2 eat = eat + e aeat(ia) = aeat(ia) + e1/3.0d0 aeat(ib) = aeat(ib) + e/3.0d0 aeat(ic) = aeat(ic) + e/3.0d0 aeat(id) = aeat(id) + e2/3.0d0 c c print a message if the energy of this interaction is large c huge = (e .gt. 3.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Angle-Torsion', & ' Interactions :', & //,' Type',25x,'Atom Names',21x,'Angle', & 6x,'Energy',/) end if write (iout,30) ia,name(ia),ib,name(ib),ic, & name(ic),id,name(id),tangle,e 30 format (' AngTors',3x,4(i7,'-',a3),f11.4,f12.4) end if end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################### c ## ## c ## subroutine ebond -- bond stretch potential energy ## c ## ## c ########################################################### c c c "ebond" calculates the bond stretching energy c c subroutine ebond use atoms use bndpot use bndstr use bound use energi use group use usage implicit none integer i,ia,ib real*8 e,ideal,force real*8 expterm,bde real*8 dt,dt2,fgrp real*8 xab,yab,zab,rab logical proceed c c c zero out the bond stretching energy c eb = 0.0d0 if (nbond .eq. 0) return c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nbond,ibnd,bl,bk,use, !$OMP& x,y,z,cbnd,qbnd,bndtyp,bndunit,use_group,use_polymer) !$OMP& shared(eb) !$OMP DO reduction(+:eb) schedule(guided) c c calculate the bond stretching energy term c do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) ideal = bl(i) force = bk(i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,0,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib)) c c compute the value of the bond length deviation c if (proceed) then xab = x(ia) - x(ib) yab = y(ia) - y(ib) zab = z(ia) - z(ib) if (use_polymer) call image (xab,yab,zab) rab = sqrt(xab*xab + yab*yab + zab*zab) dt = rab - ideal c c harmonic potential uses Taylor expansion of Morse potential c through the fourth power of the bond length deviation c if (bndtyp .eq. 'HARMONIC') then dt2 = dt * dt e = bndunit * force * dt2 * (1.0d0+cbnd*dt+qbnd*dt2) c c Morse potential uses energy = BDE * (1 - e**(-alpha*dt))**2 c with the approximations alpha = sqrt(ForceConst/BDE) = 2 c and BDE = Bond Dissociation Energy = ForceConst/alpha**2 c else if (bndtyp .eq. 'MORSE') then expterm = exp(-2.0d0*dt) bde = 0.25d0 * bndunit * force e = bde * (1.0d0-expterm)**2 end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total bond stretching energy c eb = eb + e end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine ebond1 -- bond stretch energy & derivatives ## c ## ## c ################################################################ c c c "ebond1" calculates the bond stretching energy and c first derivatives with respect to Cartesian coordinates c c subroutine ebond1 use atoms use bndpot use bndstr use bound use deriv use energi use group use usage use virial implicit none integer i,ia,ib real*8 e,ideal,force real*8 expterm,bde,fgrp real*8 dt,dt2,deddt real*8 de,dedx,dedy,dedz real*8 xab,yab,zab,rab real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy logical proceed c c c zero out the bond energy and first derivatives c eb = 0.0d0 do i = 1, n deb(1,i) = 0.0d0 deb(2,i) = 0.0d0 deb(3,i) = 0.0d0 end do if (nbond .eq. 0) return c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nbond,ibnd,bl,bk,use, !$OMP& x,y,z,cbnd,qbnd,bndtyp,bndunit,use_group,use_polymer) !$OMP& shared(eb,deb,vir) !$OMP DO reduction(+:eb,deb,vir) schedule(guided) c c calculate the bond stretch energy and first derivatives c do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) ideal = bl(i) force = bk(i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,0,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib)) c c compute the value of the bond length deviation c if (proceed) then xab = x(ia) - x(ib) yab = y(ia) - y(ib) zab = z(ia) - z(ib) if (use_polymer) call image (xab,yab,zab) rab = sqrt(xab*xab + yab*yab + zab*zab) dt = rab - ideal c c harmonic potential uses Taylor expansion of Morse potential c through the fourth power of the bond length deviation c if (bndtyp .eq. 'HARMONIC') then dt2 = dt * dt e = bndunit * force * dt2 * (1.0d0+cbnd*dt+qbnd*dt2) deddt = 2.0d0 * bndunit * force * dt & * (1.0d0+1.5d0*cbnd*dt+2.0d0*qbnd*dt2) c c Morse potential uses energy = BDE * (1 - e**(-alpha*dt))**2 c with the approximations alpha = sqrt(ForceConst/BDE) = 2 c and BDE = Bond Dissociation Energy = ForceConst/alpha**2 c else if (bndtyp .eq. 'MORSE') then expterm = exp(-2.0d0*dt) bde = 0.25d0 * bndunit * force e = bde * (1.0d0-expterm)**2 deddt = 4.0d0 * bde * (1.0d0-expterm) * expterm end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp deddt = deddt * fgrp end if c c compute chain rule terms needed for derivatives c if (rab .eq. 0.0d0) then de = 0.0d0 else de = deddt / rab end if dedx = de * xab dedy = de * yab dedz = de * zab c c increment the total bond energy and first derivatives c eb = eb + e deb(1,ia) = deb(1,ia) + dedx deb(2,ia) = deb(2,ia) + dedy deb(3,ia) = deb(3,ia) + dedz deb(1,ib) = deb(1,ib) - dedx deb(2,ib) = deb(2,ib) - dedy deb(3,ib) = deb(3,ib) - dedz c c increment the internal virial tensor components c vxx = xab * dedx vyx = yab * dedx vzx = zab * dedx vyy = yab * dedy vzy = zab * dedy vzz = zab * dedz 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine ebond2 -- atom-by-atom bond stretch Hessian ## c ## ## c ################################################################ c c c "ebond2" calculates second derivatives of the bond c stretching energy for a single atom at a time c c subroutine ebond2 (i) use atmlst use atoms use bndpot use bndstr use bound use couple use group use hessn implicit none integer i,j,k,ia,ib real*8 ideal,force,fgrp real*8 xab,yab,zab real*8 rab,rab2 real*8 expterm,bde real*8 dt,dt2,term real*8 termx,termy,termz real*8 de,deddt,d2eddt2 real*8 d2e(3,3) logical proceed c c c calculate the bond stretch interaction Hessian elements c ia = i do k = 1, n12(ia) j = bndlist(k,ia) if (ibnd(1,j) .eq. ia) then ib = ibnd(2,j) else ib = ibnd(1,j) end if ideal = bl(j) force = bk(j) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,0,0,0,0) c c compute the value of the bond length deviation c if (proceed) then xab = x(ia) - x(ib) yab = y(ia) - y(ib) zab = z(ia) - z(ib) if (use_polymer) call image (xab,yab,zab) rab2 = xab*xab + yab*yab + zab*zab rab = sqrt(rab2) dt = rab - ideal c c harmonic potential uses Taylor expansion of Morse potential c through the fourth power of the bond length deviation c if (bndtyp .eq. 'HARMONIC') then dt2 = dt * dt deddt = 2.0d0 * bndunit * force * dt & * (1.0d0+1.5d0*cbnd*dt+2.0d0*qbnd*dt2) d2eddt2 = 2.0d0 * bndunit * force & * (1.0d0+3.0d0*cbnd*dt+6.0d0*qbnd*dt2) c c Morse potential uses energy = BDE * (1 - e**(-alpha*dt))**2 c with the approximations alpha = sqrt(ForceConst/BDE) = 2 c and BDE = Bond Dissociation Energy = ForceConst/alpha**2 c else if (bndtyp .eq. 'MORSE') then expterm = exp(-2.0d0*dt) bde = 0.25d0 * bndunit * force deddt = 4.0d0 * bde * (1.0d0-expterm) * expterm d2eddt2 = -8.0d0 * bde * (1.0d0-2.0d0*expterm) * expterm end if c c scale the interaction based on its group membership c if (use_group) then deddt = deddt * fgrp d2eddt2 = d2eddt2 * fgrp end if c c set the chain rule terms for the Hessian elements c if (rab2 .eq. 0.0d0) then de = 0.0d0 term = 0.0d0 else de = deddt / rab term = (d2eddt2-de) / rab2 end if termx = term * xab termy = term * yab termz = term * zab d2e(1,1) = termx*xab + de d2e(1,2) = termx*yab d2e(1,3) = termx*zab d2e(2,1) = d2e(1,2) d2e(2,2) = termy*yab + de d2e(2,3) = termy*zab d2e(3,1) = d2e(1,3) d2e(3,2) = d2e(2,3) d2e(3,3) = termz*zab + de c c increment diagonal and non-diagonal Hessian elements c do j = 1, 3 hessx(j,ia) = hessx(j,ia) + d2e(1,j) hessy(j,ia) = hessy(j,ia) + d2e(2,j) hessz(j,ia) = hessz(j,ia) + d2e(3,j) hessx(j,ib) = hessx(j,ib) - d2e(1,j) hessy(j,ib) = hessy(j,ib) - d2e(2,j) hessz(j,ib) = hessz(j,ib) - d2e(3,j) end do end if end do return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine ebond3 -- bond stretch energy & analysis ## c ## ## c ############################################################# c c c "ebond3" calculates the bond stretching energy; also c partitions the energy among the atoms c c subroutine ebond3 use action use analyz use atomid use atoms use bndpot use bndstr use bound use energi use group use inform use iounit use usage implicit none integer i,ia,ib real*8 e,ideal,force real*8 expterm,bde real*8 dt,dt2,fgrp real*8 xab,yab,zab,rab logical proceed logical header,huge c c c zero out the bond energy and partitioning terms c neb = 0 eb = 0.0d0 do i = 1, n aeb(i) = 0.0d0 end do if (nbond .eq. 0) return c c print header information if debug output was requested c header = .true. if (debug .and. nbond.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Bond Stretching Interactions :', & //,' Type',14x,'Atom Names',22x,'Ideal', & 4x,'Actual',6x,'Energy',/) end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nbond,ibnd,bl,bk,use, !$OMP& x,y,z,cbnd,qbnd,bndtyp,bndunit,use_group,use_polymer, !$OMP& name,verbose,debug,header,iout) !$OMP& shared(eb,neb,aeb) !$OMP DO reduction(+:eb,neb,aeb) schedule(guided) c c calculate the bond stretching energy term c do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) ideal = bl(i) force = bk(i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,0,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib)) c c compute the value of the bond length deviation c if (proceed) then xab = x(ia) - x(ib) yab = y(ia) - y(ib) zab = z(ia) - z(ib) if (use_polymer) call image (xab,yab,zab) rab = sqrt(xab*xab + yab*yab + zab*zab) dt = rab - ideal c c harmonic potential uses Taylor expansion of Morse potential c through the fourth power of the bond length deviation c if (bndtyp .eq. 'HARMONIC') then dt2 = dt * dt e = bndunit * force * dt2 * (1.0d0+cbnd*dt+qbnd*dt2) c c Morse potential uses energy = BDE * (1 - e**(-alpha*dt))**2 c with the approximations alpha = sqrt(ForceConst/BDE) = 2 c and BDE = Bond Dissociation Energy = ForceConst/alpha**2 c else if (bndtyp .eq. 'MORSE') then expterm = exp(-2.0d0*dt) bde = 0.25d0 * bndunit * force e = bde * (1.0d0-expterm)**2 end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total bond energy and partition between atoms c neb = neb + 1 eb = eb + e aeb(ia) = aeb(ia) + 0.5d0*e aeb(ib) = aeb(ib) + 0.5d0*e c c print a message if the energy of this interaction is large c huge = (e .gt. 5.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Bond Stretching', & ' Interactions :', & //,' Type',14x,'Atom Names',22x,'Ideal', & 4x,'Actual',6x,'Energy',/) end if write (iout,30) ia,name(ia),ib,name(ib),ideal,rab,e 30 format (' Bond',6x,2(i7,'-',a3),13x,2f10.4,f12.4) end if end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine ebuck -- Buckingham van der Waals energy ## c ## ## c ############################################################# c c c "ebuck" calculates the Buckingham exp-6 van der Waals energy c c subroutine ebuck use energi use iounit use limits use vdwpot use warp implicit none real*8 elrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_stophat) then write (iout,10) 10 format (/,' EBUCK -- Stophat Smoothing not Available', & ' for Buckingham vdw Potential') call fatal else if (use_smooth) then call ebuck0d else if (use_vlist) then call ebuck0c else if (use_lights) then call ebuck0b else call ebuck0a end if c c apply the long range van der Waals correction if used c if (use_vcorr) then mode = 'VDW' call evcorr (mode,elrc) ev = ev + elrc end if return end c c ################################################################# c ## ## c ## subroutine ebuck0a -- double loop Buckingham vdw energy ## c ## ## c ################################################################# c c c "ebuck0a" calculates the Buckingham exp-6 van der Waals energy c using a pairwise double loop c c subroutine ebuck0a use atomid use atoms use bound use cell use couple use energi use group use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,rv,eps real*8 rdn,fgrp real*8 p,p2,p6,p12 real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expcut2 real*8 expterm,expmerge real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c switch from exponential to R^12 at very short range c expcut = 2.0d0 expcut2 = expcut * expcut expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6)) & / (expcut**12) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 if (p2 .le. expcut2) then p = sqrt(p2) expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) else p12 = p6 * p6 e = expmerge * eps * p12 end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,j) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 if (p2 .le. expcut2) then p = sqrt(p2) expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) else p12 = p6 * p6 e = expmerge * eps * p12 end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy component; c interaction of an atom with its own image counts half c if (i .eq. k) e = 0.5d0 * e ev = ev + e end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################ c ## ## c ## subroutine ebuck0b -- Buckingham vdw energy via lights ## c ## ## c ################################################################ c c c "ebuck0b" calculates the Buckingham exp-6 van der Waals energy c using the method of lights c c subroutine ebuck0b use atomid use atoms use bound use boxes use cell use couple use energi use group use light use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer, allocatable :: iv14(:) real*8 e,rv,eps real*8 rdn,fgrp real*8 p,p2,p6,p12 real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expcut2 real*8 expterm,expmerge real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c switch from exponential to R^12 at very short range c expcut = 2.0d0 expcut2 = expcut * expcut expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6)) & / (expcut**12) c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 if (p2 .le. expcut2) then p = sqrt(p2) expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) else p12 = p6 * p6 e = expmerge * eps * p12 end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################## c ## ## c ## subroutine ebuck0c -- Buckingham vdw energy via list ## c ## ## c ############################################################## c c c "ebuck0c" calculates the Buckingham exp-6 van der Waals energy c using a pairwise neighbor list c c subroutine ebuck0c use atomid use atoms use bound use couple use energi use group use neigh use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,rv,eps real*8 rdn,fgrp real*8 p,p2,p6,p12 real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expcut2 real*8 expterm,expmerge real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c switch from exponential to R^12 at very short range c expcut = 2.0d0 expcut2 = expcut * expcut expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6)) & / (expcut**12) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired, !$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13, !$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group, !$OMP& off2,radmin,epsilon,radmin4,epsilon4,abuck,bbuck,cbuck, !$OMP& expcut2,expmerge,cut2,c0,c1,c2,c3,c4,c5) !$OMP& firstprivate(vscale,iv14) shared(ev) !$OMP DO reduction(+:ev) schedule(guided) c c find the van der Waals energy via neighbor list search c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 if (p2 .le. expcut2) then p = sqrt(p2) expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) else p12 = p6 * p6 e = expmerge * eps * p12 end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ############################################################### c ## ## c ## subroutine ebuck0d -- Buckingham energy for smoothing ## c ## ## c ############################################################### c c c "ebuck0d" calculates the Buckingham exp-6 van der Waals energy c via a Gaussian approximation for potential energy smoothing c c subroutine ebuck0d use math use vdwpot implicit none c c c set coefficients for a two-Gaussian fit to MM2 vdw form c ngauss = 2 igauss(1,1) = 3423.562d0 igauss(2,1) = 9.692821d0 * twosix**2 igauss(1,2) = -6.503760d0 igauss(2,2) = 1.585344d0 * twosix**2 c c compute Gaussian approximation to the Buckingham potential c call egauss return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine ebuck1 -- Buckingham vdw energy & derivatives ## c ## ## c ################################################################## c c c "ebuck1" calculates the Buckingham exp-6 van der Waals energy c and its first derivatives with respect to Cartesian coordinates c c subroutine ebuck1 use energi use iounit use limits use vdwpot use virial use warp implicit none real*8 elrc,vlrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_stophat) then write (iout,10) 10 format (/,' EBUCK1 -- Stophat Smoothing not Available', & ' for Buckingham vdw Potential') call fatal else if (use_smooth) then call ebuck1d else if (use_vlist) then call ebuck1c else if (use_lights) then call ebuck1b else call ebuck1a end if c c apply the long range van der Waals correction if used c if (use_vcorr) then mode = 'VDW' call evcorr1 (mode,elrc,vlrc) ev = ev + elrc vir(1,1) = vir(1,1) + vlrc vir(2,2) = vir(2,2) + vlrc vir(3,3) = vir(3,3) + vlrc end if return end c c c ################################################################# c ## ## c ## subroutine ebuck1a -- double loop Buckingham vdw derivs ## c ## ## c ################################################################# c c c "ebuck1a" calculates the Buckingham exp-6 van der Waals energy c and its first derivatives using a pairwise double loop c c subroutine ebuck1a use atomid use atoms use bound use cell use couple use deriv use energi use group use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,de,rv real*8 eps,rdn,fgrp real*8 p,p2,p6,p12 real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 rik,rik2,rik3 real*8 rik4,rik5,rvterm real*8 taper,dtaper real*8 expcut,expcut2 real*8 expterm,expmerge real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c switch from exponential to R^12 at very short range c expcut = 2.0d0 expcut2 = expcut * expcut expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6)) & / (expcut**12) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find van der Waals energy and derivatives via double loop c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 rik = sqrt(rik2) if (p2 .le. expcut2) then p = sqrt(p2) rvterm = -bbuck / rv expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik) else p12 = p6 * p6 e = expmerge * eps * p12 de = -12.0d0 * e / rik end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,j) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 rik = sqrt(rik2) if (p2 .le. expcut2) then p = sqrt(p2) rvterm = -bbuck / rv expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik) else p12 = p6 * p6 e = expmerge * eps * p12 de = -12.0d0 * e / rik end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c if (i .eq. k) e = 0.5d0 * e ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (i .ne. k) then if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################ c ## ## c ## subroutine ebuck1b -- Buckingham vdw derivs via lights ## c ## ## c ################################################################ c c c "ebuck1b" calculates the Buckingham exp-6 van der Waals energy c and its first derivatives using the method of lights c c subroutine ebuck1b use atomid use atoms use bound use boxes use cell use couple use deriv use energi use group use light use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer, allocatable :: iv14(:) real*8 e,de,rv real*8 eps,rdn,fgrp real*8 p,p2,p6,p12 real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 rik,rik2,rik3 real*8 rik4,rik5,rvterm real*8 taper,dtaper real*8 expcut,expcut2 real*8 expterm,expmerge real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c switch from exponential to R^12 at very short range c expcut = 2.0d0 expcut2 = expcut * expcut expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6)) & / (expcut**12) c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c now, loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 rik = sqrt(rik2) if (p2 .le. expcut2) then p = sqrt(p2) rvterm = -bbuck / rv expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik) else p12 = p6 * p6 e = expmerge * eps * p12 de = -12.0d0 * e / rik end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################## c ## ## c ## subroutine ebuck1c -- Buckingham vdw derivs via list ## c ## ## c ############################################################## c c c "ebuck1c" calculates the Buckingham exp-6 van der Waals energy c and its first derivatives using a pairwise neighbor list c c subroutine ebuck1c use atomid use atoms use bound use couple use deriv use energi use group use neigh use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,de,rv real*8 eps,rdn,fgrp real*8 p,p2,p6,p12 real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 rik,rik2,rik3 real*8 rik4,rik5,rvterm real*8 taper,dtaper real*8 expcut,expcut2 real*8 expterm,expmerge real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c switch from exponential to R^12 at very short range c expcut = 2.0d0 expcut2 = expcut * expcut expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6)) & / (expcut**12) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired, !$OMP& kred,xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15, !$OMP& i12,i13,i14,i15,v2scale,v3scale,v4scale,v5scale, !$OMP& use_group,off2,radmin,epsilon,radmin4,epsilon4,abuck, !$OMP& bbuck,cbuck,expcut2,expmerge,cut2,c0,c1,c2,c3,c4,c5) !$OMP& firstprivate(vscale,iv14) shared(ev,dev,vir) !$OMP DO reduction(+:ev,dev,vir) schedule(guided) c c find van der Waals energy and derivatives via neighbor list c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 rik = sqrt(rik2) if (p2 .le. expcut2) then p = sqrt(p2) rvterm = -bbuck / rv expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik) else p12 = p6 * p6 e = expmerge * eps * p12 de = -12.0d0 * e / rik end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ############################################################### c ## ## c ## subroutine ebuck1d -- Buckingham derivs for smoothing ## c ## ## c ############################################################### c c c "ebuck1d" calculates the Buckingham exp-6 van der Waals energy c and its first derivatives via a Gaussian approximation for c potential energy smoothing c c subroutine ebuck1d use math use vdwpot implicit none c c c set coefficients for a two-Gaussian fit to MM2 vdw form c ngauss = 2 igauss(1,1) = 3423.562d0 igauss(2,1) = 9.692821d0 * twosix**2 igauss(1,2) = -6.503760d0 igauss(2,2) = 1.585344d0 * twosix**2 c c compute Gaussian approximation to the Buckingham potential c call egauss1 return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine ebuck2 -- atom-by-atom Buckingham vdw Hessian ## c ## ## c ################################################################## c c c "ebuck2" calculates the Buckingham exp-6 van der Waals c second derivatives for a single atom at a time c c subroutine ebuck2 (i) use iounit use warp implicit none integer i c c c choose double loop, method of lights or smoothing version c if (use_stophat) then write (iout,10) 10 format (/,' EBUCK2 -- Stophat Smoothing not Available', & ' for Buckingham vdw Potential') call fatal else if (use_smooth) then call ebuck2b (i) else call ebuck2a (i) end if return end c c c ################################################################## c ## ## c ## subroutine ebuck2a -- double loop Buckingham vdw Hessian ## c ## ## c ################################################################## c c c "ebuck2a" calculates the Buckingham exp-6 van der Waals second c derivatives using a double loop over relevant atom pairs c c subroutine ebuck2a (iatom) use atomid use atoms use bound use cell use couple use group use hessn use shunt use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer iatom,jcell integer nlist,list(5) integer, allocatable :: iv14(:) real*8 e,de,d2e,fgrp real*8 p,p2,p6,p12 real*8 eps,rv,rdn real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 redi2,rediv2,rediiv real*8 redik,redivk real*8 redikv,redivkv real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 taper,dtaper,d2taper real*8 d2edx,d2edy,d2edz real*8 expcut,expcut2 real*8 expterm,expmerge real*8 rvterm,rvterm2 real*8 term(3,3) real*8, allocatable :: vscale(:) logical proceed character*6 mode c c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c switch from exponential to R^12 at very short range c expcut = 2.0d0 expcut2 = expcut * expcut expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6)) & / (expcut**12) c c check to see if the atom of interest is a vdw site c nlist = 0 do k = 1, nvdw if (ivdw(k) .eq. iatom) then nlist = nlist + 1 list(nlist) = iatom goto 10 end if end do return 10 continue c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c determine the atoms involved via reduction factors c nlist = 1 list(nlist) = iatom do k = 1, n12(iatom) i = i12(k,iatom) if (ired(i) .eq. iatom) then nlist = nlist + 1 list(nlist) = i end if end do c c find van der Waals Hessian elements for involved atoms c do ii = 1, nlist i = list(ii) it = jvdw(i) iv = ired(i) redi = kred(i) if (i .ne. iv) then rediv = 1.0d0 - redi redi2 = redi * redi rediv2 = rediv * rediv rediiv = redi * rediv end if xi = xred(i) yi = yred(i) zi = zred(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (k .ne. i) c c compute the Hessian elements for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 rik = sqrt(rik2) if (p2 .le. expcut2) then p = sqrt(p2) rvterm = -bbuck / rv rvterm2 = rvterm * rvterm expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik) d2e = eps * (rvterm2*expterm-42.0d0*cbuck*p6/rik2) else p12 = p6 * p6 e = expmerge * eps * p12 de = -12.0d0 * e / rik d2e = 156.0d0 * e / rik2 end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2 & + 6.0d0*c3*rik + 2.0d0*c2 d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper de = e*dtaper + de*taper 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 get chain rule terms for van der Waals Hessian elements c de = de / rik d2e = (d2e-de) / rik2 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 if (i .eq. iatom) then if (i.eq.iv .and. k.eq.kv) then 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 else if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redi hessy(j,k) = hessy(j,k) - term(2,j)*redi hessz(j,k) = hessz(j,k) - term(3,j)*redi hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv end do else if (i .eq. iv) then redk = kred(k) redkv = 1.0d0 - redk 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)*redk hessy(j,k) = hessy(j,k) - term(2,j)*redk hessz(j,k) = hessz(j,k) - term(3,j)*redk hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv end do else redk = kred(k) redkv = 1.0d0 - redk redik = redi * redk redikv = redi * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redik hessy(j,k) = hessy(j,k) - term(2,j)*redik hessz(j,k) = hessz(j,k) - term(3,j)*redik hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv end do end if else if (iv .eq. iatom) then if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*rediv hessy(j,k) = hessy(j,k) - term(2,j)*rediv hessz(j,k) = hessz(j,k) - term(3,j)*rediv hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 end do else redk = kred(k) redkv = 1.0d0 - redk redivk = rediv * redk redivkv = rediv * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*redivk hessy(j,k) = hessy(j,k) - term(2,j)*redivk hessz(j,k) = hessz(j,k) - term(3,j)*redivk hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv end do end if end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nlist i = list(ii) it = jvdw(i) iv = ired(i) redi = kred(i) if (i .ne. iv) then rediv = 1.0d0 - redi redi2 = redi * redi rediv2 = rediv * rediv rediiv = redi * rediv end if xi = xred(i) yi = yred(i) zi = zred(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) c c compute the Hessian elements for this interaction c if (proceed) then do jcell = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,jcell) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 rik = sqrt(rik2) if (p2 .le. expcut2) then p = sqrt(p2) rvterm = -bbuck / rv rvterm2 = rvterm * rvterm expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) de = eps * (rvterm*expterm+6.0d0*cbuck*p6/rik) d2e = eps * (rvterm2*expterm & -42.0d0*cbuck*p6/rik2) else p12 = p6 * p6 e = expmerge * eps * p12 de = -12.0d0 * e / rik d2e = 156.0d0 * e / rik2 end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2 & + 6.0d0*c3*rik + 2.0d0*c2 d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper de = e*dtaper + de*taper 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 get chain rule terms for van der Waals Hessian elements c de = de / rik d2e = (d2e-de) / rik2 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 if (i .eq. iatom) then if (i.eq.iv .and. k.eq.kv) then 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 else if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redi hessy(j,k) = hessy(j,k) - term(2,j)*redi hessz(j,k) = hessz(j,k) - term(3,j)*redi hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediiv end do else if (i .eq. iv) then redk = kred(k) redkv = 1.0d0 - redk 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)*redk hessy(j,k) = hessy(j,k) - term(2,j)*redk hessz(j,k) = hessz(j,k) - term(3,j)*redk hessx(j,kv) = hessx(j,kv) & - term(1,j)*redkv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redkv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redkv end do else redk = kred(k) redkv = 1.0d0 - redk redik = redi * redk redikv = redi * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redik hessy(j,k) = hessy(j,k) - term(2,j)*redik hessz(j,k) = hessz(j,k) - term(3,j)*redik hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediiv hessx(j,kv) = hessx(j,kv) & - term(1,j)*redikv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redikv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redikv end do end if else if (iv .eq. iatom) then if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*rediv hessy(j,k) = hessy(j,k) - term(2,j)*rediv hessz(j,k) = hessz(j,k) - term(3,j)*rediv hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediv2 end do else redk = kred(k) redkv = 1.0d0 - redk redivk = rediv * redk redivkv = rediv * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*redivk hessy(j,k) = hessy(j,k) - term(2,j)*redivk hessz(j,k) = hessz(j,k) - term(3,j)*redivk hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediv2 hessx(j,kv) = hessx(j,kv) & - term(1,j)*redivkv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redivkv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redivkv end do end if end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################ c ## ## c ## subroutine ebuck2b -- Buckingham Hessian for smoothing ## c ## ## c ################################################################ c c c "ebuck2b" calculates the Buckingham exp-6 van der Waals second c derivatives via a Gaussian approximation for use with potential c energy smoothing c c subroutine ebuck2b (i) use math use vdwpot implicit none integer i c c c set coefficients for a two-Gaussian fit to MM2 vdw form c ngauss = 2 igauss(1,1) = 3423.562d0 igauss(2,1) = 9.692821d0 * twosix**2 igauss(1,2) = -6.503760d0 igauss(2,2) = 1.585344d0 * twosix**2 c c compute Gaussian approximation to the Buckingham potential c call egauss2 (i) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine ebuck3 -- Buckingham vdw energy & analysis ## c ## ## c ############################################################### c c c "ebuck3" calculates the Buckingham exp-6 van der Waals energy c and partitions the energy among the atoms c c subroutine ebuck3 use analyz use atoms use energi use inform use iounit use limits use vdwpot use warp implicit none integer i real*8 elrc,aelrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_stophat) then write (iout,10) 10 format (/,' EBUCK3 -- Stophat Smoothing not Available', & ' for Buckingham vdw Potential') call fatal else if (use_smooth) then call ebuck3d else if (use_vlist) then call ebuck3c else if (use_lights) then call ebuck3b else call ebuck3a end if c c apply the long range van der Waals correction if used c if (use_vcorr) then mode = 'VDW' call evcorr (mode,elrc) ev = ev + elrc aelrc = elrc / dble(n) do i = 1, n aev(i) = aev(i) + aelrc end do if (verbose .and. elrc.ne.0.0d0) then if (digits .ge. 8) then write (iout,20) elrc 20 format (/,' Long-Range van der Waals :',6x,f16.8) else if (digits .ge. 6) then write (iout,30) elrc 30 format (/,' Long-Range van der Waals :',6x,f16.6) else write (iout,40) elrc 40 format (/,' Long-Range van der Waals :',6x,f16.4) end if end if end if return end c c c ############################################################### c ## ## c ## subroutine ebuck3a -- double loop Buckingham analysis ## c ## ## c ############################################################### c c c "ebuck3a" calculates the Buckingham exp-6 van der Waals c energy and partitions the energy among the atoms using c a pairwise double loop c c subroutine ebuck3a use action use analyz use atomid use atoms use bound use cell use couple use energi use group use inform use inter use iounit use molcul use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,rv,eps real*8 rdn,fgrp real*8 p,p2,p6,p12 real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expcut2 real*8 expterm,expmerge real*8, allocatable :: vscale(:) logical proceed,usei logical header,huge character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c switch from exponential to R^12 at very short range c expcut = 2.0d0 expcut2 = expcut * expcut expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6)) & / (expcut**12) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 if (p2 .le. expcut2) then p = sqrt(p2) expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) else p12 = p6 * p6 e = expmerge * eps * p12 end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & rv,sqrt(rik2),e 30 format (' VDW-Buck',2x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,j) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 if (p2 .le. expcut2) then p = sqrt(p2) expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) else p12 = p6 * p6 e = expmerge * eps * p12 end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy component c if (e .ne. 0.0d0) then nev = nev + 1 if (i .eq. k) then ev = ev + 0.5d0*e aev(i) = aev(i) + 0.5d0*e else ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if write (iout,50) i,name(i),k,name(k), & rv,sqrt(rik2),e 50 format (' VDW-Buck',2x,2(i7,'-',a3),1x, & '(XTAL)',6x,2f10.4,f12.4) end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################## c ## ## c ## subroutine ebuck3b -- Buckingham vdw analysis via lights ## c ## ## c ################################################################## c c c "ebuck3b" calculates the Buckingham exp-6 van der Waals c energy and also partitions the energy among the atoms using c the method of lights c c subroutine ebuck3b use action use analyz use atomid use atoms use bound use boxes use cell use couple use energi use group use inform use inter use iounit use light use molcul use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer ikmin,ikmax integer, allocatable :: iv14(:) real*8 e,rv,eps real*8 rdn,fgrp real*8 p,p2,p6,p12 real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expcut2 real*8 expterm,expmerge real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat logical header,huge character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c switch from exponential to R^12 at very short range c expcut = 2.0d0 expcut2 = expcut * expcut expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6)) & / (expcut**12) c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c now, loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 20 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 60 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 60 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 60 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 60 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 if (p2 .le. expcut2) then p = sqrt(p2) expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) else p12 = p6 * p6 e = expmerge * eps * p12 end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if c c increment the total intermolecular energy c if (.not.prime .or. 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,30) 30 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if ikmin = min(i,k) ikmax = max(i,k) if (prime) then write (iout,40) ikmin,name(ikmin),ikmax, & name(ikmax),rv,sqrt(rik2),e 40 format (' VDW-Buck',2x,2(i7,'-',a3), & 13x,2f10.4,f12.4) else write (iout,50) ikmin,name(ikmin),ikmax, & name(ikmax),rv,sqrt(rik2),e 50 format (' VDW-Buck',2x,2(i7,'-',a3),1x, & '(XTAL)',6x,2f10.4,f12.4) end if end if end if end if 60 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 20 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ################################################################ c ## ## c ## subroutine ebuck3c -- Buckingham vdw analysis via list ## c ## ## c ################################################################ c c c "ebuck3c" calculates the Buckingham exp-6 van der Waals energy c and also partitions the energy among the atoms using a pairwise c neighbor list c c subroutine ebuck3c use action use analyz use atomid use atoms use bound use couple use energi use group use inform use inter use iounit use molcul use neigh use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,rv,eps real*8 rdn,fgrp real*8 p,p2,p6,p12 real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expcut2 real*8 expterm,expmerge real*8, allocatable :: vscale(:) logical proceed,usei logical header,huge character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c switch from exponential to R^12 at very short range c expcut = 2.0d0 expcut2 = expcut * expcut expmerge = (abuck*exp(-bbuck/expcut) - cbuck*(expcut**6)) & / (expcut**12) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired, !$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13, !$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group, !$OMP& off2,radmin,epsilon,radmin4,epsilon4,abuck,bbuck,cbuck, !$OMP& expcut2,expmerge,cut2,c0,c1,c2,c3,c4,c5,molcule,name, !$OMP& verbose,debug,header,iout) !$OMP& firstprivate(vscale,iv14) shared(ev,nev,aev,einter) !$OMP DO reduction(+:ev,nev,aev,einter) schedule(guided) c c find the van der Waals energy via neighbor list search c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) p2 = (rv*rv) / rik2 p6 = p2 * p2 * p2 if (p2 .le. expcut2) then p = sqrt(p2) expterm = abuck * exp(-bbuck/p) e = eps * (expterm - cbuck*p6) else p12 = p6 * p6 e = expmerge * eps * p12 end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & rv,sqrt(rik2),e 30 format (' VDW-Buck',2x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################# c ## ## c ## subroutine ebuck3d -- Buckingham analysis for smoothing ## c ## ## c ################################################################# c c c "ebuck3d" calculates the Buckingham exp-6 van der Waals energy c via a Gaussian approximation for potential energy smoothing c c subroutine ebuck3d use math use vdwpot implicit none c c c set coefficients for a two-Gaussian fit to MM2 vdw form c ngauss = 2 igauss(1,1) = 3423.562d0 igauss(2,1) = 9.692821d0 * twosix**2 igauss(1,2) = -6.503760d0 igauss(2,2) = 1.585344d0 * twosix**2 c c compute Gaussian approximation to the Buckingham potential c call egauss3 return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine echarge -- charge-charge potential energy ## c ## ## c ############################################################## c c c "echarge" calculates the charge-charge interaction energy c c subroutine echarge use energi use extfld use limits use warp implicit none real*8 exf character*6 mode c c c choose the method for summing over pairwise interactions c if (use_smooth) then call echarge0g else if (use_ewald) then if (use_clist) then call echarge0f else if (use_lights) then call echarge0e else call echarge0d end if else if (use_clist) then call echarge0c else if (use_lights) then call echarge0b else call echarge0a end if c c get contribution from external electric field if used c if (use_exfld) then mode = 'CHARGE' call exfield (mode,exf) ec = ec + exf end if return end c c c ############################################################### c ## ## c ## subroutine echarge0a -- charge energy via double loop ## c ## ## c ############################################################### c c c "echarge0a" calculates the charge-charge interaction energy c using a pairwise double loop c c subroutine echarge0a use atoms use bound use cell use charge use chgpot use couple use energi use group use shunt use usage implicit none integer i,j,k integer ii,in,ic integer kk,kn,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 c c c zero out the charge interaction energy c ec = 0.0d0 if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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(i) ic = kion(i) xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii+1, nion k = iion(kk) kn = jion(k) kc = kion(k) 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 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(k) * 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 increment the overall charge-charge energy component c if (use_group) e = e * fgrp ec = ec + e end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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(i) ic = kion(i) xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii, nion k = iion(kk) kn = jion(k) kc = kion(k) 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 = 2, 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(k) 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 increment the overall charge-charge energy component c if (i .eq. k) e = 0.5d0 * e if (use_group) e = e * fgrp ec = ec + e end if end do end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 echarge0b -- method of lights charge energy ## c ## ## c ################################################################ c c c "echarge0b" calculates the charge-charge interaction energy c using the method of lights c c subroutine echarge0b use atoms use bound use boxes use cell use charge use chgpot use couple use energi use group use iounit use light use shunt use usage implicit none integer i,j,k integer ii,in,ic integer kk,kn,kc integer kgy,kgz,kmap integer start,stop 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(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat character*6 mode c c c zero out the charge interaction energy c ec = 0.0d0 if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c initialize connected atom exclusion coefficients 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 transfer the interaction site coordinates to sorting arrays c do ii = 1, nion i = iion(ii) ic = kion(i) xsort(ii) = x(ic) ysort(ii) = y(ic) zsort(ii) = z(ic) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nion,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nion i = iion(ii) in = jion(i) ic = kion(i) xic = xsort(rgx(ii)) yic = ysort(rgy(ii)) zic = zsort(rgz(ii)) xi = x(i) - x(ic) yi = y(i) - y(ic) zi = z(i) - z(ic) fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if kmap = kk - ((kk-1)/nion)*nion k = iion(kmap) kn = jion(k) kc = kion(k) prime = (kk .le. nion) c c decide whether to compute the current interaction c 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 xc = xic - xsort(j) yc = yic - ysort(kgy) zc = zic - zsort(kgz) if (use_bounds) then if (abs(xc) .gt. xcell2) xc = xc - sign(xcell,xc) if (abs(yc) .gt. ycell2) yc = yc - sign(ycell,yc) if (abs(zc) .gt. zcell2) zc = zc - sign(zcell,zc) if (monoclinic) then xc = xc + zc*beta_cos zc = zc * beta_sin else if (triclinic) then xc = xc + yc*gamma_cos + zc*beta_cos yc = yc*gamma_sin + zc*beta_term zc = zc * gamma_term end if end if 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(k) if (prime) fik = fik * cscale(kn) if (use_polymer) then if (r2 .gt. polycut2) fik = fi * pchg(k) 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 increment the overall charge-charge energy component c if (use_group) e = e * fgrp ec = ec + e end if end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ################################################################# c ## ## c ## subroutine echarge0c -- charge energy via neighbor list ## c ## ## c ################################################################# c c c "echarge0c" calculates the charge-charge interaction energy c using a pairwise neighbor list c c subroutine echarge0c use atoms use bound use charge use chgpot use couple use energi use group use neigh use shunt use usage implicit none integer i,j,k integer ii,in,ic integer kk,kn,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 c c c zero out the charge interaction energy c ec = 0.0d0 if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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 OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nion,iion,jion,kion,use, !$OMP& x,y,z,f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15, !$OMP& c1scale,c2scale,c3scale,c4scale,c5scale,use_group,use_bounds, !$OMP& off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,f6,f7, !$OMP& ebuffer) !$OMP& firstprivate(cscale) shared (ec) !$OMP DO reduction(+:ec) schedule(guided) c c calculate the charge interaction energy term c do ii = 1, nion i = iion(ii) in = jion(i) ic = kion(i) xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = 1, nelst(i) k = elst(kk,i) kn = jion(k) kc = kion(k) 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 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(k) * 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 increment the overall charge-charge energy component c if (use_group) e = e * fgrp ec = ec + e end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (cscale) return end c c c ################################################################# c ## ## c ## subroutine echarge0d -- double loop Ewald charge energy ## c ## ## c ################################################################# c c c "echarge0d" calculates the charge-charge interaction energy c using a particle mesh Ewald summation c c subroutine echarge0d use atoms use bound use boxes use cell use charge use chgpot use couple use energi use ewald use group use math use pme use shunt use usage implicit none integer i,j,k integer ii,in integer kk,kn real*8 e,fs,fgrp real*8 f,fi,fik real*8 r,r2,rb,rew real*8 xi,yi,zi real*8 xr,yr,zr real*8 xd,yd,zd real*8 erfc,erfterm real*8 sum,scale real*8, allocatable :: cscale(:) logical proceed,usei character*6 mode external erfc c c c zero out the Ewald charge interaction energy c ec = 0.0d0 if (nion .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bseorder aewald = aeewald c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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 = 'EWALD' call switch (mode) c c compute the Ewald self-energy term over all the atoms c fs = -f * aewald / rootpi do ii = 1, nion i = iion(ii) e = fs * pchg(i)**2 ec = ec + e end do c c compute the uniform background charge correction term c fs = -0.5d0 * f * pi / (volbox*aewald**2) sum = 0.0d0 do ii = 1, nion i = iion(ii) sum = sum + pchg(i) end do e = fs * sum**2 ec = ec + e c c compute the cell dipole boundary correction term c if (boundary .eq. 'VACUUM') then xd = 0.0d0 yd = 0.0d0 zd = 0.0d0 do ii = 1, nion i = iion(ii) xd = xd + pchg(i)*x(i) yd = yd + pchg(i)*y(i) zd = zd + pchg(i)*z(i) end do e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd) ec = ec + e end if c c compute the reciprocal space part of the Ewald summation c call ecrecip c c compute the real space portion of the Ewald summation c do ii = 1, nion-1 i = iion(ii) in = jion(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = use(i) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii+1, nion k = iion(kk) kn = jion(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) rb = r + ebuffer fik = fi * pchg(k) rew = aewald * r erfterm = erfc (rew) scale = cscale(kn) if (use_group) scale = scale * fgrp scale = scale - 1.0d0 e = (fik/rb) * (erfterm+scale) c c increment the overall charge-charge energy component c ec = ec + e end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 real space portion involving other unit cells c do ii = 1, nion i = iion(ii) in = jion(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = use(i) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii, nion k = iion(kk) kn = jion(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) call imager (xr,yr,zr,j) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rb = r + ebuffer fik = fi * pchg(k) rew = aewald * r erfterm = erfc (rew) 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 scale = scale - 1.0d0 e = (fik/rb) * (erfterm+scale) 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 exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 echarge0e -- Ewald charge energy via lights ## c ## ## c ################################################################ c c c "echarge0e" calculates the charge-charge interaction energy c using a particle mesh Ewald summation and the method of lights c c subroutine echarge0e use atoms use bound use boxes use cell use charge use chgpot use couple use energi use ewald use group use light use math use pme use shunt use usage implicit none integer i,j,k integer ii,in,ic integer kk,kn integer kgy,kgz,kmap integer start,stop real*8 e,fs,fgrp real*8 f,fi,fik real*8 r,r2,rb,rew real*8 xi,yi,zi real*8 xr,yr,zr real*8 xd,yd,zd real*8 erfc,erfterm real*8 sum,scale real*8, allocatable :: cscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat character*6 mode external erfc c c c zero out the Ewald charge interaction energy c ec = 0.0d0 if (nion .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bseorder aewald = aeewald c c perform dynamic allocation of some local arrays c allocate (cscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c initialize connected atom exclusion coefficients 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 = 'EWALD' call switch (mode) c c compute the Ewald self-energy term over all the atoms c fs = -f * aewald / rootpi do ii = 1, nion i = iion(ii) e = fs * pchg(i)**2 ec = ec + e end do c c compute the uniform background charge correction term c fs = -0.5d0 * f * pi / (volbox*aewald**2) sum = 0.0d0 do ii = 1, nion i = iion(ii) sum = sum + pchg(i) end do e = fs * sum**2 ec = ec + e c c compute the cell dipole boundary correction term c if (boundary .eq. 'VACUUM') then xd = 0.0d0 yd = 0.0d0 zd = 0.0d0 do ii = 1, nion i = iion(ii) xd = xd + pchg(i)*x(i) yd = yd + pchg(i)*y(i) zd = zd + pchg(i)*z(i) end do e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd) ec = ec + e end if c c compute the reciprocal space part of the Ewald summation c call ecrecip c c compute the real space portion of the Ewald summation; c transfer the interaction site coordinates to sorting arrays c do ii = 1, nion i = iion(ii) ic = kion(i) xsort(ii) = x(ic) ysort(ii) = y(ic) zsort(ii) = z(ic) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nion,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nion i = iion(ii) in = jion(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) fi = f * pchg(i) usei = (use(i)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if kmap = kk - ((kk-1)/nion)*nion k = iion(kmap) kn = jion(k) prime = (kk .le. nion) c c decide whether to compute the current interaction c if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rb = r + ebuffer rew = aewald * r erfterm = erfc (rew) scale = 1.0d0 if (prime) scale = cscale(kn) if (use_group) scale = scale * fgrp fik = fi * pchg(k) if (use_polymer) then if (r2 .gt. polycut2) fik = fi * pchg(k) end if scale = scale - 1.0d0 e = (fik/rb) * (erfterm+scale) c c increment the overall charge-charge energy component c ec = ec + e end if end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################## c ## ## c ## subroutine echarge0f -- Ewald charge energy via list ## c ## ## c ############################################################## c c c "echarge0f" calculates the charge-charge interaction energy c using a particle mesh Ewald summation and a neighbor list c c subroutine echarge0f use atoms use bound use boxes use charge use chgpot use couple use energi use ewald use group use math use neigh use pme use shunt use usage implicit none integer i,j,k integer ii,in integer kk,kn real*8 e,fs,fgrp real*8 f,fi,fik real*8 r,r2,rb,rew real*8 xi,yi,zi real*8 xr,yr,zr real*8 xd,yd,zd real*8 erfc,erfterm real*8 sum,scale real*8, allocatable :: cscale(:) logical proceed,usei character*6 mode external erfc c c c zero out the Ewald charge interaction energy c ec = 0.0d0 if (nion .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bseorder aewald = aeewald c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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 = 'EWALD' call switch (mode) c c compute the Ewald self-energy term over all the atoms c fs = -f * aewald / rootpi do ii = 1, nion i = iion(ii) e = fs * pchg(i)**2 ec = ec + e end do c c compute the uniform background charge correction term c fs = -0.5d0 * f * pi / (volbox*aewald**2) sum = 0.0d0 do ii = 1, nion i = iion(ii) sum = sum + pchg(i) end do e = fs * sum**2 ec = ec + e c c compute the cell dipole boundary correction term c if (boundary .eq. 'VACUUM') then xd = 0.0d0 yd = 0.0d0 zd = 0.0d0 do ii = 1, nion i = iion(ii) xd = xd + pchg(i)*x(i) yd = yd + pchg(i)*y(i) zd = zd + pchg(i)*z(i) end do e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd) ec = ec + e end if c c compute the reciprocal space part of the Ewald summation c call ecrecip c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nion,iion,jion,use,x,y,z, !$OMP& f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15,c1scale, !$OMP& c2scale,c3scale,c4scale,c5scale,use_group,off2,aewald,ebuffer) !$OMP& firstprivate(cscale) shared (ec) !$OMP DO reduction(+:ec) schedule(guided) c c compute the real space portion of the Ewald summation c do ii = 1, nion i = iion(ii) in = jion(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = use(i) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = 1, nelst(i) k = elst(kk,i) kn = jion(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) rb = r + ebuffer fik = fi * pchg(k) rew = aewald * r erfterm = erfc (rew) scale = cscale(kn) if (use_group) scale = scale * fgrp scale = scale - 1.0d0 e = (fik/rb) * (erfterm+scale) c c increment the overall charge-charge energy component c ec = ec + e end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (cscale) return end c c c ############################################################# c ## ## c ## subroutine echarge0g -- charge energy for smoothing ## c ## ## c ############################################################# c c c "echarge0g" calculates the charge-charge interaction energy c for use with potential smoothing methods c c subroutine echarge0g use atoms use charge use chgpot use couple use energi use group use usage use warp implicit none integer i,j,k integer ii,in integer kk,kn real*8 e,fgrp real*8 r,r2,rb,rb2 real*8 f,fi,fik real*8 xi,yi,zi real*8 xr,yr,zr real*8 erf,wterm,width real*8 width2,width3 real*8, allocatable :: cscale(:) logical proceed,usei external erf c c c zero out the charge interaction energy c ec = 0.0d0 if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n cscale(i) = 1.0d0 end do c c set the energy units conversion factor c f = electric / dielec 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 term c do ii = 1, nion-1 i = iion(ii) in = jion(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = (use(i)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii+1, nion k = iion(kk) kn = jion(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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 fik = fi * pchg(k) * cscale(kn) e = fik / rb c c transform the potential function via smoothing c if (use_dem) then if (width .gt. 0.0d0) then e = e * erf(width*rb) end if else if (use_gda) then width = m2(i) + m2(k) if (width .gt. 0.0d0) then width = wterm / sqrt(width) e = e * erf(width*rb) end if else if (use_tophat) then if (width .gt. rb) then rb2 = rb * rb e = fik * (3.0d0*width2-rb2) / (2.0d0*width3) end if else if (use_stophat) then e = fik / (rb+width) end if c c increment the overall charge-charge energy component c if (use_group) e = e * fgrp ec = ec + e end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 ecrecip -- PME reciprocal space charge energy ## c ## ## c ################################################################## c c c "ecrecip" evaluates the reciprocal space portion of the particle c mesh Ewald energy due to partial charges c c literature reference: c c U. Essmann, L. Perera, M. L Berkowitz, T. Darden, H. Lee and c L. G. Pedersen, "A Smooth Particle Mesh Ewald Method", Journal c of Chemical Physics, 103, 8577-8593 (1995) c c W. Smith and D. Fincham, "The Ewald Sum in Truncated Octahedral c and Rhombic Dodecahedral Boundary Conditions", Molecular c Simulation, 10, 67-71 (1993) c c modifications for nonperiodic systems suggested by Tom Darden c during May 2007 c c subroutine ecrecip use bound use boxes use chgpot use energi use ewald use math use pme implicit none integer i,j integer k1,k2,k3 integer m1,m2,m3 integer nf1,nf2,nf3 integer nff,ntot real*8 e,f,denom real*8 term,expterm real*8 pterm,volterm real*8 hsq,struc2 real*8 h1,h2,h3 real*8 r1,r2,r3 c c c return if the Ewald coefficient is zero c if (aewald .lt. 1.0d-6) return f = 0.5d0 * electric / dielec c c perform dynamic allocation of some global arrays c ntot = nfft1 * nfft2 * nfft3 if (allocated(qgrid)) then if (size(qgrid) .ne. 2*ntot) call fftclose end if if (.not. allocated(qgrid)) call fftsetup c c setup spatial decomposition and B-spline coefficients c call getchunk call moduli call bspline_fill call table_fill c c assign PME grid and perform 3-D FFT forward transform c call grid_pchg call fftfront c c use scalar sum to get the reciprocal space energy c pterm = (pi/aewald)**2 volterm = pi * volbox nf1 = (nfft1+1) / 2 nf2 = (nfft2+1) / 2 nf3 = (nfft3+1) / 2 nff = nfft1 * nfft2 ntot = nff * nfft3 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 (nonprism) then if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 end if struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2 e = f * expterm * struc2 ec = ec + e end if end do c c account for zeroth grid point for nonperiodic system c qgrid(1,1,1,1) = 0.0d0 qgrid(2,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 = f * expterm * struc2 ec = ec + e end if return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine echarge1 -- charge-charge energy & derivs ## c ## ## c ############################################################## c c c "echarge1" calculates the charge-charge interaction energy c and first derivatives with respect to Cartesian coordinates c c subroutine echarge1 use energi use extfld use limits use warp implicit none real*8 exf character*6 mode c c c choose the method for summing over pairwise interactions c if (use_smooth) then call echarge1g else if (use_ewald) then if (use_clist) then call echarge1f else if (use_lights) then call echarge1e else call echarge1d end if else if (use_clist) then call echarge1c else if (use_lights) then call echarge1b else call echarge1a end if c c get contribution from external electric field if used c if (use_exfld) then mode = 'CHARGE' call exfield1 (mode,exf) ec = ec + exf end if return end c c c ############################################################### c ## ## c ## subroutine echarge1a -- charge derivs via double loop ## c ## ## c ############################################################### c c c "echarge1a" calculates the charge-charge interaction energy c and first derivatives with respect to Cartesian coordinates c using a pairwise double loop c c subroutine echarge1a use atoms use bound use cell use charge use chgpot use couple use deriv use energi use group use shunt use usage use virial implicit none integer i,j,k integer ii,in,ic integer kk,kn,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 c c c zero out the charge interaction energy and derivatives c ec = 0.0d0 do i = 1, n dec(1,i) = 0.0d0 dec(2,i) = 0.0d0 dec(3,i) = 0.0d0 end do if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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(i) ic = kion(i) xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii+1, nion k = iion(kk) kn = jion(k) kc = kion(k) 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 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(k) * 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 end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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(i) ic = kion(i) xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 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 = 2, 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(k) 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 end if end do end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 echarge1b -- method of lights charge derivs ## c ## ## c ################################################################ c c c "echarge1b" calculates the charge-charge interaction energy c and first derivatives with respect to Cartesian coordinates c using the method of lights c c subroutine echarge1b use atoms use bound use boxes use cell use charge use chgpot use couple use deriv use energi use group use light use shunt use usage use virial implicit none integer i,j,k integer ii,in,ic integer kk,kn,kc integer kgy,kgz,kmap integer start,stop 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(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat character*6 mode c c c zero out the charge interaction energy and derivatives c ec = 0.0d0 do i = 1, n dec(1,i) = 0.0d0 dec(2,i) = 0.0d0 dec(3,i) = 0.0d0 end do if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c initialize connected atom exclusion coefficients 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 transfer the interaction site coordinates to sorting arrays c do ii = 1, nion i = iion(ii) ic = kion(i) xsort(ii) = x(ic) ysort(ii) = y(ic) zsort(ii) = z(ic) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nion,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nion i = iion(ii) in = jion(i) ic = kion(i) xic = xsort(rgx(ii)) yic = ysort(rgy(ii)) zic = zsort(rgz(ii)) xi = x(i) - x(ic) yi = y(i) - y(ic) zi = z(i) - z(ic) fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if kmap = kk - ((kk-1)/nion)*nion k = iion(kmap) kn = jion(k) kc = kion(k) prime = (kk .le. nion) c c decide whether to compute the current interaction c 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 xc = xic - xsort(j) yc = yic - ysort(kgy) zc = zic - zsort(kgz) if (use_bounds) then if (abs(xc) .gt. xcell2) xc = xc - sign(xcell,xc) if (abs(yc) .gt. ycell2) yc = yc - sign(ycell,yc) if (abs(zc) .gt. zcell2) zc = zc - sign(zcell,zc) if (monoclinic) then xc = xc + zc*beta_cos zc = zc * beta_sin else if (triclinic) then xc = xc + yc*gamma_cos + zc*beta_cos yc = yc*gamma_sin + zc*beta_term zc = zc * gamma_term end if end if 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(k) if (prime) fik = fik * cscale(kn) if (use_polymer) then if (r2 .gt. polycut2) fik = fi * pchg(k) 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 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 end if end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ################################################################# c ## ## c ## subroutine echarge1c -- charge derivs via neighbor list ## c ## ## c ################################################################# c c c "echarge1c" calculates the charge-charge interaction energy c and first derivatives with respect to Cartesian coordinates c using a pairwise neighbor list c c subroutine echarge1c use atoms use bound use charge use chgpot use couple use deriv use energi use group use neigh use shunt use usage use virial implicit none integer i,j,k integer ii,in,ic integer kk,kn,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 c c c zero out the charge interaction energy and derivatives c ec = 0.0d0 do i = 1, n dec(1,i) = 0.0d0 dec(2,i) = 0.0d0 dec(3,i) = 0.0d0 end do if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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 OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nion,iion,jion,kion,use, !$OMP& x,y,z,f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15, !$OMP& c1scale,c2scale,c3scale,c4scale,c5scale,use_group,use_bounds, !$OMP& off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5, !$OMP& f6,f7,ebuffer) !$OMP& firstprivate(cscale) shared (ec,dec,vir) !$OMP DO reduction(+:ec,dec,vir) schedule(guided) c c compute the charge interaction energy and first derivatives c do ii = 1, nion i = iion(ii) in = jion(i) ic = kion(i) xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = 1, nelst(i) k = elst(kk,i) kn = jion(k) kc = kion(k) 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 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(k) * 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 end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (cscale) return end c c c ################################################################# c ## ## c ## subroutine echarge1d -- double loop Ewald charge derivs ## c ## ## c ################################################################# c c c "echarge1d" calculates the charge-charge interaction energy c and first derivatives with respect to Cartesian coordinates c using a particle mesh Ewald summation c c subroutine echarge1d use atoms use bound use boxes use cell use charge use chgpot use couple use deriv use energi use ewald use group use math use pme use shunt use usage use virial implicit none integer i,j,k integer ii,in integer kk,kn real*8 e,de,f real*8 fi,fik,fs real*8 r,r2,rew real*8 rb,rb2 real*8 fgrp,term real*8 xi,yi,zi real*8 xr,yr,zr real*8 xd,yd,zd real*8 erfc,erfterm real*8 sum,scale real*8 dedx,dedy,dedz real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: cscale(:) logical proceed,usei character*6 mode external erfc c c c zero out the Ewald summation energy and derivatives c ec = 0.0d0 do i = 1, n dec(1,i) = 0.0d0 dec(2,i) = 0.0d0 dec(3,i) = 0.0d0 end do if (nion .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bseorder aewald = aeewald c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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 = 'EWALD' call switch (mode) c c compute the Ewald self-energy term over all the atoms c fs = -f * aewald / rootpi do ii = 1, nion i = iion(ii) e = fs * pchg(i)**2 ec = ec + e end do c c compute the uniform background charge correction term c fs = -0.5d0 * f * pi / (volbox*aewald**2) sum = 0.0d0 do ii = 1, nion i = iion(ii) sum = sum + pchg(i) end do e = fs * sum**2 ec = ec + e c c compute the cell dipole boundary correction term c if (boundary .eq. 'VACUUM') then xd = 0.0d0 yd = 0.0d0 zd = 0.0d0 do ii = 1, nion i = iion(ii) xd = xd + pchg(i)*x(i) yd = yd + pchg(i)*y(i) zd = zd + pchg(i)*z(i) end do term = (2.0d0/3.0d0) * f * (pi/volbox) e = term * (xd*xd+yd*yd+zd*zd) ec = ec + e do ii = 1, nion i = iion(ii) de = 2.0d0 * term * pchg(i) dedx = de * xd dedy = de * yd dedz = de * zd dec(1,i) = dec(1,i) + dedx dec(2,i) = dec(2,i) + dedy dec(3,i) = dec(3,i) + dedz end do end if c c compute reciprocal space Ewald energy and first derivatives c call ecrecip1 c c compute the real space Ewald energy and first derivatives c do ii = 1, nion-1 i = iion(ii) in = jion(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = use(i) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii+1, nion k = iion(kk) kn = jion(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) rb = r + ebuffer rb2 = rb * rb fik = fi * pchg(k) rew = aewald * r erfterm = erfc (rew) scale = cscale(kn) if (use_group) scale = scale * fgrp scale = scale - 1.0d0 e = (fik/rb) * (erfterm+scale) de = -fik * ((erfterm+scale)/rb2 & + (2.0d0*aewald/rootpi)*exp(-rew**2)/rb) c c form the chain rule terms for derivative expressions c de = de / r dedx = de * xr dedy = de * yr dedz = de * zr 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,k) = dec(1,k) - dedx dec(2,k) = dec(2,k) - dedy dec(3,k) = dec(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 real space portion involving other unit cells c do ii = 1, nion i = iion(ii) in = jion(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = use(i) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii, nion k = iion(kk) kn = jion(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) c c find appropriate image and check the real space cutoff c call imager (xr,yr,zr,j) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rb = r + ebuffer rb2 = rb * rb fik = fi * pchg(k) rew = aewald * r erfterm = erfc (rew) 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 scale = scale - 1.0d0 e = (fik/rb) * (erfterm+scale) de = -fik * ((erfterm+scale)/rb2 & + (2.0d0*aewald/rootpi)*exp(-rew**2)/rb) c c form the chain rule terms for derivative expressions c de = de / r dedx = de * xr dedy = de * yr dedz = de * zr 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 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 end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 echarge1e -- Ewald charge derivs via lights ## c ## ## c ################################################################ c c c "echarge1e" calculates the charge-charge interaction energy c and first derivatives with respect to Cartesian coordinates c using a particle mesh Ewald summation and the method of lights c c subroutine echarge1e use atoms use bound use boxes use cell use charge use chgpot use couple use deriv use energi use ewald use group use light use math use pme use shunt use usage use virial implicit none integer i,j,k integer ii,in,ic integer kk,kn integer kgy,kgz,kmap integer start,stop real*8 e,de,f real*8 fi,fik,fs real*8 r,r2,rew real*8 rb,rb2 real*8 fgrp,term real*8 xi,yi,zi real*8 xr,yr,zr real*8 xd,yd,zd real*8 erfc,erfterm real*8 sum,scale real*8 dedx,dedy,dedz real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: cscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat character*6 mode external erfc c c c zero out the Ewald summation energy and derivatives c ec = 0.0d0 do i = 1, n dec(1,i) = 0.0d0 dec(2,i) = 0.0d0 dec(3,i) = 0.0d0 end do if (nion .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bseorder aewald = aeewald c c perform dynamic allocation of some local arrays c allocate (cscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c initialize connected atom exclusion coefficients 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 = 'EWALD' call switch (mode) c c compute the Ewald self-energy term over all the atoms c fs = -f * aewald / rootpi do ii = 1, nion i = iion(ii) e = fs * pchg(i)**2 ec = ec + e end do c c compute the uniform background charge correction term c fs = -0.5d0 * f * pi / (volbox*aewald**2) sum = 0.0d0 do ii = 1, nion i = iion(ii) sum = sum + pchg(i) end do e = fs * sum**2 ec = ec + e c c compute the cell dipole boundary correction term c if (boundary .eq. 'VACUUM') then xd = 0.0d0 yd = 0.0d0 zd = 0.0d0 do ii = 1, nion i = iion(ii) xd = xd + pchg(i)*x(i) yd = yd + pchg(i)*y(i) zd = zd + pchg(i)*z(i) end do term = (2.0d0/3.0d0) * f * (pi/volbox) e = term * (xd*xd+yd*yd+zd*zd) ec = ec + e do ii = 1, nion i = iion(ii) de = 2.0d0 * term * pchg(i) dedx = de * xd dedy = de * yd dedz = de * zd dec(1,i) = dec(1,i) + dedx dec(2,i) = dec(2,i) + dedy dec(3,i) = dec(3,i) + dedz end do end if c c compute reciprocal space Ewald energy and first derivatives c call ecrecip1 c c compute the real space portion of the Ewald summation; c transfer the interaction site coordinates to sorting arrays c do ii = 1, nion i = iion(ii) ic = kion(i) xsort(ii) = x(ic) ysort(ii) = y(ic) zsort(ii) = z(ic) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nion,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nion i = iion(ii) in = jion(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) fi = f * pchg(i) usei = (use(i)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if kmap = kk - ((kk-1)/nion)*nion k = iion(kmap) kn = jion(k) prime = (kk .le. nion) c c decide whether to compute the current interaction c if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rb = r + ebuffer rb2 = rb * rb rew = aewald * r erfterm = erfc (rew) scale = 1.0d0 if (prime) scale = cscale(kn) if (use_group) scale = scale * fgrp fik = fi * pchg(k) if (use_polymer) then if (r2 .gt. polycut2) fik = fi * pchg(k) end if scale = scale - 1.0d0 e = (fik/rb) * (erfterm+scale) de = -fik * ((erfterm+scale)/rb2 & + (2.0d0*aewald/rootpi)*exp(-rew**2)/rb) c c form the chain rule terms for derivative expressions c de = de / r dedx = de * xr dedy = de * yr dedz = de * zr 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,k) = dec(1,k) - dedx dec(2,k) = dec(2,k) - dedy dec(3,k) = dec(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################## c ## ## c ## subroutine echarge1f -- Ewald charge derivs via list ## c ## ## c ############################################################## c c c "echarge1f" calculates the charge-charge interaction energy c and first derivatives with respect to Cartesian coordinates c using a particle mesh Ewald summation and a neighbor list c c subroutine echarge1f use atoms use bound use boxes use charge use chgpot use couple use deriv use energi use ewald use group use math use neigh use pme use shunt use usage use virial implicit none integer i,j,k integer ii,in integer kk,kn real*8 e,de,f real*8 fi,fik,fs real*8 r,r2,rew real*8 rb,rb2 real*8 fgrp,term real*8 xi,yi,zi real*8 xr,yr,zr real*8 xd,yd,zd real*8 erfc,erfterm real*8 sum,scale real*8 dedx,dedy,dedz real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: cscale(:) logical proceed,usei character*6 mode external erfc c c c zero out the Ewald summation energy and derivatives c ec = 0.0d0 do i = 1, n dec(1,i) = 0.0d0 dec(2,i) = 0.0d0 dec(3,i) = 0.0d0 end do if (nion .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bseorder aewald = aeewald c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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 = 'EWALD' call switch (mode) c c compute the Ewald self-energy term over all the atoms c fs = -f * aewald / rootpi do ii = 1, nion i = iion(ii) e = fs * pchg(i)**2 ec = ec + e end do c c compute the uniform background charge correction term c fs = -0.5d0 * f * pi / (volbox*aewald**2) sum = 0.0d0 do ii = 1, nion i = iion(ii) sum = sum + pchg(i) end do e = fs * sum**2 ec = ec + e c c compute the cell dipole boundary correction term c if (boundary .eq. 'VACUUM') then xd = 0.0d0 yd = 0.0d0 zd = 0.0d0 do ii = 1, nion i = iion(ii) xd = xd + pchg(i)*x(i) yd = yd + pchg(i)*y(i) zd = zd + pchg(i)*z(i) end do term = (2.0d0/3.0d0) * f * (pi/volbox) e = term * (xd*xd+yd*yd+zd*zd) ec = ec + e do ii = 1, nion i = iion(ii) de = 2.0d0 * term * pchg(i) dedx = de * xd dedy = de * yd dedz = de * zd dec(1,i) = dec(1,i) + dedx dec(2,i) = dec(2,i) + dedy dec(3,i) = dec(3,i) + dedz end do end if c c compute reciprocal space Ewald energy and first derivatives c call ecrecip1 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nion,iion,jion,use,x,y,z, !$OMP& f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15,c1scale, !$OMP& c2scale,c3scale,c4scale,c5scale,use_group,off2,aewald,ebuffer) !$OMP& firstprivate(cscale) shared (ec,dec,vir) !$OMP DO reduction(+:ec,dec,vir) schedule(guided) c c compute the real space Ewald energy and first derivatives c do ii = 1, nion i = iion(ii) in = jion(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = use(i) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = 1, nelst(i) k = elst(kk,i) kn = jion(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) 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) c c find energy for interactions within real space cutoff c 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(k) rew = aewald * r erfterm = erfc (rew) scale = cscale(kn) if (use_group) scale = scale * fgrp scale = scale - 1.0d0 e = (fik/rb) * (erfterm+scale) de = -fik * ((erfterm+scale)/rb2 & + (2.0d0*aewald/rootpi)*exp(-rew**2)/rb) c c form the chain rule terms for derivative expressions c de = de / r dedx = de * xr dedy = de * yr dedz = de * zr 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,k) = dec(1,k) - dedx dec(2,k) = dec(2,k) - dedy dec(3,k) = dec(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (cscale) return end c c c ################################################################## c ## ## c ## subroutine echarge1g -- charge derivatives for smoothing ## c ## ## c ################################################################## c c c "echarge1g" calculates the charge-charge interaction energy c and first derivatives with respect to Cartesian coordinates c for use with potential smoothing methods c c subroutine echarge1g use atoms use charge use chgpot use couple use deriv use energi use group use math use usage use warp implicit none integer i,j,k integer ii,in integer kk,kn real*8 e,de,fgrp real*8 r,r2,rb,rb2 real*8 f,fi,fik real*8 xi,yi,zi real*8 xr,yr,zr real*8 dedx,dedy,dedz real*8 erf,erfterm real*8 expcut,expterm real*8 wterm,width real*8 width2,width3 real*8, allocatable :: cscale(:) logical proceed,usei external erf c c c zero out the charge interaction energy and derivatives c ec = 0.0d0 do i = 1, n dec(1,i) = 0.0d0 dec(2,i) = 0.0d0 dec(3,i) = 0.0d0 end do if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n cscale(i) = 1.0d0 end do c c set the energy units conversion factor c f = electric / dielec 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 compute the charge interaction energy and first derivatives c do ii = 1, nion-1 i = iion(ii) in = jion(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = (use(i)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii+1, nion k = iion(kk) kn = jion(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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(k) * cscale(kn) e = fik / rb de = -fik / rb2 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) & / (rootpi*rb) else expterm = 0.0d0 end if e = e * erfterm de = de*erfterm + expterm end if else if (use_gda) then width = m2(i) + m2(k) if (width .gt. 0.0d0) then width = wterm / sqrt(width) erfterm = erf(width*rb) expterm = -rb2 * width * width if (expterm .gt. expcut) then expterm = 2.0d0*fik*width*exp(expterm) & / (rootpi*rb) else expterm = 0.0d0 end if e = e * erfterm de = de*erfterm + expterm end if else if (use_tophat) then if (width .gt. rb) then e = fik * (3.0d0*width2-rb2) / (2.0d0*width3) de = -fik * rb / width3 end if else if (use_stophat) then wterm = rb + width e = fik / wterm de = -fik / (wterm*wterm) end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * 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 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,k) = dec(1,k) - dedx dec(2,k) = dec(2,k) - dedy dec(3,k) = dec(3,k) - dedz c c increment the total intermolecular energy c end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 ecrecip1 -- PME recip charge energy & derivs ## c ## ## c ################################################################# c c c "ecrecip1" evaluates the reciprocal space portion of the particle c mesh Ewald summation energy and gradient due to partial charges c c literature reference: c c U. Essmann, L. Perera, M. L Berkowitz, T. Darden, H. Lee and c L. G. Pedersen, "A Smooth Particle Mesh Ewald Method", Journal c of Chemical Physics, 103, 8577-8593 (1995) c c W. Smith and D. Fincham, "The Ewald Sum in Truncated Octahedral c and Rhombic Dodecahedral Boundary Conditions", Molecular c Simulation, 10, 67-71 (1993) c c modifications for nonperiodic systems suggested by Tom Darden c during May 2007 c c subroutine ecrecip1 use atoms use bound use boxes use charge use chgpot use deriv use energi use ewald use math use pme use virial implicit none integer i,j,ii integer k1,k2,k3 integer m1,m2,m3 integer nf1,nf2,nf3 integer nff,ntot real*8 e,term,eterm real*8 expterm real*8 vterm,pterm real*8 volterm real*8 vxx,vyy,vzz real*8 vxy,vxz,vyz real*8 f,fi,denom real*8 hsq,struc2 real*8 h1,h2,h3 real*8 r1,r2,r3 real*8 f1,f2,f3 real*8, allocatable :: fphi(:,:) c c c return if the Ewald coefficient is zero c if (aewald .lt. 1.0d-6) return f = electric / dielec c c perform dynamic allocation of some global arrays c ntot = nfft1 * nfft2 * nfft3 if (allocated(qgrid)) then if (size(qgrid) .ne. 2*ntot) call fftclose end if if (.not. allocated(qgrid)) call fftsetup c c setup spatial decomposition and B-spline coefficients c call getchunk call moduli call bspline_fill call table_fill c c assign PME grid and perform 3-D FFT forward transform c call grid_pchg call fftfront c c zero out the temporary virial accumulation variables c vxx = 0.0d0 vxy = 0.0d0 vxz = 0.0d0 vyy = 0.0d0 vyz = 0.0d0 vzz = 0.0d0 c c use scalar sum to get reciprocal space energy and virial c pterm = (pi/aewald)**2 volterm = pi * volbox nf1 = (nfft1+1) / 2 nf2 = (nfft2+1) / 2 nf3 = (nfft3+1) / 2 nff = nfft1 * nfft2 ntot = nff * nfft3 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 (nonprism) then if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 end if struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2 eterm = 0.5d0 * f * expterm * struc2 vterm = (2.0d0/hsq) * (1.0d0-term) * eterm vxx = vxx + h1*h1*vterm - eterm vxy = vxy + h1*h2*vterm vxz = vxz + h1*h3*vterm vyy = vyy + h2*h2*vterm - eterm vyz = vyz + h2*h3*vterm vzz = vzz + h3*h3*vterm - eterm end if qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3) qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3) end do c c increment the total internal virial tensor components c vir(1,1) = vir(1,1) + vxx vir(2,1) = vir(2,1) + vxy vir(3,1) = vir(3,1) + vxz vir(1,2) = vir(1,2) + vxy vir(2,2) = vir(2,2) + vyy vir(3,2) = vir(3,2) + vyz vir(1,3) = vir(1,3) + vxz vir(2,3) = vir(2,3) + vyz vir(3,3) = vir(3,3) + vzz c c account for zeroth grid point for nonperiodic system c qgrid(1,1,1,1) = 0.0d0 qgrid(2,1,1,1) = 0.0d0 if (.not. use_bounds) then expterm = 0.5d0 * pi / xbox qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1) qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1) end if c c perform the 3-D FFT backward transformation c call fftback c c perform dynamic allocation of some local arrays c allocate (fphi(4,n)) c c extract the partial charge electrostatic potential c call fphi_pchg (fphi) c c increment partial charge energy and gradient components c e = 0.0d0 do ii = 1, nion i = iion(ii) fi = f * pchg(i) e = e + fi*fphi(1,i) f1 = fi * dble(nfft1) * fphi(2,i) f2 = fi * dble(nfft2) * fphi(3,i) f3 = fi * dble(nfft3) * fphi(4,i) h1 = recip(1,1)*f1 + recip(1,2)*f2 + recip(1,3)*f3 h2 = recip(2,1)*f1 + recip(2,2)*f2 + recip(2,3)*f3 h3 = recip(3,1)*f1 + recip(3,2)*f2 + recip(3,3)*f3 dec(1,i) = dec(1,i) + h1 dec(2,i) = dec(2,i) + h2 dec(3,i) = dec(3,i) + h3 end do e = 0.5d0 * e ec = ec + e c c perform deallocation of some local arrays c deallocate (fphi) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine echarge2 -- atomwise charge-charge Hessian ## c ## ## c ############################################################### c c c "echarge2" calculates second derivatives of the c charge-charge interaction energy for a single atom c c subroutine echarge2 (i) use limits use warp implicit none integer i c c c choose the method for summing over pairwise interactions c if (use_smooth) then call echarge2f (i) else if (use_ewald) then call echarge2c (i) if (use_clist) then call echarge2e (i) else call echarge2d (i) end if else if (use_clist) then call echarge2b (i) else call echarge2a (i) end if return end c c c ################################################################## c ## ## c ## subroutine echarge2a -- charge Hessian via pairwise loop ## c ## ## c ################################################################## c c c "echarge2a" calculates second derivatives of the charge-charge c interaction energy for a single atom using a pairwise loop c c subroutine echarge2a (i) use atoms use bound use cell use charge use chgpot use couple use group use hessn use shunt implicit none integer i,j,k,kk integer in,ic,kn,kc integer jcell real*8 e,de,d2e real*8 fi,fik,fgrp real*8 r,r2,rb,rb2 real*8 d2edx,d2edy,d2edz 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 dtaper,dtrans real*8 d2taper,d2trans real*8 rc,rc2,rc3,rc4 real*8 rc5,rc6,rc7 real*8 term(3,3) real*8, allocatable :: cscale(:) logical proceed character*6 mode c c c first see if the atom of interest carries a charge c do kk = 1, nion k = iion(kk) if (k .eq. i) then fi = electric * pchg(k) / dielec in = jion(k) ic = kion(k) goto 10 end if end do return 10 continue c c store the coordinates of the atom of interest c xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients c do j = 1, nion cscale(iion(j)) = 1.0d0 end do cscale(in) = c1scale 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 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(k) kc = kion(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (kn .ne. i) 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(k) * 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 (rc2 .gt. cut2) then e = fik / rb shift = fik / (0.5d0*(off+cut)) e = e - shift 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 d2taper = 20.0d0*c5*rc3 + 12.0d0*c4*rc2 & + 6.0d0*c3*rc + 2.0d0*c2 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) d2trans = fik * (42.0d0*f7*rc5 + 30.0d0*f6*rc4 & + 20.0d0*f5*rc3 + 12.0d0*f4*rc2 & + 6.0d0*f3*rc + 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 c c calculate interaction energy with other unit cells c do kk = 1, nion k = iion(kk) kn = jion(k) kc = kion(k) 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 = 2, ncell xc = xic - x(kc) yc = yic - y(kc) zc = zic - z(kc) call imager (xc,yc,zc,jcell) 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(k) if (use_polymer) then if (rc2 .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 / rb shift = fik / (0.5d0*(off+cut)) e = e - shift 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 d2taper = 20.0d0*c5*rc3 + 12.0d0*c4*rc2 & + 6.0d0*c3*rc + 2.0d0*c2 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) d2trans = fik * (42.0d0*f7*rc5 + 30.0d0*f6*rc4 & + 20.0d0*f5*rc3 + 12.0d0*f4*rc2 & + 6.0d0*f3*rc + 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 c c c ################################################################## c ## ## c ## subroutine echarge2b -- charge Hessian via neighbor list ## c ## ## c ################################################################## c c c "echarge2b" calculates second derivatives of the charge-charge c interaction energy for a single atom using a neighbor list c c subroutine echarge2b (i) use atoms use bound use cell use charge use chgpot use couple use group use hessn use neigh use shunt implicit none integer i,j,k,kk integer in,ic,kn,kc real*8 e,de,d2e real*8 fi,fik,fgrp real*8 r,r2,rb,rb2 real*8 d2edx,d2edy,d2edz 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 dtaper,dtrans real*8 d2taper,d2trans real*8 rc,rc2,rc3,rc4 real*8 rc5,rc6,rc7 real*8 term(3,3) real*8, allocatable :: cscale(:) logical proceed character*6 mode c c c first see if the atom of interest carries a charge c do kk = 1, nion k = iion(kk) if (k .eq. i) then fi = electric * pchg(k) / dielec in = jion(k) ic = kion(k) goto 10 end if end do return 10 continue c c store the coordinates of the atom of interest c xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients c do j = 1, nion cscale(iion(j)) = 1.0d0 end do cscale(in) = c1scale 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 c c set cutoff distances and switching function coefficients c mode = 'CHARGE' call switch (mode) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(i,iion,jion,kion,x,y,z, !$OMP& xi,yi,zi,xic,yic,zic,fi,pchg,nelst,elst,use_group,use_bounds, !$OMP& off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,f6,f7, !$OMP& ebuffer,cscale) !$OMP& shared (hessx,hessy,hessz) !$OMP DO reduction(+:hessx,hessy,hessz) schedule(guided) c c calculate the charge interaction energy Hessian elements c do kk = 1, nelst(i) k = elst(kk,i) kn = jion(k) kc = kion(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (kn .ne. i) 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(k) * 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 / rb shift = fik / (0.5d0*(off+cut)) e = e - shift 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 d2taper = 20.0d0*c5*rc3 + 12.0d0*c4*rc2 & + 6.0d0*c3*rc + 2.0d0*c2 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) d2trans = fik * (42.0d0*f7*rc5 + 30.0d0*f6*rc4 & + 20.0d0*f5*rc3 + 12.0d0*f4*rc2 & + 6.0d0*f3*rc + 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (cscale) return end c c c ################################################################# c ## ## c ## subroutine echarge2c -- reciprocal Ewald charge Hessian ## c ## ## c ################################################################# c c c "echarge2c" calculates second derivatives of the reciprocal c space charge-charge interaction energy for a single atom using c a particle mesh Ewald summation via numerical differentiation c c subroutine echarge2c (i) use atoms use deriv use hessn implicit none integer i,j,k real*8 eps,old real*8, allocatable :: d0(:,:) logical prior logical twosided c c c set the default stepsize and accuracy control flags c eps = 1.0d-5 twosided = .false. if (n .le. 300) twosided = .true. if (n .gt. 600) return c c perform dynamic allocation of some local arrays c allocate (d0(3,n)) c c perform dynamic allocation of some global arrays c prior = .false. if (allocated(dec)) then prior = .true. if (size(dec) .lt. 3*n) deallocate (dec) end if if (.not. allocated(dec)) allocate (dec(3,n)) c c get charge first derivatives for the base structure c if (.not. twosided) then call echarge2r do k = 1, n do j = 1, 3 d0(j,k) = dec(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 echarge2r do k = 1, n do j = 1, 3 d0(j,k) = dec(j,k) end do end do end if x(i) = x(i) + eps call echarge2r x(i) = old do k = 1, n do j = 1, 3 hessx(j,k) = hessx(j,k) + (dec(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 echarge2r do k = 1, n do j = 1, 3 d0(j,k) = dec(j,k) end do end do end if y(i) = y(i) + eps call echarge2r y(i) = old do k = 1, n do j = 1, 3 hessy(j,k) = hessy(j,k) + (dec(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 echarge2r do k = 1, n do j = 1, 3 d0(j,k) = dec(j,k) end do end do end if z(i) = z(i) + eps call echarge2r z(i) = old do k = 1, n do j = 1, 3 hessz(j,k) = hessz(j,k) + (dec(j,k)-d0(j,k))/eps end do end do c c perform deallocation of some global arrays c if (.not. prior) deallocate (dec) c c perform deallocation of some local arrays c deallocate (d0) return end c c c ############################################################# c ## ## c ## subroutine echarge2r -- recip charge derivs utility ## c ## ## c ############################################################# c c c "echarge2r" computes reciprocal space charge-charge first c derivatives; used to get finite difference second derivatives c c subroutine echarge2r use atoms use boxes use charge use chgpot use deriv use ewald use math use pme implicit none integer i,ii real*8 de,f,term real*8 xd,yd,zd real*8 dedx,dedy,dedz c c c zero out the Ewald summation derivative values c do i = 1, n dec(1,i) = 0.0d0 dec(2,i) = 0.0d0 dec(3,i) = 0.0d0 end do if (nion .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bseorder aewald = aeewald f = electric / dielec c c compute the cell dipole boundary correction term c if (boundary .eq. 'VACUUM') then xd = 0.0d0 yd = 0.0d0 zd = 0.0d0 do ii = 1, nion i = iion(ii) xd = xd + pchg(i)*x(i) yd = yd + pchg(i)*y(i) zd = zd + pchg(i)*z(i) end do term = (2.0d0/3.0d0) * f * (pi/volbox) do ii = 1, nion i = iion(ii) de = 2.0d0 * term * pchg(i) dedx = de * xd dedy = de * yd dedz = de * zd dec(1,i) = dec(1,i) + dedx dec(2,i) = dec(2,i) + dedy dec(3,i) = dec(3,i) + dedz end do end if c c compute reciprocal space Ewald first derivative values c call ecrecip1 return end c c c ################################################################# c ## ## c ## subroutine echarge2d -- real Ewald charge Hessian; loop ## c ## ## c ################################################################# c c c "echarge2d" calculates second derivatives of the real space c charge-charge interaction energy for a single atom using a c pairwise loop c c subroutine echarge2d (i) use atoms use bound use cell use charge use chgpot use couple use ewald use group use hessn use limits use math use shunt implicit none integer i,j,k,kk integer in,kn,jcell real*8 fi,fik,fgrp real*8 r,r2,rb,rb2 real*8 de,d2e real*8 d2edx,d2edy,d2edz real*8 xi,yi,zi real*8 xr,yr,zr real*8 rew,erfc real*8 erfterm,expterm real*8 scale real*8 term(3,3) real*8, allocatable :: cscale(:) logical proceed character*6 mode external erfc c c c first see if the atom of interest carries a charge c do kk = 1, nion k = iion(kk) if (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 cutoff distances and switching function coefficients c mode = 'EWALD' call switch (mode) c c initialize connected atom exclusion coefficients c do j = 1, nion cscale(iion(j)) = 1.0d0 end do cscale(in) = c1scale 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 c c calculate the real space Ewald interaction Hessian elements c do kk = 1, nion k = iion(kk) kn = jion(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (kn .ne. i) 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. off2) then r = sqrt(r2) rb = r + ebuffer rb2 = rb * rb fik = fi * pchg(k) * cscale(kn) rew = aewald * r erfterm = erfc (rew) expterm = exp(-rew**2) scale = cscale(kn) if (use_group) scale = scale * fgrp scale = scale - 1.0d0 c c compute chain rule terms for Hessian matrix elements c de = -fik * ((erfterm+scale)/rb2 & + (2.0d0*aewald/rootpi)*expterm/r) d2e = -2.0d0*de/rb + 2.0d0*(fik/(rb*rb2))*scale & + (4.0d0*fik*aewald**3/rootpi)*expterm & + 2.0d0*(fik/(rb*rb2))*scale 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 c c calculate interaction energy with other unit cells c do kk = 1, nion k = iion(kk) kn = jion(k) 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 = 2, 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(k) 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 scale = scale - 1.0d0 c c compute chain rule terms for Hessian matrix elements c de = -fik * ((erfterm+scale)/rb2 & + (2.0d0*aewald/rootpi)*exp(-rew**2)/r) d2e = -2.0d0*de/rb + 2.0d0*(fik/(rb*rb2))*scale & + (4.0d0*fik*aewald**3/rootpi)*expterm & + 2.0d0*(fik/(rb*rb2))*scale 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 c c c ################################################################# c ## ## c ## subroutine echarge2e -- real Ewald charge Hessian; list ## c ## ## c ################################################################# c c c "echarge2e" calculates second derivatives of the real space c charge-charge interaction energy for a single atom using a c pairwise neighbor list c c subroutine echarge2e (i) use atoms use bound use charge use chgpot use couple use ewald use group use hessn use limits use math use neigh use shunt implicit none integer i,j,k integer in,kn,kk real*8 fi,fik,fgrp real*8 r,r2,rb,rb2 real*8 de,d2e real*8 d2edx,d2edy,d2edz real*8 xi,yi,zi real*8 xr,yr,zr real*8 rew,erfc real*8 erfterm,expterm real*8 scale real*8 term(3,3) real*8, allocatable :: cscale(:) logical proceed character*6 mode external erfc c c c first see if the atom of interest carries a charge c do kk = 1, nion k = iion(kk) if (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 cutoff distances and switching function coefficients c mode = 'EWALD' call switch (mode) c c initialize connected atom exclusion coefficients c do j = 1, nion cscale(iion(j)) = 1.0d0 end do cscale(in) = c1scale 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 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(i,iion,jion,x,y,z,fi, !$OMP& pchg,nelst,elst,cscale,use_group,off2,aewald,ebuffer) !$OMP& shared (hessx,hessy,hessz) !$OMP DO reduction(+:hessx,hessy,hessz) schedule(guided) c c calculate the real space Ewald interaction Hessian elements c do kk = 1, nelst(i) k = elst(kk,i) kn = jion(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (kn .ne. i) 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. off2) then r = sqrt(r2) rb = r + ebuffer rb2 = rb * rb fik = fi * pchg(k) * cscale(kn) rew = aewald * r erfterm = erfc (rew) expterm = exp(-rew**2) scale = cscale(kn) if (use_group) scale = scale * fgrp scale = scale - 1.0d0 c c compute chain rule terms for Hessian matrix elements c de = -fik * ((erfterm+scale)/rb2 & + (2.0d0*aewald/rootpi)*expterm/r) d2e = -2.0d0*de/rb + 2.0d0*(fik/(rb*rb2))*scale & + (4.0d0*fik*aewald**3/rootpi)*expterm & + 2.0d0*(fik/(rb*rb2))*scale 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (cscale) return end c c c ############################################################## c ## ## c ## subroutine echarge2f -- charge Hessian for smoothing ## c ## ## c ############################################################## c c c "echarge2f" calculates second derivatives of the charge-charge c interaction energy for a single atom for use with potential c smoothing methods c c subroutine echarge2f (i) use atoms use charge use chgpot use couple use group use hessn use math use warp implicit none integer i,j,k integer in,kn,kk real*8 fi,fik,fgrp real*8 r,r2,rb,rb2 real*8 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 c c c first see if the atom of interest carries a charge c do kk = 1, nion k = iion(kk) if (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 initialize connected atom exclusion coefficients c do j = 1, nion cscale(iion(j)) = 1.0d0 end do cscale(in) = c1scale 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 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(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (kn .ne. i) 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(k) * cscale(kn) c c compute chain rule terms for Hessian matrix elements c 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) & / (rootpi*rb) else expterm = 0.0d0 end if 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) & / (rootpi*rb) else expterm = 0.0d0 end if de = de*erfterm + expterm d2e = -2.0d0 * (de/rb + expterm*r*width2) end if else if (use_tophat) then if (width .gt. rb) then d2e = -fik / width3 de = d2e * rb end if else if (use_stophat) then wterm = rb + width 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 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 c c perform deallocation of some local arrays c deallocate (cscale) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine echarge3 -- charge-charge energy & analysis ## c ## ## c ################################################################ c c c "echarge3" calculates the charge-charge interaction energy c and partitions the energy among the atoms c c subroutine echarge3 use energi use extfld use inform use iounit use limits use warp implicit none real*8 exf character*6 mode c c c choose the method for summing over pairwise interactions c if (use_smooth) then call echarge3g else if (use_ewald) then if (use_clist) then call echarge3f else if (use_lights) then call echarge3e else call echarge3d end if else if (use_clist) then call echarge3c else if (use_lights) then call echarge3b else call echarge3a end if c c get contribution from external electric field if used c if (use_exfld) then mode = 'CHARGE' call exfield3 (mode,exf) ec = ec + exf if (verbose .and. exf.ne.0.0d0) then if (digits .ge. 8) then write (iout,10) exf 10 format (/,' External Electric Field :',7x,f16.8) else if (digits .ge. 6) then write (iout,20) exf 20 format (/,' External Electric Field :',7x,f16.6) else write (iout,30) exf 30 format (/,' External Electric Field :',7x,f16.4) end if end if end if return end c c c ################################################################# c ## ## c ## subroutine echarge3a -- charge analysis via double loop ## c ## ## c ################################################################# c c c "echarge3a" calculates the charge-charge interaction energy c and partitions the energy among the atoms using a pairwise c double loop c c subroutine echarge3a use action use analyz use atomid use atoms use bound use cell use charge use chgpot use couple use energi use group use inform use inter use iounit use molcul use shunt use usage implicit none integer i,j,k integer ii,in,ic,im integer kk,kn,kc,km 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 c c c zero out the charge interaction energy and partitioning c nec = 0 ec = 0.0d0 do i = 1, n aec(i) = 0.0d0 end do if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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 print header information if debug output was requested c header = .true. if (debug .and. nion.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge-Charge Interactions :', & //,' Type',14x,'Atom Names',17x,'Charges', & 5x,'Distance',6x,'Energy',/) end if c c compute and partition the charge interaction energy c do ii = 1, nion-1 i = iion(ii) in = jion(i) ic = kion(i) im = molcule(i) xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii+1, nion k = iion(kk) kn = jion(k) kc = kion(k) km = molcule(k) 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) 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(k) * 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 increment the overall charge-charge energy components c if (e .ne. 0.0d0) then if (use_group) e = e * fgrp nec = nec + 1 ec = ec + e aec(i) = aec(i) + 0.5d0*e aec(k) = aec(k) + 0.5d0*e if (im .ne. km) 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.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Charge-Charge', & ' Interactions :', & //,' Type',14x,'Atom Names', & 17x,'Charges',5x,'Distance', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & pchg(i),pchg(k),r,e 30 format (' Charge',4x,2(i7,'-',a3),8x, & 2f7.2,f11.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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(i) ic = kion(i) xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii, nion k = iion(kk) kn = jion(k) kc = kion(k) 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 = 2, 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(k) 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 increment the overall charge-charge energy components c if (e .ne. 0.0d0) then if (use_group) e = e * fgrp if (i .eq. k) e = 0.5d0 * e nec = nec + 1 ec = ec + e aec(i) = aec(i) + 0.5d0*e aec(k) = aec(k) + 0.5d0*e 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.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual Charge-Charge', & ' Interactions :', & //,' Type',14x,'Atom Names', & 17x,'Charges',5x,'Distance', & 6x,'Energy',/) end if write (iout,50) i,name(i),k,name(k), & pchg(i),pchg(k),r,e 50 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 exclusion coefficients for connected atoms c cscale(in) = c1scale 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 echarge3b -- method of lights charge analysis ## c ## ## c ################################################################## c c c "echarge3b" calculates the charge-charge interaction energy c and partitions the energy among the atoms using the method c of lights c c subroutine echarge3b use action use analyz use atomid use atoms use bound use boxes use cell use charge use chgpot use couple use energi use group use inform use inter use iounit use light use molcul use shunt use usage implicit none integer i,j,k integer ii,in,ic,im integer kk,kn,kc,km integer kgy,kgz,kmap integer start,stop integer ikmin,ikmax 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(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat logical header,huge character*6 mode c c c zero out the charge interaction energy and partitioning c nec = 0 ec = 0.0d0 do i = 1, n aec(i) = 0.0d0 end do if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c initialize connected atom exclusion coefficients 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 print header information if debug output was requested c header = .true. if (debug .and. nion.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge-Charge Interactions :', & //,' Type',14x,'Atom Names',17x,'Charges', & 5x,'Distance',6x,'Energy',/) end if c c transfer the interaction site coordinates to sorting arrays c do ii = 1, nion i = iion(ii) ic = kion(i) xsort(ii) = x(ic) ysort(ii) = y(ic) zsort(ii) = z(ic) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nion,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nion i = iion(ii) in = jion(i) ic = kion(i) im = molcule(i) xic = xsort(rgx(ii)) yic = ysort(rgy(ii)) zic = zsort(rgz(ii)) xi = x(i) - x(ic) yi = y(i) - y(ic) zi = z(i) - z(ic) fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 20 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 60 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 60 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 60 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 60 end if kmap = kk - ((kk-1)/nion)*nion k = iion(kmap) kn = jion(k) kc = kion(k) km = molcule(k) prime = (kk .le. nion) c c decide whether to compute the current interaction c 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 xc = xic - xsort(j) yc = yic - ysort(kgy) zc = zic - zsort(kgz) if (use_bounds) then if (abs(xc) .gt. xcell2) xc = xc - sign(xcell,xc) if (abs(yc) .gt. ycell2) yc = yc - sign(ycell,yc) if (abs(zc) .gt. zcell2) zc = zc - sign(zcell,zc) if (monoclinic) then xc = xc + zc*beta_cos zc = zc * beta_sin else if (triclinic) then xc = xc + yc*gamma_cos + zc*beta_cos yc = yc*gamma_sin + zc*beta_term zc = zc * gamma_term end if end if 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(k) if (prime) fik = fik * cscale(kn) if (use_polymer) then if (r2 .gt. polycut2) fik = fi * pchg(k) 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 increment the overall charge-charge energy components c if (e .ne. 0.0d0) then if (use_group) e = e * fgrp nec = nec + 1 ec = ec + e aec(i) = aec(i) + 0.5d0*e aec(k) = aec(k) + 0.5d0*e if (.not.prime .or. im.ne.km) 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.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,30) 30 format (/,' Individual Charge-Charge', & ' Interactions :', & //,' Type',14x,'Atom Names', & 17x,'Charges',5x,'Distance', & 6x,'Energy',/) end if ikmin = min(i,k) ikmax = max(i,k) if (prime) then write (iout,40) ikmin,name(ikmin),ikmax, & name(ikmax),pchg(i), & pchg(k),r,e 40 format (' Charge',4x,2(i7,'-',a3),8x, & 2f7.2,f11.4,f12.4) else write (iout,50) ikmin,name(ikmin),ikmax, & name(ikmax),pchg(i), & pchg(k),r,e 50 format (' Charge',4x,2(i7,'-',a3),1x, & '(XTAL)',1x,2f7.2,f11.4,f12.4) end if end if end if end if 60 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 20 end if c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################### c ## ## c ## subroutine echarge3c -- neighbor list charge analysis ## c ## ## c ############################################################### c c c "echarge3c" calculates the charge-charge interaction energy c and partitions the energy among the atoms using a pairwise c neighbor list c c subroutine echarge3c use action use analyz use atomid use atoms use bound use charge use chgpot use couple use energi use group use inform use inter use iounit use molcul use neigh use shunt use usage implicit none integer i,j,k integer ii,in,ic,im integer kk,kn,kc,km 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 c c c zero out the charge interaction energy and partitioning c nec = 0 ec = 0.0d0 do i = 1, n aec(i) = 0.0d0 end do if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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 print header information if debug output was requested c header = .true. if (debug .and. nion.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge-Charge Interactions :', & //,' Type',14x,'Atom Names',17x,'Charges', & 5x,'Distance',6x,'Energy',/) end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nion,iion,jion,kion,use, !$OMP& x,y,z,f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15, !$OMP& c1scale,c2scale,c3scale,c4scale,c5scale,use_group,use_bounds, !$OMP& off,off2,cut,cut2,c0,c1,c2,c3,c4,c5,f0,f1,f2,f3,f4,f5,f6,f7, !$OMP% molcule,ebuffer,name,verbose,debug,header,iout) !$OMP& firstprivate(cscale) shared (ec,nec,aec,einter) !$OMP DO reduction(+:ec,nec,aec,einter) schedule(guided) c c compute and partition the charge interaction energy c do ii = 1, nion-1 i = iion(ii) in = jion(i) ic = kion(i) im = molcule(i) xic = x(ic) yic = y(ic) zic = z(ic) xi = x(i) - xic yi = y(i) - yic zi = z(i) - zic fi = f * pchg(i) usei = (use(i) .or. use(ic)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = 1, nelst(i) k = elst(kk,i) kn = jion(k) kc = kion(k) km = molcule(k) 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) 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(k) * 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 increment the overall charge-charge energy components c if (e .ne. 0.0d0) then if (use_group) e = e * fgrp nec = nec + 1 ec = ec + e aec(i) = aec(i) + 0.5d0*e aec(k) = aec(k) + 0.5d0*e if (im .ne. km) 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.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Charge-Charge', & ' Interactions :', & //,' Type',14x,'Atom Names', & 17x,'Charges',5x,'Distance', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & pchg(i),pchg(k),r,e 30 format (' Charge',4x,2(i7,'-',a3),8x, & 2f7.2,f11.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (cscale) return end c c c ################################################################ c ## ## c ## subroutine echarge3d -- Ewald charge analysis via loop ## c ## ## c ################################################################ c c c "echarge3d" calculates the charge-charge interaction energy c and partitions the energy among the atoms using a particle c mesh Ewald summation c c subroutine echarge3d use action use analyz use atomid use atoms use bound use boxes use cell use charge use chgpot use couple use energi use ewald use group use inform use inter use iounit use math use molcul use pme use shunt use usage implicit none integer i,j,k integer ii,in,im integer kk,kn,km real*8 e,efull real*8 f,fi,fik real*8 fs,fgrp real*8 r,r2,rb,rew real*8 xi,yi,zi real*8 xr,yr,zr real*8 xd,yd,zd real*8 erfc,erfterm real*8 sum,scale real*8, allocatable :: cscale(:) logical proceed,usei logical header,huge character*6 mode external erfc c c c zero out the Ewald summation energy and partitioning c nec = 0 ec = 0.0d0 do i = 1, n aec(i) = 0.0d0 end do if (nion .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bseorder aewald = aeewald c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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 = 'EWALD' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nion.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge-Charge Interactions :', & //,' Type',14x,'Atom Names',17x,'Charges', & 5x,'Distance',6x,'Energy',/) end if c c compute the Ewald self-energy term over all the atoms c fs = -f * aewald / rootpi do ii = 1, nion i = iion(ii) e = fs * pchg(i)**2 ec = ec + e nec = nec + 1 aec(i) = aec(i) + e end do c c compute the uniform background charge correction term c fs = -0.5d0 * f * pi / (volbox*aewald**2) sum = 0.0d0 do ii = 1, nion i = iion(ii) sum = sum + pchg(i) end do if (sum .ne. 0.0d0) then e = fs * sum**2 ec = ec + e nec = nec + 1 do ii = 1, nion i = iion(ii) aec(i) = aec(i) + e/dble(nion) end do end if c c compute the cell dipole boundary correction term c if (boundary .eq. 'VACUUM') then xd = 0.0d0 yd = 0.0d0 zd = 0.0d0 do ii = 1, nion i = iion(ii) xd = xd + pchg(i)*x(i) yd = yd + pchg(i)*y(i) zd = zd + pchg(i)*z(i) end do e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd) ec = ec + e nec = nec + 1 do ii = 1, nion i = iion(ii) aec(i) = aec(i) + e/dble(nion) end do end if c c compute the reciprocal space part of the Ewald summation c call ecrecip3 c c compute the real space portion of the Ewald summation c do ii = 1, nion-1 i = iion(ii) in = jion(i) im = molcule(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = use(i) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii+1, nion k = iion(kk) kn = jion(k) km = molcule(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) rb = r + ebuffer fik = fi * pchg(k) rew = aewald * r erfterm = erfc (rew) scale = cscale(kn) if (use_group) scale = scale * fgrp e = (fik/rb) * (erfterm+scale-1.0d0) c c increment the overall charge-charge energy components c ec = ec + e efull = (fik/rb) * scale if (efull .ne. 0.0d0) then nec = nec + 1 aec(i) = aec(i) + 0.5d0*efull aec(k) = aec(k) + 0.5d0*efull if (im .ne. km) einter = einter + efull end if c c print a message if the energy of this interaction is large c huge = (abs(efull) .gt. 100.0d0) if ((debug.and.efull.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Real Space Ewald', & ' Charge-Charge Interactions :', & //,' Type',14x,'Atom Names', & 17x,'Charges',5x,'Distance', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & pchg(i),pchg(k),r,efull 30 format (' Charge',4x,2(i7,'-',a3),8x, & 2f7.2,f11.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 real space portion involving other unit cells c do ii = 1, nion i = iion(ii) in = jion(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = use(i) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii, nion k = iion(kk) kn = jion(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) call imager (xr,yr,zr,j) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rb = r + ebuffer fik = fi * pchg(k) rew = aewald * r erfterm = erfc (rew) 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 e = (fik/rb) * (erfterm+scale-1.0d0) if (i .eq. k) e = 0.5d0 * e c c increment the overall charge-charge energy components c ec = ec + e aec(i) = aec(i) + 0.5d0*e aec(k) = aec(k) + 0.5d0*e efull = (fik/rb) * scale if (i .eq. k) efull = 0.5d0 * efull if (efull .ne. 0.0d0) then nec = nec + 1 einter = einter + efull end if c c print a message if the energy of this interaction is large c huge = (abs(efull) .gt. 100.0d0) if ((debug.and.efull.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual Real Space Ewald', & ' Charge-Charge Interactions :', & //,' Type',14x,'Atom Names', & 17x,'Charges',5x,'Distance', & 6x,'Energy',/) end if write (iout,50) i,name(i),k,name(k), & pchg(i),pchg(k),r,efull 50 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 exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 echarge3e -- Ewald charge analysis via lights ## c ## ## c ################################################################## c c c "echarge3e" calculates the charge-charge interaction energy c and partitions the energy among the atoms using a particle c mesh Ewald summation and the method of lights c c subroutine echarge3e use action use analyz use atomid use atoms use bound use boxes use cell use charge use chgpot use couple use energi use ewald use group use inform use inter use iounit use light use math use molcul use pme use shunt use usage implicit none integer i,j,k integer ii,in,ic,im integer kk,kn,km integer kgy,kgz,kmap integer start,stop real*8 e,efull real*8 f,fi,fik real*8 fs,fgrp real*8 r,r2,rb,rew real*8 xi,yi,zi real*8 xr,yr,zr real*8 xd,yd,zd real*8 erfc,erfterm real*8 sum,scale real*8, allocatable :: cscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat logical header,huge character*6 mode external erfc c c c zero out the Ewald summation energy and partitioning c nec = 0 ec = 0.0d0 do i = 1, n aec(i) = 0.0d0 end do if (nion .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bseorder aewald = aeewald c c perform dynamic allocation of some local arrays c allocate (cscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c initialize connected atom exclusion coefficients 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 = 'EWALD' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nion.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge-Charge Interactions :', & //,' Type',14x,'Atom Names',17x,'Charges', & 5x,'Distance',6x,'Energy',/) end if c c compute the Ewald self-energy term over all the atoms c fs = -f * aewald / rootpi do ii = 1, nion i = iion(ii) e = fs * pchg(i)**2 ec = ec + e nec = nec + 1 aec(i) = aec(i) + e end do c c compute the uniform background charge correction term c fs = -0.5d0 * f * pi / (volbox*aewald**2) sum = 0.0d0 do ii = 1, nion i = iion(ii) sum = sum + pchg(i) end do if (sum .ne. 0.0d0) then e = fs * sum**2 ec = ec + e nec = nec + 1 do ii = 1, nion i = iion(ii) aec(i) = aec(i) + e/dble(nion) end do end if c c compute the cell dipole boundary correction term c if (boundary .eq. 'VACUUM') then xd = 0.0d0 yd = 0.0d0 zd = 0.0d0 do ii = 1, nion i = iion(ii) xd = xd + pchg(i)*x(i) yd = yd + pchg(i)*y(i) zd = zd + pchg(i)*z(i) end do e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd) ec = ec + e nec = nec + 1 do ii = 1, nion i = iion(ii) aec(i) = aec(i) + e/dble(nion) end do end if c c compute the reciprocal space part of the Ewald summation c call ecrecip3 c c compute the real space portion of the Ewald summation; c transfer the interaction site coordinates to sorting arrays c do ii = 1, nion i = iion(ii) ic = kion(i) xsort(ii) = x(ic) ysort(ii) = y(ic) zsort(ii) = z(ic) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nion,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nion i = iion(ii) in = jion(i) im = molcule(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) fi = f * pchg(i) usei = use(i) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 20 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 60 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 60 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 60 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 60 end if kmap = kk - ((kk-1)/nion)*nion k = iion(kmap) kn = jion(k) km = molcule(k) prime = (kk .le. nion) c c decide whether to compute the current interaction c if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) c c find energy for interactions within real space cutoff c if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rb = r + ebuffer rew = aewald * r erfterm = erfc (rew) scale = 1.0d0 if (prime) scale = cscale(kn) if (use_group) scale = scale * fgrp fik = fi * pchg(k) if (use_polymer) then if (r2 .gt. polycut2) fik = fi * pchg(k) end if e = (fik/rb) * (erfterm+scale-1.0d0) c c increment the overall charge-charge energy components c ec = ec + e aec(i) = aec(i) + 0.5d0*e aec(k) = aec(k) + 0.5d0*e efull = (fik/rb) * scale if (efull .ne. 0.0d0) then nec = nec + 1 if (.not.prime .or. im.ne.km) & einter = einter + efull end if c c print a message if the energy of this interaction is large c huge = (abs(efull) .gt. 100.0d0) if ((debug.and.efull.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,30) 30 format (/,' Individual Real Space Ewald', & ' Charge-Charge Interactions :', & //,' Type',14x,'Atom Names', & 17x,'Charges',5x,'Distance', & 6x,'Energy',/) end if if (prime) then write (iout,40) i,name(i),k,name(k),pchg(i), & pchg(k),r,efull 40 format (' Charge',4x,2(i7,'-',a3),8x, & 2f7.2,f11.4,f12.4) else write (iout,50) i,name(i),k,name(k),pchg(i), & pchg(k),r,efull 50 format (' Charge',4x,2(i7,'-',a3),1x, & '(XTAL)',1x,2f7.2,f11.4,f12.4) end if end if end if end if 60 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 20 end if c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ################################################################ c ## ## c ## subroutine echarge3f -- Ewald charge analysis via list ## c ## ## c ################################################################ c c c "echarge3f" calculates the charge-charge interaction energy c and partitions the energy among the atoms using a particle c mesh Ewald summation and a pairwise neighbor list c c subroutine echarge3f use action use analyz use atomid use atoms use bound use boxes use charge use chgpot use couple use energi use ewald use group use inform use inter use iounit use math use molcul use neigh use pme use shunt use usage implicit none integer i,j,k integer ii,in,im integer kk,kn,km real*8 e,efull real*8 f,fi,fik real*8 fs,fgrp real*8 r,r2,rb,rew real*8 xi,yi,zi real*8 xr,yr,zr real*8 xd,yd,zd real*8 erfc,erfterm real*8 sum,scale real*8, allocatable :: cscale(:) logical proceed,usei logical header,huge character*6 mode external erfc c c c zero out the Ewald summation energy and partitioning c nec = 0 ec = 0.0d0 do i = 1, n aec(i) = 0.0d0 end do if (nion .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bseorder aewald = aeewald c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients 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 = 'EWALD' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nion.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge-Charge Interactions :', & //,' Type',14x,'Atom Names',17x,'Charges', & 5x,'Distance',6x,'Energy',/) end if c c compute the Ewald self-energy term over all the atoms c fs = -f * aewald / rootpi do ii = 1, nion i = iion(ii) e = fs * pchg(i)**2 ec = ec + e nec = nec + 1 aec(i) = aec(i) + e end do c c compute the uniform background charge correction term c fs = -0.5d0 * f * pi / (volbox*aewald**2) sum = 0.0d0 do ii = 1, nion i = iion(ii) sum = sum + pchg(i) end do if (sum .ne. 0.0d0) then e = fs * sum**2 ec = ec + e nec = nec + 1 do ii = 1, nion i = iion(ii) aec(i) = aec(i) + e/dble(nion) end do end if c c compute the cell dipole boundary correction term c if (boundary .eq. 'VACUUM') then xd = 0.0d0 yd = 0.0d0 zd = 0.0d0 do ii = 1, nion i = iion(ii) xd = xd + pchg(i)*x(i) yd = yd + pchg(i)*y(i) zd = zd + pchg(i)*z(i) end do e = (2.0d0/3.0d0) * f * (pi/volbox) * (xd*xd+yd*yd+zd*zd) ec = ec + e nec = nec + 1 do ii = 1, nion i = iion(ii) aec(i) = aec(i) + e/dble(nion) end do end if c c compute the reciprocal space part of the Ewald summation c call ecrecip3 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nion,iion,jion,use, !$OMP& x,y,z,f,pchg,nelst,elst,n12,n13,n14,n15,i12,i13,i14,i15, !$OMP& c1scale,c2scale,c3scale,c4scale,c5scale,use_group,off2, !$OMP& aewald,molcule,ebuffer,name,verbose,debug,header,iout) !$OMP& firstprivate(cscale) shared (ec,nec,aec,einter) !$OMP DO reduction(+:ec,nec,aec,einter) schedule(guided) c c compute the real space portion of the Ewald summation c do ii = 1, nion i = iion(ii) in = jion(i) im = molcule(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) usei = use(i) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = 1, nelst(i) k = elst(kk,i) kn = jion(k) km = molcule(k) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) proceed = .true. if (proceed) proceed = (usei .or. use(k)) 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) c c find energy for interactions within real space cutoff c call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rb = r + ebuffer fik = fi * pchg(k) rew = aewald * r erfterm = erfc (rew) scale = cscale(kn) if (use_group) scale = scale * fgrp e = (fik/rb) * (erfterm+scale-1.0d0) c c increment the overall charge-charge energy components c ec = ec + e aec(i) = aec(i) + 0.5d0*e aec(k) = aec(k) + 0.5d0*e efull = (fik/rb) * scale if (efull .ne. 0.0d0) then nec = nec + 1 if (im .ne. km) einter = einter + efull end if c c print a message if the energy of this interaction is large c huge = (abs(efull) .gt. 100.0d0) if ((debug.and.efull.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Real Space Ewald', & ' Charge-Charge Interactions :', & //,' Type',14x,'Atom Names', & 17x,'Charges',5x,'Distance', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & pchg(i),pchg(k),r,efull 30 format (' Charge',4x,2(i7,'-',a3),8x, & 2f7.2,f11.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (cscale) return end c c c ############################################################### c ## ## c ## subroutine echarge3g -- charge analysis for smoothing ## c ## ## c ############################################################### c c c "echarge3g" calculates the charge-charge interaction energy c and partitions the energy among the atoms for use with c potential smoothing methods c c subroutine echarge3g use action use analyz use atomid use atoms use charge use chgpot use couple use energi use group use inform use inter use iounit use molcul use usage use warp implicit none integer i,j,k integer ii,in,im integer kk,kn,km real*8 e,fgrp real*8 r,r2,rb,rb2 real*8 f,fi,fik real*8 xi,yi,zi real*8 xr,yr,zr real*8 erf,wterm,width real*8 width2,width3 real*8, allocatable :: cscale(:) logical proceed,usei logical header,huge external erf c c c zero out the charge interaction energy and partitioning c nec = 0 ec = 0.0d0 do i = 1, n aec(i) = 0.0d0 end do if (nion .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (cscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n cscale(i) = 1.0d0 end do c c print header information if debug output was requested c header = .true. if (debug .and. nion.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge-Charge Interactions :', & //,' Type',14x,'Atom Names',17x,'Charges', & 5x,'Distance',6x,'Energy',/) end if c c set the energy units conversion factor c f = electric / dielec 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 compute and partition the charge interaction energy c do ii = 1, nion-1 i = iion(ii) in = jion(i) im = molcule(i) xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(ii) usei = (use(i)) c c set exclusion coefficients for connected atoms c cscale(in) = c1scale 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 c c decide whether to compute the current interaction c do kk = ii+1, nion k = iion(kk) kn = jion(k) km = molcule(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) if (proceed) proceed = (cscale(kn) .ne. 0.0d0) 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 fik = fi * pchg(k) * cscale(kn) e = fik / rb c c transform the potential function via smoothing c if (use_dem) then if (width .gt. 0.0d0) then e = e * erf(width*rb) end if else if (use_gda) then width = m2(i) + m2(k) if (width .gt. 0.0d0) then width = wterm / sqrt(width) e = e * erf(width*rb) end if else if (use_tophat) then if (width .gt. rb) then rb2 = rb * rb e = fik * (3.0d0*width2-rb2) / (2.0d0*width3) end if else if (use_stophat) then e = fik / (rb+width) end if c c increment the overall charge-charge energy components c if (e .ne. 0.0d0) then if (use_group) e = e * fgrp nec = nec + 1 ec = ec + e aec(i) = aec(i) + 0.5d0*e aec(k) = aec(k) + 0.5d0*e if (im .ne. km) 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.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Charge-Charge', & ' Interactions :', & //,' Type',14x,'Atom Names', & 17x,'Charges',5x,'Distance', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k),pchg(i), & pchg(k),r,e 30 format (' Charge',4x,2(i7,'-',a3),8x, & 2f7.2,f11.4,f12.4) end if end if end do c c reset exclusion coefficients for connected atoms c cscale(in) = 1.0d0 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 ecrecip3 -- PME reciprocal charge analysis ## c ## ## c ############################################################### c c c "ecrecip3" evaluates the reciprocal space portion of the c particle mesh Ewald energy due to partial charges, and c partitions the energy among the atoms c c literature reference: c c U. Essmann, L. Perera, M. L Berkowitz, T. Darden, H. Lee and c L. G. Pedersen, "A Smooth Particle Mesh Ewald Method", Journal c of Chemical Physics, 103, 8577-8593 (1995) c c W. Smith and D. Fincham, "The Ewald Sum in Truncated Octahedral c and Rhombic Dodecahedral Boundary Conditions", Molecular c Simulation, 10, 67-71 (1993) c c modifications for nonperiodic systems suggested by Tom Darden c during May 2007 c c subroutine ecrecip3 use analyz use atoms use bound use boxes use charge use chgpot use energi use ewald use math use pme implicit none integer i,j,ii integer k1,k2,k3 integer m1,m2,m3 integer nf1,nf2,nf3 integer nff,ntot real*8 e,f,hsq,denom real*8 term,expterm real*8 pterm,volterm real*8 h1,h2,h3 real*8 r1,r2,r3 real*8, allocatable :: fphi(:,:) c c c return if the Ewald coefficient is zero c if (aewald .lt. 1.0d-6) return f = 0.5d0 * electric / dielec c c perform dynamic allocation of some global arrays c ntot = nfft1 * nfft2 * nfft3 if (allocated(qgrid)) then if (size(qgrid) .ne. 2*ntot) call fftclose end if if (.not. allocated(qgrid)) call fftsetup c c setup spatial decomposition and B-spline coefficients c call getchunk call moduli call bspline_fill call table_fill c c assign PME grid and perform 3-D FFT forward transform c call grid_pchg call fftfront c c use scalar sum to get the reciprocal space energy c pterm = (pi/aewald)**2 volterm = pi * volbox nf1 = (nfft1+1) / 2 nf2 = (nfft2+1) / 2 nf3 = (nfft3+1) / 2 nff = nfft1 * nfft2 ntot = nff * nfft3 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 (nonprism) then if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 end if end if qgrid(1,k1,k2,k3) = expterm * qgrid(1,k1,k2,k3) qgrid(2,k1,k2,k3) = expterm * qgrid(2,k1,k2,k3) end do c c account for zeroth grid point for nonperiodic system c qgrid(1,1,1,1) = 0.0d0 qgrid(2,1,1,1) = 0.0d0 if (.not. use_bounds) then expterm = 0.5d0 * pi / xbox qgrid(1,1,1,1) = expterm * qgrid(1,1,1,1) qgrid(2,1,1,1) = expterm * qgrid(2,1,1,1) end if c c perform the 3-D FFT backward transformation c call fftback c c perform dynamic allocation of some local arrays c allocate (fphi(4,n)) c c extract the partial charge electrostatic potential c call fphi_pchg (fphi) c c sum over charges and increment total charge energy c e = 0.0d0 do ii = 1, nion i = iion(ii) term = f * pchg(i) * fphi(1,i) e = e + term aec(i) = aec(i) + term end do ec = ec + e c c perform deallocation of some local arrays c deallocate (fphi) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine echgdpl -- charge-dipole potential energy ## c ## ## c ############################################################## c c c "echgdpl" calculates the charge-dipole interaction energy c c subroutine echgdpl use atoms use bound use cell use charge use chgpot use couple use dipole use energi use group use shunt use units use usage implicit none integer i,j,k integer ii,k1,k2 integer, allocatable :: skip(:) real*8 e,rk2,rkr3,dotk real*8 taper,fgrp real*8 f,fi,fik real*8 xi,yi,zi real*8 xk,yk,zk real*8 xr,yr,zr real*8 r,r2,r3,r4,r5 logical proceed character*6 mode c c c zero out the overall charge-dipole interaction energy c ecd = 0.0d0 if (nion.eq.0 .or. ndipole.eq.0) return c c perform dynamic allocation of some local arrays c allocate (skip(n)) c c zero out the list of atoms to be skipped c do i = 1, n skip(i) = 0 end do c c set conversion factor and switching function coefficients c f = electric / (debye * dielec) mode = 'CHGDPL' call switch (mode) c c get the total energy by looping over each charge-dipole pair c do ii = 1, nion i = iion(ii) skip(i) = i do k = 1, n12(i) skip(i12(k,i)) = i end do xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) c c decide whether to compute the current interaction c do k = 1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k1,k2,0,0,0) if (proceed) proceed = (use(i) .or. use(k1) .or. use(k2)) if (proceed) proceed = (skip(k1).ne.i .and. & skip(k2).ne.i) c c compute the energy contribution for this interaction c if (proceed) then xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) xr = x(k1) + xk*sdpl(k) - xi yr = y(k1) + yk*sdpl(k) - yi zr = z(k1) + zk*sdpl(k) - zi call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then fik = fi * bdpl(k) rk2 = xk*xk + yk*yk + zk*zk rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr e = fik * dotk / rkr3 c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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-dipole energy component c ecd = ecd + e end if end if 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) skip(i) = i do k = 1, n12(i) skip(i12(k,i)) = i end do xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) c c decide whether to compute the current interaction c do k = 1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k1,k2,0,0,0) if (proceed) proceed = (use(i) .or. use(k1) .or. use(k2)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) xr = x(k1) + xk*sdpl(k) - xi yr = y(k1) + yk*sdpl(k) - yi zr = z(k1) + zk*sdpl(k) - zi call imager (xr,yr,zr,j) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then fik = fi * bdpl(k) if (use_polymer) then if (r2 .lt. polycut2) then if (skip(k1).eq.i .or. skip(k2).ne.i) & fik = 0.0d0 end if end if rk2 = xk*xk + yk*yk + zk*zk rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr e = fik * dotk / rkr3 c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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-dipole energy component c ecd = ecd + e end if end do end if end do end do c c perform deallocation of some local arrays c deallocate (skip) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine echgdpl1 -- charge-dipole energy & derivs ## c ## ## c ############################################################## c c c "echgdpl1" calculates the charge-dipole interaction energy c and first derivatives with respect to Cartesian coordinates c c subroutine echgdpl1 use atoms use bound use cell use charge use chgpot use couple use deriv use dipole use energi use group use shunt use units use usage use virial implicit none integer i,j,k integer ii,k1,k2 integer, allocatable :: skip(:) real*8 e,r2,rk2,rkr3,dotk real*8 f,fi,fik,fgrp real*8 sk1,sk2 real*8 xi,yi,zi real*8 xk,yk,zk real*8 xr,yr,zr real*8 xr1,yr1,zr1 real*8 xr2,yr2,zr2 real*8 term,term2,term3 real*8 termx,termy,termz real*8 termxk,termyk,termzk real*8 dedxi1,dedyi1,dedzi1 real*8 dedxk1,dedyk1,dedzk1 real*8 dedxk2,dedyk2,dedzk2 real*8 r,r3,r4,r5,taper,dtaper real*8 dtaperx,dtapery,dtaperz real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy logical proceed character*6 mode c c c zero out the overall charge-dipole interaction energy c and set up the constants for the calculation c ecd = 0.0d0 do i = 1, n decd(1,i) = 0.0d0 decd(2,i) = 0.0d0 decd(3,i) = 0.0d0 end do if (nion.eq.0 .or. ndipole.eq.0) return c c perform dynamic allocation of some local arrays c allocate (skip(n)) c c zero out the list of atoms to be skipped c do i = 1, n skip(i) = 0 end do c c set conversion factor and switching function coefficients c f = electric / (debye * dielec) mode = 'CHGDPL' call switch (mode) c c get energy and derivs by looping over each charge-dipole pair c do ii = 1, nion i = iion(ii) skip(i) = i do k = 1, n12(i) skip(i12(k,i)) = i end do xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) c c decide whether to compute the current interaction c do k = 1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k1,k2,0,0,0) if (proceed) proceed = (use(i) .or. use(k1) .or. use(k2)) if (proceed) proceed = (skip(k1).ne.i .and. & skip(k2).ne.i) c c compute the energy contribution for this interaction c if (proceed) then sk1 = 1.0d0 - sdpl(k) sk2 = sdpl(k) xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) xr = x(k1) + xk*sk2 - xi yr = y(k1) + yk*sk2 - yi zr = z(k1) + zk*sk2 - zi call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then fik = fi * bdpl(k) rk2 = xk*xk + yk*yk + zk*zk rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr c c form the energy and master chain rule term for derivatives c e = fik * dotk / rkr3 term = -fik / rkr3 c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp term = term * fgrp end if c c secondary chain rule terms for derivative expressions c term2 = -3.0d0 * dotk / r2 term3 = -dotk / rk2 termx = term * (xk+xr*term2) termy = term * (yk+yr*term2) termz = term * (zk+zr*term2) termxk = -term * (xr+xk*term3) termyk = -term * (yr+yk*term3) termzk = -term * (zr+zk*term3) dedxi1 = termx dedyi1 = termy dedzi1 = termz dedxk1 = -sk1*termx - termxk dedyk1 = -sk1*termy - termyk dedzk1 = -sk1*termz - termzk dedxk2 = -sk2*termx + termxk dedyk2 = -sk2*termy + termyk dedzk2 = -sk2*termz + termzk c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 dtaper = dtaper * e/r dtaperx = xr * dtaper dtapery = yr * dtaper dtaperz = zr * dtaper e = e * taper dedxi1 = dedxi1*taper - dtaperx dedyi1 = dedyi1*taper - dtapery dedzi1 = dedzi1*taper - dtaperz dedxk1 = dedxk1*taper + sk1*dtaperx dedyk1 = dedyk1*taper + sk1*dtapery dedzk1 = dedzk1*taper + sk1*dtaperz dedxk2 = dedxk2*taper + sk2*dtaperx dedyk2 = dedyk2*taper + sk2*dtapery dedzk2 = dedzk2*taper + sk2*dtaperz end if c c increment the overall energy and derivative expressions c ecd = ecd + e decd(1,i) = decd(1,i) + dedxi1 decd(2,i) = decd(2,i) + dedyi1 decd(3,i) = decd(3,i) + dedzi1 decd(1,k1) = decd(1,k1) + dedxk1 decd(2,k1) = decd(2,k1) + dedyk1 decd(3,k1) = decd(3,k1) + dedzk1 decd(1,k2) = decd(1,k2) + dedxk2 decd(2,k2) = decd(2,k2) + dedyk2 decd(3,k2) = decd(3,k2) + dedzk2 c c increment the internal virial tensor components c xr1 = x(k1) - xi yr1 = y(k1) - yi zr1 = z(k1) - zi xr2 = x(k2) - xi yr2 = y(k2) - yi zr2 = z(k2) - zi vxx = xr1*dedxk1 + xr2*dedxk2 vyx = yr1*dedxk1 + yr2*dedxk2 vzx = zr1*dedxk1 + zr2*dedxk2 vyy = yr1*dedyk1 + yr2*dedyk2 vzy = zr1*dedyk1 + zr2*dedyk2 vzz = zr1*dedzk1 + zr2*dedzk2 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 if 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) skip(i) = i do k = 1, n12(i) skip(i12(k,i)) = i end do xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) c c decide whether to compute the current interaction c do k = 1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k1,k2,0,0,0) if (proceed) proceed = (use(i) .or. use(k1) .or. use(k2)) c c compute the energy contribution for this interaction c if (proceed) then sk1 = 1.0d0 - sdpl(k) sk2 = sdpl(k) do j = 2, ncell xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) xr = x(k1) + xk*sk2 - xi yr = y(k1) + yk*sk2 - yi zr = z(k1) + zk*sk2 - zi call imager (xr,yr,zr,j) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then fik = fi * bdpl(k) if (use_polymer) then if (r2 .lt. polycut2) then if (skip(k1).eq.i .or. skip(k2).ne.i) & fik = 0.0d0 end if end if rk2 = xk*xk + yk*yk + zk*zk rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr c c form the energy and master chain rule term for derivatives c e = fik * dotk / rkr3 term = -fik / rkr3 c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp term = term * fgrp end if c c secondary chain rule terms for derivative expressions c term2 = -3.0d0 * dotk / r2 term3 = -dotk / rk2 termx = term * (xk+xr*term2) termy = term * (yk+yr*term2) termz = term * (zk+zr*term2) termxk = -term * (xr+xk*term3) termyk = -term * (yr+yk*term3) termzk = -term * (zr+zk*term3) dedxi1 = termx dedyi1 = termy dedzi1 = termz dedxk1 = -sk1*termx - termxk dedyk1 = -sk1*termy - termyk dedzk1 = -sk1*termz - termzk dedxk2 = -sk2*termx + termxk dedyk2 = -sk2*termy + termyk dedzk2 = -sk2*termz + termzk c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 dtaper = dtaper * e/r dtaperx = xr * dtaper dtapery = yr * dtaper dtaperz = zr * dtaper e = e * taper dedxi1 = dedxi1*taper - dtaperx dedyi1 = dedyi1*taper - dtapery dedzi1 = dedzi1*taper - dtaperz dedxk1 = dedxk1*taper + sk1*dtaperx dedyk1 = dedyk1*taper + sk1*dtapery dedzk1 = dedzk1*taper + sk1*dtaperz dedxk2 = dedxk2*taper + sk2*dtaperx dedyk2 = dedyk2*taper + sk2*dtapery dedzk2 = dedzk2*taper + sk2*dtaperz end if c c increment the overall energy and derivative expressions c ecd = ecd + e decd(1,i) = decd(1,i) + dedxi1 decd(2,i) = decd(2,i) + dedyi1 decd(3,i) = decd(3,i) + dedzi1 decd(1,k1) = decd(1,k1) + dedxk1 decd(2,k1) = decd(2,k1) + dedyk1 decd(3,k1) = decd(3,k1) + dedzk1 decd(1,k2) = decd(1,k2) + dedxk2 decd(2,k2) = decd(2,k2) + dedyk2 decd(3,k2) = decd(3,k2) + dedzk2 end if c c increment the internal virial tensor components c xr1 = x(k1) - xi yr1 = y(k1) - yi zr1 = z(k1) - zi xr2 = x(k2) - xi yr2 = y(k2) - yi zr2 = z(k2) - zi vxx = xr1*dedxk1 + xr2*dedxk2 vyx = yr1*dedxk1 + yr2*dedxk2 vzx = zr1*dedxk1 + zr2*dedxk2 vyy = yr1*dedyk1 + yr2*dedyk2 vzy = zr1*dedyk1 + zr2*dedyk2 vzz = zr1*dedzk1 + zr2*dedzk2 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 do end if end do end do c c perform deallocation of some local arrays c deallocate (skip) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine echgdpl2 -- atomwise charge-dipole Hessian ## c ## ## c ############################################################### c c c "echgdpl2" calculates second derivatives of the c charge-dipole interaction energy for a single atom c c subroutine echgdpl2 (i) use atoms use bound use cell use charge use chgpot use couple use dipole use group use hessn use shunt use units implicit none integer i,k,jcell integer ii,i1,k1,k2 integer, allocatable :: skip(:) integer, allocatable :: omit(:) real*8 f,fi,fk,fik real*8 fgrp,sk1,sk2 real*8 xi,yi,zi,xk,yk,zk real*8 xr,yr,zr,xq,yq,zq real*8 e,r2,rk2,rkr3,dotk real*8 term,term2,part,part2 real*8 termx,termy,termz real*8 termxk,termyk,termzk real*8 xrr2,yrr2,zrr2 real*8 xkrk2,ykrk2,zkrk2 real*8 dotk2,dotkr2,dotkrk2 real*8 factor,factork real*8 dedxi1,dedyi1,dedzi1 real*8 dedxk1,dedyk1,dedzk1 real*8 dedxk2,dedyk2,dedzk2 real*8 dtdxi1,dtdyi1,dtdzi1 real*8 dtdxk1,dtdyk1,dtdzk1 real*8 dtdxk2,dtdyk2,dtdzk2 real*8 dtxdxi1,dtxkdxi1,dtxdxk1 real*8 dtxkdxk1,dtxdxk2,dtxkdxk2 real*8 dtydxi1,dtykdxi1,dtydxk1 real*8 dtykdxk1,dtydxk2,dtykdxk2 real*8 dtzdxi1,dtzkdxi1,dtzdxk1 real*8 dtzkdxk1,dtzdxk2,dtzkdxk2 real*8 dtxdyi1,dtxkdyi1,dtxdyk1 real*8 dtxkdyk1,dtxdyk2,dtxkdyk2 real*8 dtydyi1,dtykdyi1,dtydyk1 real*8 dtykdyk1,dtydyk2,dtykdyk2 real*8 dtzdyi1,dtzkdyi1,dtzdyk1 real*8 dtzkdyk1,dtzdyk2,dtzkdyk2 real*8 dtxdzi1,dtxkdzi1,dtxdzk1 real*8 dtxkdzk1,dtxdzk2,dtxkdzk2 real*8 dtydzi1,dtykdzi1,dtydzk1 real*8 dtykdzk1,dtydzk2,dtykdzk2 real*8 dtzdzi1,dtzkdzi1,dtzdzk1 real*8 dtzkdzk1,dtzdzk2,dtzkdzk2 real*8 r,r3,r4,r5 real*8 taper,dtaper,d2taper real*8 dtaperx,dtapery,dtaperz real*8 d2taperxx,d2taperyy real*8 d2taperzz,d2taperxy real*8 d2taperxz,d2taperyz logical proceed character*6 mode c c c check for the presence of both charges and dipoles c if (ndipole.eq.0 .or. nion.eq.0) return c c perform dynamic allocation of some local arrays c allocate (skip(n)) allocate (omit(n)) c c zero out the lists of atoms to be skipped c do k = 1, n skip(k) = 0 omit(k) = 0 end do c c set conversion factor and switching function coefficients c f = -electric / (debye * dielec) mode = 'CHGDPL' call switch (mode) c c first see if the atom of interest carries a charge c do ii = 1, nion i1 = iion(ii) if (i1 .ne. i) goto 10 skip(i1) = i1 do k = 1, n12(i1) skip(i12(k,i1)) = i1 end do xi = x(i1) yi = y(i1) zi = z(i1) fi = f * pchg(i1) c c decide whether to compute the current interaction c do k = 1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. 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) c c compute the energy contribution for this interaction c if (proceed) then sk1 = 1.0d0 - sdpl(k) sk2 = sdpl(k) xk = x(k1) - x(k2) yk = y(k1) - y(k2) zk = z(k1) - z(k2) xr = xi - x(k1) + xk*sk2 yr = yi - y(k1) + yk*sk2 zr = zi - z(k1) + zk*sk2 call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rk2 = xk*xk + yk*yk + zk*zk rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr fik = -fi * bdpl(k) c c scale the interaction based on its group membership c if (use_group) fik = fik * fgrp c c some abbreviations used in various chain rule terms c xrr2 = xr / r2 yrr2 = yr / r2 zrr2 = zr / r2 xkrk2 = xk / rk2 ykrk2 = yk / rk2 zkrk2 = zk / rk2 dotk2 = 2.0d0 * dotk dotkr2 = dotk / r2 c c form the chain rule terms for first derivatives c term = fik / rkr3 term2 = -3.0d0 * dotk termx = term * (xk+xrr2*term2) termy = term * (yk+yrr2*term2) termz = term * (zk+zrr2*term2) termxk = term * (xr-dotk*xkrk2) termyk = term * (yr-dotk*ykrk2) termzk = term * (zr-dotk*zkrk2) c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then e = fik * dotk / rkr3 dedxi1 = termx dedyi1 = termy dedzi1 = termz dedxk1 = -sk1*termx + termxk dedyk1 = -sk1*termy + termyk dedzk1 = -sk1*termz + termzk dedxk2 = -sk2*termx - termxk dedyk2 = -sk2*termy - termyk dedzk2 = -sk2*termz - termzk r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 dtaper = dtaper / r dtaperx = xr * dtaper dtapery = yr * dtaper dtaperz = zr * dtaper d2taper = e * (d2taper-dtaper) dtaper = e * dtaper d2taperxx = xr*xrr2*d2taper + dtaper d2taperxy = xr*yrr2*d2taper d2taperxz = xr*zrr2*d2taper d2taperyy = yr*yrr2*d2taper + dtaper d2taperyz = yr*zrr2*d2taper d2taperzz = zr*zrr2*d2taper + dtaper term = term * taper termx = termx * taper termy = termy * taper termz = termz * taper termxk = termxk * taper termyk = termyk * taper termzk = termzk * taper end if c c chain rule terms for second derivative components c dtdxi1 = -3.0d0 * xrr2 part = xk - dotk2*xrr2 factor = -3.0d0 * (dotkr2 + xrr2*part) factork = 1.0d0 - xk*xkrk2 dtxdxi1 = dtdxi1*termx + term*factor dtxkdxi1 = dtdxi1*termxk + term*factork factor = -3.0d0 * yrr2 * part factork = -yk * xkrk2 dtydxi1 = dtdxi1*termy + term*factor dtykdxi1 = dtdxi1*termyk + term*factork factor = -3.0d0 * zrr2 * part factork = -zk * xkrk2 dtzdxi1 = dtdxi1*termz + term*factor dtzkdxi1 = dtdxi1*termzk + term*factork dtdyi1 = -3.0d0 * yrr2 part = yk - dotk2*yrr2 factor = -3.0d0 * xrr2 * part factork = -xk * ykrk2 dtxdyi1 = dtdyi1*termx + term*factor dtxkdyi1 = dtdyi1*termxk + term*factork factor = -3.0d0 * (dotkr2 + yrr2*part) factork = 1.0d0 - yk*ykrk2 dtydyi1 = dtdyi1*termy + term*factor dtykdyi1 = dtdyi1*termyk + term*factork factor = -3.0d0 * zrr2 * part factork = -zk * ykrk2 dtzdyi1 = dtdyi1*termz + term*factor dtzkdyi1 = dtdyi1*termzk + term*factork dtdzi1 = -3.0d0 * zrr2 part = zk - dotk2*zrr2 factor = -3.0d0 * xrr2 * part factork = -xk * zkrk2 dtxdzi1 = dtdzi1*termx + term*factor dtxkdzi1 = dtdzi1*termxk + term*factork factor = -3.0d0 * yrr2 * part factork = -yk * zkrk2 dtydzi1 = dtdzi1*termy + term*factor dtykdzi1 = dtdzi1*termyk + term*factork factor = -3.0d0 * (dotkr2 + zrr2*part) factork = 1.0d0 - zk*zkrk2 dtzdzi1 = dtdzi1*termz + term*factor dtzkdzi1 = dtdzi1*termzk + term*factork c c increment diagonal and off-diagonal Hessian elements c hessx(1,i1) = hessx(1,i1) + dtxdxi1 hessx(2,i1) = hessx(2,i1) + dtydxi1 hessx(3,i1) = hessx(3,i1) + dtzdxi1 hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi1 + dtxkdxi1 hessx(2,k1) = hessx(2,k1) - sk1*dtydxi1 + dtykdxi1 hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi1 + dtzkdxi1 hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi1 - dtxkdxi1 hessx(2,k2) = hessx(2,k2) - sk2*dtydxi1 - dtykdxi1 hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi1 - dtzkdxi1 hessy(1,i1) = hessy(1,i1) + dtxdyi1 hessy(2,i1) = hessy(2,i1) + dtydyi1 hessy(3,i1) = hessy(3,i1) + dtzdyi1 hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi1 + dtxkdyi1 hessy(2,k1) = hessy(2,k1) - sk1*dtydyi1 + dtykdyi1 hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi1 + dtzkdyi1 hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi1 - dtxkdyi1 hessy(2,k2) = hessy(2,k2) - sk2*dtydyi1 - dtykdyi1 hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi1 - dtzkdyi1 hessz(1,i1) = hessz(1,i1) + dtxdzi1 hessz(2,i1) = hessz(2,i1) + dtydzi1 hessz(3,i1) = hessz(3,i1) + dtzdzi1 hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi1 + dtxkdzi1 hessz(2,k1) = hessz(2,k1) - sk1*dtydzi1 + dtykdzi1 hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi1 + dtzkdzi1 hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi1 - dtxkdzi1 hessz(2,k2) = hessz(2,k2) - sk2*dtydzi1 - dtykdzi1 hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi1 - dtzkdzi1 c c more energy switching if near the cutoff distance c if (r2 .gt. cut2) then hessx(1,i1) = hessx(1,i1) + dtaperx*dedxi1 & + dtaperx*dedxi1 + d2taperxx hessx(2,i1) = hessx(2,i1) + dtaperx*dedyi1 & + dtapery*dedxi1 + d2taperxy hessx(3,i1) = hessx(3,i1) + dtaperx*dedzi1 & + dtaperz*dedxi1 + d2taperxz hessx(1,k1) = hessx(1,k1) + dtaperx*dedxk1 & - sk1*(dtaperx*dedxi1+d2taperxx) hessx(2,k1) = hessx(2,k1) + dtaperx*dedyk1 & - sk1*(dtapery*dedxi1+d2taperxy) hessx(3,k1) = hessx(3,k1) + dtaperx*dedzk1 & - sk1*(dtaperz*dedxi1+d2taperxz) hessx(1,k2) = hessx(1,k2) + dtaperx*dedxk2 & - sk2*(dtaperx*dedxi1+d2taperxx) hessx(2,k2) = hessx(2,k2) + dtaperx*dedyk2 & - sk2*(dtapery*dedxi1+d2taperxy) hessx(3,k2) = hessx(3,k2) + dtaperx*dedzk2 & - sk2*(dtaperz*dedxi1+d2taperxz) hessy(1,i1) = hessy(1,i1) + dtapery*dedxi1 & + dtaperx*dedyi1 + d2taperxy hessy(2,i1) = hessy(2,i1) + dtapery*dedyi1 & + dtapery*dedyi1 + d2taperyy hessy(3,i1) = hessy(3,i1) + dtapery*dedzi1 & + dtaperz*dedyi1 + d2taperyz hessy(1,k1) = hessy(1,k1) + dtapery*dedxk1 & - sk1*(dtaperx*dedyi1+d2taperxy) hessy(2,k1) = hessy(2,k1) + dtapery*dedyk1 & - sk1*(dtapery*dedyi1+d2taperyy) hessy(3,k1) = hessy(3,k1) + dtapery*dedzk1 & - sk1*(dtaperz*dedyi1+d2taperyz) hessy(1,k2) = hessy(1,k2) + dtapery*dedxk2 & - sk2*(dtaperx*dedyi1+d2taperxy) hessy(2,k2) = hessy(2,k2) + dtapery*dedyk2 & - sk2*(dtapery*dedyi1+d2taperyy) hessy(3,k2) = hessy(3,k2) + dtapery*dedzk2 & - sk2*(dtaperz*dedyi1+d2taperyz) hessz(1,i1) = hessz(1,i1) + dtaperz*dedxi1 & + dtaperx*dedzi1 + d2taperxz hessz(2,i1) = hessz(2,i1) + dtaperz*dedyi1 & + dtapery*dedzi1 + d2taperyz hessz(3,i1) = hessz(3,i1) + dtaperz*dedzi1 & + dtaperz*dedzi1 + d2taperzz hessz(1,k1) = hessz(1,k1) + dtaperz*dedxk1 & - sk1*(dtaperx*dedzi1+d2taperxz) hessz(2,k1) = hessz(2,k1) + dtaperz*dedyk1 & - sk1*(dtapery*dedzi1+d2taperyz) hessz(3,k1) = hessz(3,k1) + dtaperz*dedzk1 & - sk1*(dtaperz*dedzi1+d2taperzz) hessz(1,k2) = hessz(1,k2) + dtaperz*dedxk2 & - sk2*(dtaperx*dedzi1+d2taperxz) hessz(2,k2) = hessz(2,k2) + dtaperz*dedyk2 & - sk2*(dtapery*dedzi1+d2taperyz) hessz(3,k2) = hessz(3,k2) + dtaperz*dedzk2 & - sk2*(dtaperz*dedzi1+d2taperzz) end if end if end if end do 10 continue end do c c see if the atom of interest is part of a dipole c do k = 1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) if (k1.ne.i .and. k2.ne.i) goto 20 do ii = 1, n12(k1) omit(i12(ii,k1)) = k end do do ii = 1, n12(k2) omit(i12(ii,k2)) = k end do sk1 = 1.0d0 - sdpl(k) sk2 = sdpl(k) xk = x(k1) - x(k2) yk = y(k1) - y(k2) zk = z(k1) - z(k2) rk2 = xk*xk + yk*yk + zk*zk xq = x(k1) - xk*sk2 yq = y(k1) - yk*sk2 zq = z(k1) - zk*sk2 fk = -f * bdpl(k) c c decide whether to compute the current interaction c do ii = 1, nion i1 = iion(ii) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,k1,k2,0,0,0) if (proceed) proceed = (omit(i1) .ne. k) c c compute the energy contribution for this interaction c if (proceed) then xr = x(i1) - xq yr = y(i1) - yq zr = z(i1) - zq call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr fik = fk * pchg(i1) c c scale the interaction based on its group membership c if (use_group) fik = fik * fgrp c c some abbreviations used in various chain rule terms c xrr2 = xr / r2 yrr2 = yr / r2 zrr2 = zr / r2 xkrk2 = xk / rk2 ykrk2 = yk / rk2 zkrk2 = zk / rk2 dotk2 = 2.0d0 * dotk dotkr2 = dotk / r2 dotkrk2 = dotk / rk2 c c form the chain rule terms for first derivatives c term = fik / rkr3 term2 = -3.0d0 * dotk termx = term * (xk+xrr2*term2) termy = term * (yk+yrr2*term2) termz = term * (zk+zrr2*term2) termxk = term * (xr-dotk*xkrk2) termyk = term * (yr-dotk*ykrk2) termzk = term * (zr-dotk*zkrk2) c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then e = fik * dotk / rkr3 dedxi1 = termx dedyi1 = termy dedzi1 = termz dedxk1 = -sk1*termx + termxk dedyk1 = -sk1*termy + termyk dedzk1 = -sk1*termz + termzk dedxk2 = -sk2*termx - termxk dedyk2 = -sk2*termy - termyk dedzk2 = -sk2*termz - termzk r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 dtaper = dtaper / r dtaperx = xr * dtaper dtapery = yr * dtaper dtaperz = zr * dtaper d2taper = e * (d2taper-dtaper) dtaper = e * dtaper d2taperxx = xr*xrr2*d2taper + dtaper d2taperxy = xr*yrr2*d2taper d2taperxz = xr*zrr2*d2taper d2taperyy = yr*yrr2*d2taper + dtaper d2taperyz = yr*zrr2*d2taper d2taperzz = zr*zrr2*d2taper + dtaper term = term * taper termx = termx * taper termy = termy * taper termz = termz * taper termxk = termxk * taper termyk = termyk * taper termzk = termzk * taper end if c c chain rule terms for second derivative components c if (k1 .eq. i) then dtdxk1 = 3.0d0*sk1*xrr2 - xkrk2 part = sk1*xk - xr part2 = sk1*dotk2*xrr2 - part factor = 1.0d0 - 3.0d0*xrr2*part2 & + 3.0d0*sk1*dotkr2 factork = -sk1 + dotk2*xkrk2*xkrk2 & + xkrk2*part - dotkrk2 dtxdxk1 = dtdxk1*termx + term*factor dtxkdxk1 = dtdxk1*termxk + term*factork factor = -3.0d0 * yrr2 * part2 factork = dotk2*ykrk2*xkrk2 + ykrk2*part dtydxk1 = dtdxk1*termy + term*factor dtykdxk1 = dtdxk1*termyk + term*factork factor = -3.0d0 * zrr2 * part2 factork = dotk2*zkrk2*xkrk2 + zkrk2*part dtzdxk1 = dtdxk1*termz + term*factor dtzkdxk1 = dtdxk1*termzk + term*factork dtdyk1 = 3.0d0*sk1*yrr2 - ykrk2 part = sk1*yk - yr part2 = sk1*dotk2*yrr2 - part factor = -3.0d0 * xrr2 * part2 factork = dotk2*xkrk2*ykrk2 + xkrk2*part dtxdyk1 = dtdyk1*termx + term*factor dtxkdyk1 = dtdyk1*termxk + term*factork factor = 1.0d0 - 3.0d0*yrr2*part2 & + 3.0d0*sk1*dotkr2 factork = -sk1 + dotk2*ykrk2*ykrk2 & + ykrk2*part - dotkrk2 dtydyk1 = dtdyk1*termy + term*factor dtykdyk1 = dtdyk1*termyk + term*factork factor = -3.0d0 * zrr2 * part2 factork = dotk2*zkrk2*ykrk2 + zkrk2*part dtzdyk1 = dtdyk1*termz + term*factor dtzkdyk1 = dtdyk1*termzk + term*factork dtdzk1 = 3.0d0*sk1*zrr2 - zkrk2 part = sk1*zk - zr part2 = sk1*dotk2*zrr2 - part factor = -3.0d0 * xrr2 * part2 factork = dotk2*xkrk2*zkrk2 + xkrk2*part dtxdzk1 = dtdzk1*termx + term*factor dtxkdzk1 = dtdzk1*termxk + term*factork factor = -3.0d0 * yrr2 * part2 factork = dotk2*ykrk2*zkrk2 + ykrk2*part dtydzk1 = dtdzk1*termy + term*factor dtykdzk1 = dtdzk1*termyk + term*factork factor = 1.0d0 - 3.0d0*zrr2*part2 & + 3.0d0*sk1*dotkr2 factork = -sk1 + dotk2*zkrk2*zkrk2 & + zkrk2*part - dotkrk2 dtzdzk1 = dtdzk1*termz + term*factor dtzkdzk1 = dtdzk1*termzk + term*factork else if (k2 .eq. i) then dtdxk2 = 3.0d0*sk2*xrr2 + xkrk2 part = sk2*xk + xr part2 = sk2*dotk2*xrr2 - part factor = -1.0d0 - 3.0d0*xrr2*part2 & + 3.0d0*sk2*dotkr2 factork = -sk2 - dotk2*xkrk2*xkrk2 & + xkrk2*part + dotkrk2 dtxdxk2 = dtdxk2*termx + term*factor dtxkdxk2 = dtdxk2*termxk + term*factork factor = -3.0d0 * yrr2 * part2 factork = -dotk2*ykrk2*xkrk2 + ykrk2*part dtydxk2 = dtdxk2*termy + term*factor dtykdxk2 = dtdxk2*termyk + term*factork factor = -3.0d0 * zrr2 * part2 factork = -dotk2*zkrk2*xkrk2 + zkrk2*part dtzdxk2 = dtdxk2*termz + term*factor dtzkdxk2 = dtdxk2*termzk + term*factork dtdyk2 = 3.0d0*sk2*yrr2 + ykrk2 part = sk2*yk + yr part2 = sk2*dotk2*yrr2 - part factor = -3.0d0 * xrr2 * part2 factork = -dotk2*xkrk2*ykrk2 + xkrk2*part dtxdyk2 = dtdyk2*termx + term*factor dtxkdyk2 = dtdyk2*termxk + term*factork factor = -1.0d0 - 3.0d0*yrr2*part2 & + 3.0d0*sk2*dotkr2 factork = -sk2 - dotk2*ykrk2*ykrk2 & + ykrk2*part + dotkrk2 dtydyk2 = dtdyk2*termy + term*factor dtykdyk2 = dtdyk2*termyk + term*factork factor = -3.0d0 * zrr2 * part2 factork = -dotk2*zkrk2*ykrk2 + zkrk2*part dtzdyk2 = dtdyk2*termz + term*factor dtzkdyk2 = dtdyk2*termzk + term*factork dtdzk2 = 3.0d0*sk2*zrr2 + zkrk2 part = sk2*zk + zr part2 = sk2*dotk2*zrr2 - part factor = -3.0d0 * xrr2 * part2 factork = -dotk2*xkrk2*zkrk2 + xkrk2*part dtxdzk2 = dtdzk2*termx + term*factor dtxkdzk2 = dtdzk2*termxk + term*factork factor = -3.0d0 * yrr2 * part2 factork = -dotk2*ykrk2*zkrk2 + ykrk2*part dtydzk2 = dtdzk2*termy + term*factor dtykdzk2 = dtdzk2*termyk + term*factork factor = -1.0d0 - 3.0d0*zrr2*part2 & + 3.0d0*sk2*dotkr2 factork = -sk2 - dotk2*zkrk2*zkrk2 & + zkrk2*part + dotkrk2 dtzdzk2 = dtdzk2*termz + term*factor dtzkdzk2 = dtdzk2*termzk + term*factork end if c c increment diagonal and off-diagonal Hessian elements c if (i .eq. k1) then hessx(1,i1) = hessx(1,i1) + dtxdxk1 hessx(2,i1) = hessx(2,i1) + dtydxk1 hessx(3,i1) = hessx(3,i1) + dtzdxk1 hessx(1,k1) = hessx(1,k1) - sk1*dtxdxk1 + dtxkdxk1 hessx(2,k1) = hessx(2,k1) - sk1*dtydxk1 + dtykdxk1 hessx(3,k1) = hessx(3,k1) - sk1*dtzdxk1 + dtzkdxk1 hessx(1,k2) = hessx(1,k2) - sk2*dtxdxk1 - dtxkdxk1 hessx(2,k2) = hessx(2,k2) - sk2*dtydxk1 - dtykdxk1 hessx(3,k2) = hessx(3,k2) - sk2*dtzdxk1 - dtzkdxk1 hessy(1,i1) = hessy(1,i1) + dtxdyk1 hessy(2,i1) = hessy(2,i1) + dtydyk1 hessy(3,i1) = hessy(3,i1) + dtzdyk1 hessy(1,k1) = hessy(1,k1) - sk1*dtxdyk1 + dtxkdyk1 hessy(2,k1) = hessy(2,k1) - sk1*dtydyk1 + dtykdyk1 hessy(3,k1) = hessy(3,k1) - sk1*dtzdyk1 + dtzkdyk1 hessy(1,k2) = hessy(1,k2) - sk2*dtxdyk1 - dtxkdyk1 hessy(2,k2) = hessy(2,k2) - sk2*dtydyk1 - dtykdyk1 hessy(3,k2) = hessy(3,k2) - sk2*dtzdyk1 - dtzkdyk1 hessz(1,i1) = hessz(1,i1) + dtxdzk1 hessz(2,i1) = hessz(2,i1) + dtydzk1 hessz(3,i1) = hessz(3,i1) + dtzdzk1 hessz(1,k1) = hessz(1,k1) - sk1*dtxdzk1 + dtxkdzk1 hessz(2,k1) = hessz(2,k1) - sk1*dtydzk1 + dtykdzk1 hessz(3,k1) = hessz(3,k1) - sk1*dtzdzk1 + dtzkdzk1 hessz(1,k2) = hessz(1,k2) - sk2*dtxdzk1 - dtxkdzk1 hessz(2,k2) = hessz(2,k2) - sk2*dtydzk1 - dtykdzk1 hessz(3,k2) = hessz(3,k2) - sk2*dtzdzk1 - dtzkdzk1 else if (i .eq. k2) then hessx(1,i1) = hessx(1,i1) + dtxdxk2 hessx(2,i1) = hessx(2,i1) + dtydxk2 hessx(3,i1) = hessx(3,i1) + dtzdxk2 hessx(1,k1) = hessx(1,k1) - sk1*dtxdxk2 + dtxkdxk2 hessx(2,k1) = hessx(2,k1) - sk1*dtydxk2 + dtykdxk2 hessx(3,k1) = hessx(3,k1) - sk1*dtzdxk2 + dtzkdxk2 hessx(1,k2) = hessx(1,k2) - sk2*dtxdxk2 - dtxkdxk2 hessx(2,k2) = hessx(2,k2) - sk2*dtydxk2 - dtykdxk2 hessx(3,k2) = hessx(3,k2) - sk2*dtzdxk2 - dtzkdxk2 hessy(1,i1) = hessy(1,i1) + dtxdyk2 hessy(2,i1) = hessy(2,i1) + dtydyk2 hessy(3,i1) = hessy(3,i1) + dtzdyk2 hessy(1,k1) = hessy(1,k1) - sk1*dtxdyk2 + dtxkdyk2 hessy(2,k1) = hessy(2,k1) - sk1*dtydyk2 + dtykdyk2 hessy(3,k1) = hessy(3,k1) - sk1*dtzdyk2 + dtzkdyk2 hessy(1,k2) = hessy(1,k2) - sk2*dtxdyk2 - dtxkdyk2 hessy(2,k2) = hessy(2,k2) - sk2*dtydyk2 - dtykdyk2 hessy(3,k2) = hessy(3,k2) - sk2*dtzdyk2 - dtzkdyk2 hessz(1,i1) = hessz(1,i1) + dtxdzk2 hessz(2,i1) = hessz(2,i1) + dtydzk2 hessz(3,i1) = hessz(3,i1) + dtzdzk2 hessz(1,k1) = hessz(1,k1) - sk1*dtxdzk2 + dtxkdzk2 hessz(2,k1) = hessz(2,k1) - sk1*dtydzk2 + dtykdzk2 hessz(3,k1) = hessz(3,k1) - sk1*dtzdzk2 + dtzkdzk2 hessz(1,k2) = hessz(1,k2) - sk2*dtxdzk2 - dtxkdzk2 hessz(2,k2) = hessz(2,k2) - sk2*dtydzk2 - dtykdzk2 hessz(3,k2) = hessz(3,k2) - sk2*dtzdzk2 - dtzkdzk2 end if c c more energy switching if near the cutoff distance c if (r2.gt.cut2 .and. i.eq.k1) then hessx(1,i1) = hessx(1,i1) - sk1*dtaperx*dedxi1 & + dtaperx*dedxk1 - sk1*d2taperxx hessx(2,i1) = hessx(2,i1) - sk1*dtaperx*dedyi1 & + dtapery*dedxk1 - sk1*d2taperxy hessx(3,i1) = hessx(3,i1) - sk1*dtaperx*dedzi1 & + dtaperz*dedxk1 - sk1*d2taperxz hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxk1 & - sk1*dtaperx*dedxk1 + sk1*sk1*d2taperxx hessx(2,k1) = hessx(2,k1) - sk1*dtaperx*dedyk1 & - sk1*dtapery*dedxk1 + sk1*sk1*d2taperxy hessx(3,k1) = hessx(3,k1) - sk1*dtaperx*dedzk1 & - sk1*dtaperz*dedxk1 + sk1*sk1*d2taperxz hessx(1,k2) = hessx(1,k2) - sk1*dtaperx*dedxk2 & - sk2*dtaperx*dedxk1 + sk1*sk2*d2taperxx hessx(2,k2) = hessx(2,k2) - sk1*dtaperx*dedyk2 & - sk2*dtapery*dedxk1 + sk1*sk2*d2taperxy hessx(3,k2) = hessx(3,k2) - sk1*dtaperx*dedzk2 & - sk2*dtaperz*dedxk1 + sk1*sk2*d2taperxz hessy(1,i1) = hessy(1,i1) - sk1*dtapery*dedxi1 & + dtaperx*dedyk1 - sk1*d2taperxy hessy(2,i1) = hessy(2,i1) - sk1*dtapery*dedyi1 & + dtapery*dedyk1 - sk1*d2taperyy hessy(3,i1) = hessy(3,i1) - sk1*dtapery*dedzi1 & + dtaperz*dedyk1 - sk1*d2taperyz hessy(1,k1) = hessy(1,k1) - sk1*dtapery*dedxk1 & - sk1*dtaperx*dedyk1 + sk1*sk1*d2taperxy hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyk1 & - sk1*dtapery*dedyk1 + sk1*sk1*d2taperyy hessy(3,k1) = hessy(3,k1) - sk1*dtapery*dedzk1 & - sk1*dtaperz*dedyk1 + sk1*sk1*d2taperyz hessy(1,k2) = hessy(1,k2) - sk1*dtapery*dedxk2 & - sk2*dtaperx*dedyk1 + sk1*sk2*d2taperxy hessy(2,k2) = hessy(2,k2) - sk1*dtapery*dedyk2 & - sk2*dtapery*dedyk1 + sk1*sk2*d2taperyy hessy(3,k2) = hessy(3,k2) - sk1*dtapery*dedzk2 & - sk2*dtaperz*dedyk1 + sk1*sk2*d2taperyz hessz(1,i1) = hessz(1,i1) - sk1*dtaperz*dedxi1 & + dtaperx*dedzk1 - sk1*d2taperxz hessz(2,i1) = hessz(2,i1) - sk1*dtaperz*dedyi1 & + dtapery*dedzk1 - sk1*d2taperyz hessz(3,i1) = hessz(3,i1) - sk1*dtaperz*dedzi1 & + dtaperz*dedzk1 - sk1*d2taperzz hessz(1,k1) = hessz(1,k1) - sk1*dtaperz*dedxk1 & - sk1*dtaperx*dedzk1 + sk1*sk1*d2taperxz hessz(2,k1) = hessz(2,k1) - sk1*dtaperz*dedyk1 & - sk1*dtapery*dedzk1 + sk1*sk1*d2taperyz hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzk1 & - sk1*dtaperz*dedzk1 + sk1*sk1*d2taperzz hessz(1,k2) = hessz(1,k2) - sk1*dtaperz*dedxk2 & - sk2*dtaperx*dedzk1 + sk1*sk2*d2taperxz hessz(2,k2) = hessz(2,k2) - sk1*dtaperz*dedyk2 & - sk2*dtapery*dedzk1 + sk1*sk2*d2taperyz hessz(3,k2) = hessz(3,k2) - sk1*dtaperz*dedzk2 & - sk2*dtaperz*dedzk1 + sk1*sk2*d2taperzz else if (r2.gt.cut2 .and. i.eq.k2) then hessx(1,i1) = hessx(1,i1) - sk2*dtaperx*dedxi1 & + dtaperx*dedxk2 - sk2*d2taperxx hessx(2,i1) = hessx(2,i1) - sk2*dtaperx*dedyi1 & + dtapery*dedxk2 - sk2*d2taperxy hessx(3,i1) = hessx(3,i1) - sk2*dtaperx*dedzi1 & + dtaperz*dedxk2 - sk2*d2taperxz hessx(1,k1) = hessx(1,k1) - sk2*dtaperx*dedxk1 & - sk1*dtaperx*dedxk2 + sk1*sk2*d2taperxx hessx(2,k1) = hessx(2,k1) - sk2*dtaperx*dedyk1 & - sk1*dtapery*dedxk2 + sk1*sk2*d2taperxy hessx(3,k1) = hessx(3,k1) - sk2*dtaperx*dedzk1 & - sk1*dtaperz*dedxk2 + sk1*sk2*d2taperxz hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxk2 & - sk2*dtaperx*dedxk2 + sk2*sk2*d2taperxx hessx(2,k2) = hessx(2,k2) - sk2*dtaperx*dedyk2 & - sk2*dtapery*dedxk2 + sk2*sk2*d2taperxy hessx(3,k2) = hessx(3,k2) - sk2*dtaperx*dedzk2 & - sk2*dtaperz*dedxk2 + sk2*sk2*d2taperxz hessy(1,i1) = hessy(1,i1) - sk2*dtapery*dedxi1 & + dtaperx*dedyk2 - sk2*d2taperxy hessy(2,i1) = hessy(2,i1) - sk2*dtapery*dedyi1 & + dtapery*dedyk2 - sk2*d2taperyy hessy(3,i1) = hessy(3,i1) - sk2*dtapery*dedzi1 & + dtaperz*dedyk2 - sk2*d2taperyz hessy(1,k1) = hessy(1,k1) - sk2*dtapery*dedxk1 & - sk1*dtaperx*dedyk2 + sk1*sk2*d2taperxy hessy(2,k1) = hessy(2,k1) - sk2*dtapery*dedyk1 & - sk1*dtapery*dedyk2 + sk1*sk2*d2taperyy hessy(3,k1) = hessy(3,k1) - sk2*dtapery*dedzk1 & - sk1*dtaperz*dedyk2 + sk1*sk2*d2taperyz hessy(1,k2) = hessy(1,k2) - sk2*dtapery*dedxk2 & - sk2*dtaperx*dedyk2 + sk2*sk2*d2taperxy hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyk2 & - sk2*dtapery*dedyk2 + sk2*sk2*d2taperyy hessy(3,k2) = hessy(3,k2) - sk2*dtapery*dedzk2 & - sk2*dtaperz*dedyk2 + sk2*sk2*d2taperyz hessz(1,i1) = hessz(1,i1) - sk2*dtaperz*dedxi1 & + dtaperx*dedzk2 - sk2*d2taperxz hessz(2,i1) = hessz(2,i1) - sk2*dtaperz*dedyi1 & + dtapery*dedzk2 - sk2*d2taperyz hessz(3,i1) = hessz(3,i1) - sk2*dtaperz*dedzi1 & + dtaperz*dedzk2 - sk2*d2taperzz hessz(1,k1) = hessz(1,k1) - sk2*dtaperz*dedxk1 & - sk1*dtaperx*dedzk2 + sk1*sk2*d2taperxz hessz(2,k1) = hessz(2,k1) - sk2*dtaperz*dedyk1 & - sk1*dtapery*dedzk2 + sk1*sk2*d2taperyz hessz(3,k1) = hessz(3,k1) - sk2*dtaperz*dedzk1 & - sk1*dtaperz*dedzk2 + sk1*sk2*d2taperzz hessz(1,k2) = hessz(1,k2) - sk2*dtaperz*dedxk2 & - sk2*dtaperx*dedzk2 + sk2*sk2*d2taperxz hessz(2,k2) = hessz(2,k2) - sk2*dtaperz*dedyk2 & - sk2*dtapery*dedzk2 + sk2*sk2*d2taperyz hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzk2 & - sk2*dtaperz*dedzk2 + sk2*sk2*d2taperzz end if end if end if end do 20 continue 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 i1 = iion(ii) if (i1 .ne. i) goto 30 skip(i1) = i1 do k = 1, n12(i1) skip(i12(k,i1)) = i1 end do xi = x(i1) yi = y(i1) zi = z(i1) fi = f * pchg(i1) c c decide whether to compute the current interaction c do k = 1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,k1,k2,0,0,0) c c compute the energy contribution for this interaction c if (proceed) then sk1 = 1.0d0 - sdpl(k) sk2 = sdpl(k) do jcell = 2, ncell xk = x(k1) - x(k2) yk = y(k1) - y(k2) zk = z(k1) - z(k2) xr = xi - x(k1) + xk*sk2 yr = yi - y(k1) + yk*sk2 zr = zi - z(k1) + zk*sk2 call imager (xr,yr,zr,jcell) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rk2 = xk*xk + yk*yk + zk*zk rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr fik = -fi * bdpl(k) if (use_polymer) then if (r2 .lt. polycut2) then if (skip(k1).eq.i1 .or. skip(k2).ne.i1) & fik = 0.0d0 end if end if c c scale the interaction based on its group membership c if (use_group) fik = fik * fgrp c c some abbreviations used in various chain rule terms c xrr2 = xr / r2 yrr2 = yr / r2 zrr2 = zr / r2 xkrk2 = xk / rk2 ykrk2 = yk / rk2 zkrk2 = zk / rk2 dotk2 = 2.0d0 * dotk dotkr2 = dotk / r2 c c form the chain rule terms for first derivatives c term = fik / rkr3 term2 = -3.0d0 * dotk termx = term * (xk+xrr2*term2) termy = term * (yk+yrr2*term2) termz = term * (zk+zrr2*term2) termxk = term * (xr-dotk*xkrk2) termyk = term * (yr-dotk*ykrk2) termzk = term * (zr-dotk*zkrk2) c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then e = fik * dotk / rkr3 dedxi1 = termx dedyi1 = termy dedzi1 = termz dedxk1 = -sk1*termx + termxk dedyk1 = -sk1*termy + termyk dedzk1 = -sk1*termz + termzk dedxk2 = -sk2*termx - termxk dedyk2 = -sk2*termy - termyk dedzk2 = -sk2*termz - termzk r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 dtaper = dtaper / r dtaperx = xr * dtaper dtapery = yr * dtaper dtaperz = zr * dtaper d2taper = e * (d2taper-dtaper) dtaper = e * dtaper d2taperxx = xr*xrr2*d2taper + dtaper d2taperxy = xr*yrr2*d2taper d2taperxz = xr*zrr2*d2taper d2taperyy = yr*yrr2*d2taper + dtaper d2taperyz = yr*zrr2*d2taper d2taperzz = zr*zrr2*d2taper + dtaper term = term * taper termx = termx * taper termy = termy * taper termz = termz * taper termxk = termxk * taper termyk = termyk * taper termzk = termzk * taper end if c c chain rule terms for second derivative components c dtdxi1 = -3.0d0 * xrr2 part = xk - dotk2*xrr2 factor = -3.0d0 * (dotkr2 + xrr2*part) factork = 1.0d0 - xk*xkrk2 dtxdxi1 = dtdxi1*termx + term*factor dtxkdxi1 = dtdxi1*termxk + term*factork factor = -3.0d0 * yrr2 * part factork = -yk * xkrk2 dtydxi1 = dtdxi1*termy + term*factor dtykdxi1 = dtdxi1*termyk + term*factork factor = -3.0d0 * zrr2 * part factork = -zk * xkrk2 dtzdxi1 = dtdxi1*termz + term*factor dtzkdxi1 = dtdxi1*termzk + term*factork dtdyi1 = -3.0d0 * yrr2 part = yk - dotk2*yrr2 factor = -3.0d0 * xrr2 * part factork = -xk * ykrk2 dtxdyi1 = dtdyi1*termx + term*factor dtxkdyi1 = dtdyi1*termxk + term*factork factor = -3.0d0 * (dotkr2 + yrr2*part) factork = 1.0d0 - yk*ykrk2 dtydyi1 = dtdyi1*termy + term*factor dtykdyi1 = dtdyi1*termyk + term*factork factor = -3.0d0 * zrr2 * part factork = -zk * ykrk2 dtzdyi1 = dtdyi1*termz + term*factor dtzkdyi1 = dtdyi1*termzk + term*factork dtdzi1 = -3.0d0 * zrr2 part = zk - dotk2*zrr2 factor = -3.0d0 * xrr2 * part factork = -xk * zkrk2 dtxdzi1 = dtdzi1*termx + term*factor dtxkdzi1 = dtdzi1*termxk + term*factork factor = -3.0d0 * yrr2 * part factork = -yk * zkrk2 dtydzi1 = dtdzi1*termy + term*factor dtykdzi1 = dtdzi1*termyk + term*factork factor = -3.0d0 * (dotkr2 + zrr2*part) factork = 1.0d0 - zk*zkrk2 dtzdzi1 = dtdzi1*termz + term*factor dtzkdzi1 = dtdzi1*termzk + term*factork c c increment diagonal and off-diagonal Hessian elements c hessx(1,i1) = hessx(1,i1) + dtxdxi1 hessx(2,i1) = hessx(2,i1) + dtydxi1 hessx(3,i1) = hessx(3,i1) + dtzdxi1 hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi1 + dtxkdxi1 hessx(2,k1) = hessx(2,k1) - sk1*dtydxi1 + dtykdxi1 hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi1 + dtzkdxi1 hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi1 - dtxkdxi1 hessx(2,k2) = hessx(2,k2) - sk2*dtydxi1 - dtykdxi1 hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi1 - dtzkdxi1 hessy(1,i1) = hessy(1,i1) + dtxdyi1 hessy(2,i1) = hessy(2,i1) + dtydyi1 hessy(3,i1) = hessy(3,i1) + dtzdyi1 hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi1 + dtxkdyi1 hessy(2,k1) = hessy(2,k1) - sk1*dtydyi1 + dtykdyi1 hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi1 + dtzkdyi1 hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi1 - dtxkdyi1 hessy(2,k2) = hessy(2,k2) - sk2*dtydyi1 - dtykdyi1 hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi1 - dtzkdyi1 hessz(1,i1) = hessz(1,i1) + dtxdzi1 hessz(2,i1) = hessz(2,i1) + dtydzi1 hessz(3,i1) = hessz(3,i1) + dtzdzi1 hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi1 + dtxkdzi1 hessz(2,k1) = hessz(2,k1) - sk1*dtydzi1 + dtykdzi1 hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi1 + dtzkdzi1 hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi1 - dtxkdzi1 hessz(2,k2) = hessz(2,k2) - sk2*dtydzi1 - dtykdzi1 hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi1 - dtzkdzi1 c c more energy switching if near the cutoff distance c if (r2 .gt. cut2) then hessx(1,i1) = hessx(1,i1) + dtaperx*dedxi1 & + dtaperx*dedxi1 + d2taperxx hessx(2,i1) = hessx(2,i1) + dtaperx*dedyi1 & + dtapery*dedxi1 + d2taperxy hessx(3,i1) = hessx(3,i1) + dtaperx*dedzi1 & + dtaperz*dedxi1 + d2taperxz hessx(1,k1) = hessx(1,k1) + dtaperx*dedxk1 & - sk1*(dtaperx*dedxi1+d2taperxx) hessx(2,k1) = hessx(2,k1) + dtaperx*dedyk1 & - sk1*(dtapery*dedxi1+d2taperxy) hessx(3,k1) = hessx(3,k1) + dtaperx*dedzk1 & - sk1*(dtaperz*dedxi1+d2taperxz) hessx(1,k2) = hessx(1,k2) + dtaperx*dedxk2 & - sk2*(dtaperx*dedxi1+d2taperxx) hessx(2,k2) = hessx(2,k2) + dtaperx*dedyk2 & - sk2*(dtapery*dedxi1+d2taperxy) hessx(3,k2) = hessx(3,k2) + dtaperx*dedzk2 & - sk2*(dtaperz*dedxi1+d2taperxz) hessy(1,i1) = hessy(1,i1) + dtapery*dedxi1 & + dtaperx*dedyi1 + d2taperxy hessy(2,i1) = hessy(2,i1) + dtapery*dedyi1 & + dtapery*dedyi1 + d2taperyy hessy(3,i1) = hessy(3,i1) + dtapery*dedzi1 & + dtaperz*dedyi1 + d2taperyz hessy(1,k1) = hessy(1,k1) + dtapery*dedxk1 & - sk1*(dtaperx*dedyi1+d2taperxy) hessy(2,k1) = hessy(2,k1) + dtapery*dedyk1 & - sk1*(dtapery*dedyi1+d2taperyy) hessy(3,k1) = hessy(3,k1) + dtapery*dedzk1 & - sk1*(dtaperz*dedyi1+d2taperyz) hessy(1,k2) = hessy(1,k2) + dtapery*dedxk2 & - sk2*(dtaperx*dedyi1+d2taperxy) hessy(2,k2) = hessy(2,k2) + dtapery*dedyk2 & - sk2*(dtapery*dedyi1+d2taperyy) hessy(3,k2) = hessy(3,k2) + dtapery*dedzk2 & - sk2*(dtaperz*dedyi1+d2taperyz) hessz(1,i1) = hessz(1,i1) + dtaperz*dedxi1 & + dtaperx*dedzi1 + d2taperxz hessz(2,i1) = hessz(2,i1) + dtaperz*dedyi1 & + dtapery*dedzi1 + d2taperyz hessz(3,i1) = hessz(3,i1) + dtaperz*dedzi1 & + dtaperz*dedzi1 + d2taperzz hessz(1,k1) = hessz(1,k1) + dtaperz*dedxk1 & - sk1*(dtaperx*dedzi1+d2taperxz) hessz(2,k1) = hessz(2,k1) + dtaperz*dedyk1 & - sk1*(dtapery*dedzi1+d2taperyz) hessz(3,k1) = hessz(3,k1) + dtaperz*dedzk1 & - sk1*(dtaperz*dedzi1+d2taperzz) hessz(1,k2) = hessz(1,k2) + dtaperz*dedxk2 & - sk2*(dtaperx*dedzi1+d2taperxz) hessz(2,k2) = hessz(2,k2) + dtaperz*dedyk2 & - sk2*(dtapery*dedzi1+d2taperyz) hessz(3,k2) = hessz(3,k2) + dtaperz*dedzk2 & - sk2*(dtaperz*dedzi1+d2taperzz) end if end if end do end if end do 30 continue end do c c see if the atom of interest is part of a dipole c do k = 1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) if (k1.ne.i .and. k2.ne.i) goto 40 do ii = 1, n12(k1) omit(i12(ii,k1)) = k end do do ii = 1, n12(k2) omit(i12(ii,k2)) = k end do sk1 = 1.0d0 - sdpl(k) sk2 = sdpl(k) xk = x(k1) - x(k2) yk = y(k1) - y(k2) zk = z(k1) - z(k2) rk2 = xk*xk + yk*yk + zk*zk xq = x(k1) - xk*sk2 yq = y(k1) - yk*sk2 zq = z(k1) - zk*sk2 fk = -f * bdpl(k) c c decide whether to compute the current interaction c do ii = 1, nion i1 = iion(ii) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,k1,k2,0,0,0) c c compute the energy contribution for this interaction c if (proceed) then do jcell = 2, ncell xr = x(i1) - xq yr = y(i1) - yq zr = z(i1) - zq call imager (xr,yr,zr,jcell) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr fik = fk * pchg(i1) if (use_polymer) then if (r2 .lt. polycut2) then if (omit(i1) .ne. k) fik = 0.0d0 end if end if c c scale the interaction based on its group membership c if (use_group) fik = fik * fgrp c c some abbreviations used in various chain rule terms c xrr2 = xr / r2 yrr2 = yr / r2 zrr2 = zr / r2 xkrk2 = xk / rk2 ykrk2 = yk / rk2 zkrk2 = zk / rk2 dotk2 = 2.0d0 * dotk dotkr2 = dotk / r2 dotkrk2 = dotk / rk2 c c form the chain rule terms for first derivatives c term = fik / rkr3 term2 = -3.0d0 * dotk termx = term * (xk+xrr2*term2) termy = term * (yk+yrr2*term2) termz = term * (zk+zrr2*term2) termxk = term * (xr-dotk*xkrk2) termyk = term * (yr-dotk*ykrk2) termzk = term * (zr-dotk*zkrk2) c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then e = fik * dotk / rkr3 dedxi1 = termx dedyi1 = termy dedzi1 = termz dedxk1 = -sk1*termx + termxk dedyk1 = -sk1*termy + termyk dedzk1 = -sk1*termz + termzk dedxk2 = -sk2*termx - termxk dedyk2 = -sk2*termy - termyk dedzk2 = -sk2*termz - termzk r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 dtaper = dtaper / r dtaperx = xr * dtaper dtapery = yr * dtaper dtaperz = zr * dtaper d2taper = e * (d2taper-dtaper) dtaper = e * dtaper d2taperxx = xr*xrr2*d2taper + dtaper d2taperxy = xr*yrr2*d2taper d2taperxz = xr*zrr2*d2taper d2taperyy = yr*yrr2*d2taper + dtaper d2taperyz = yr*zrr2*d2taper d2taperzz = zr*zrr2*d2taper + dtaper term = term * taper termx = termx * taper termy = termy * taper termz = termz * taper termxk = termxk * taper termyk = termyk * taper termzk = termzk * taper end if c c chain rule terms for second derivative components c if (k1 .eq. i) then dtdxk1 = 3.0d0*sk1*xrr2 - xkrk2 part = sk1*xk - xr part2 = sk1*dotk2*xrr2 - part factor = 1.0d0 - 3.0d0*xrr2*part2 & + 3.0d0*sk1*dotkr2 factork = -sk1 + dotk2*xkrk2*xkrk2 & + xkrk2*part - dotkrk2 dtxdxk1 = dtdxk1*termx + term*factor dtxkdxk1 = dtdxk1*termxk + term*factork factor = -3.0d0 * yrr2 * part2 factork = dotk2*ykrk2*xkrk2 + ykrk2*part dtydxk1 = dtdxk1*termy + term*factor dtykdxk1 = dtdxk1*termyk + term*factork factor = -3.0d0 * zrr2 * part2 factork = dotk2*zkrk2*xkrk2 + zkrk2*part dtzdxk1 = dtdxk1*termz + term*factor dtzkdxk1 = dtdxk1*termzk + term*factork dtdyk1 = 3.0d0*sk1*yrr2 - ykrk2 part = sk1*yk - yr part2 = sk1*dotk2*yrr2 - part factor = -3.0d0 * xrr2 * part2 factork = dotk2*xkrk2*ykrk2 + xkrk2*part dtxdyk1 = dtdyk1*termx + term*factor dtxkdyk1 = dtdyk1*termxk + term*factork factor = 1.0d0 - 3.0d0*yrr2*part2 & + 3.0d0*sk1*dotkr2 factork = -sk1 + dotk2*ykrk2*ykrk2 & + ykrk2*part - dotkrk2 dtydyk1 = dtdyk1*termy + term*factor dtykdyk1 = dtdyk1*termyk + term*factork factor = -3.0d0 * zrr2 * part2 factork = dotk2*zkrk2*ykrk2 + zkrk2*part dtzdyk1 = dtdyk1*termz + term*factor dtzkdyk1 = dtdyk1*termzk + term*factork dtdzk1 = 3.0d0*sk1*zrr2 - zkrk2 part = sk1*zk - zr part2 = sk1*dotk2*zrr2 - part factor = -3.0d0 * xrr2 * part2 factork = dotk2*xkrk2*zkrk2 + xkrk2*part dtxdzk1 = dtdzk1*termx + term*factor dtxkdzk1 = dtdzk1*termxk + term*factork factor = -3.0d0 * yrr2 * part2 factork = dotk2*ykrk2*zkrk2 + ykrk2*part dtydzk1 = dtdzk1*termy + term*factor dtykdzk1 = dtdzk1*termyk + term*factork factor = 1.0d0 - 3.0d0*zrr2*part2 & + 3.0d0*sk1*dotkr2 factork = -sk1 + dotk2*zkrk2*zkrk2 & + zkrk2*part - dotkrk2 dtzdzk1 = dtdzk1*termz + term*factor dtzkdzk1 = dtdzk1*termzk + term*factork else if (k2 .eq. i) then dtdxk2 = 3.0d0*sk2*xrr2 + xkrk2 part = sk2*xk + xr part2 = sk2*dotk2*xrr2 - part factor = -1.0d0 - 3.0d0*xrr2*part2 & + 3.0d0*sk2*dotkr2 factork = -sk2 - dotk2*xkrk2*xkrk2 & + xkrk2*part + dotkrk2 dtxdxk2 = dtdxk2*termx + term*factor dtxkdxk2 = dtdxk2*termxk + term*factork factor = -3.0d0 * yrr2 * part2 factork = -dotk2*ykrk2*xkrk2 + ykrk2*part dtydxk2 = dtdxk2*termy + term*factor dtykdxk2 = dtdxk2*termyk + term*factork factor = -3.0d0 * zrr2 * part2 factork = -dotk2*zkrk2*xkrk2 + zkrk2*part dtzdxk2 = dtdxk2*termz + term*factor dtzkdxk2 = dtdxk2*termzk + term*factork dtdyk2 = 3.0d0*sk2*yrr2 + ykrk2 part = sk2*yk + yr part2 = sk2*dotk2*yrr2 - part factor = -3.0d0 * xrr2 * part2 factork = -dotk2*xkrk2*ykrk2 + xkrk2*part dtxdyk2 = dtdyk2*termx + term*factor dtxkdyk2 = dtdyk2*termxk + term*factork factor = -1.0d0 - 3.0d0*yrr2*part2 & + 3.0d0*sk2*dotkr2 factork = -sk2 - dotk2*ykrk2*ykrk2 & + ykrk2*part + dotkrk2 dtydyk2 = dtdyk2*termy + term*factor dtykdyk2 = dtdyk2*termyk + term*factork factor = -3.0d0 * zrr2 * part2 factork = -dotk2*zkrk2*ykrk2 + zkrk2*part dtzdyk2 = dtdyk2*termz + term*factor dtzkdyk2 = dtdyk2*termzk + term*factork dtdzk2 = 3.0d0*sk2*zrr2 + zkrk2 part = sk2*zk + zr part2 = sk2*dotk2*zrr2 - part factor = -3.0d0 * xrr2 * part2 factork = -dotk2*xkrk2*zkrk2 + xkrk2*part dtxdzk2 = dtdzk2*termx + term*factor dtxkdzk2 = dtdzk2*termxk + term*factork factor = -3.0d0 * yrr2 * part2 factork = -dotk2*ykrk2*zkrk2 + ykrk2*part dtydzk2 = dtdzk2*termy + term*factor dtykdzk2 = dtdzk2*termyk + term*factork factor = -1.0d0 - 3.0d0*zrr2*part2 & + 3.0d0*sk2*dotkr2 factork = -sk2 - dotk2*zkrk2*zkrk2 & + zkrk2*part + dotkrk2 dtzdzk2 = dtdzk2*termz + term*factor dtzkdzk2 = dtdzk2*termzk + term*factork end if c c increment diagonal and off-diagonal Hessian elements c if (i .eq. k1) then hessx(1,i1) = hessx(1,i1) + dtxdxk1 hessx(2,i1) = hessx(2,i1) + dtydxk1 hessx(3,i1) = hessx(3,i1) + dtzdxk1 hessx(1,k1) = hessx(1,k1) - sk1*dtxdxk1 & + dtxkdxk1 hessx(2,k1) = hessx(2,k1) - sk1*dtydxk1 & + dtykdxk1 hessx(3,k1) = hessx(3,k1) - sk1*dtzdxk1 & + dtzkdxk1 hessx(1,k2) = hessx(1,k2) - sk2*dtxdxk1 & - dtxkdxk1 hessx(2,k2) = hessx(2,k2) - sk2*dtydxk1 & - dtykdxk1 hessx(3,k2) = hessx(3,k2) - sk2*dtzdxk1 & - dtzkdxk1 hessy(1,i1) = hessy(1,i1) + dtxdyk1 hessy(2,i1) = hessy(2,i1) + dtydyk1 hessy(3,i1) = hessy(3,i1) + dtzdyk1 hessy(1,k1) = hessy(1,k1) - sk1*dtxdyk1 & + dtxkdyk1 hessy(2,k1) = hessy(2,k1) - sk1*dtydyk1 & + dtykdyk1 hessy(3,k1) = hessy(3,k1) - sk1*dtzdyk1 & + dtzkdyk1 hessy(1,k2) = hessy(1,k2) - sk2*dtxdyk1 & - dtxkdyk1 hessy(2,k2) = hessy(2,k2) - sk2*dtydyk1 & - dtykdyk1 hessy(3,k2) = hessy(3,k2) - sk2*dtzdyk1 & - dtzkdyk1 hessz(1,i1) = hessz(1,i1) + dtxdzk1 hessz(2,i1) = hessz(2,i1) + dtydzk1 hessz(3,i1) = hessz(3,i1) + dtzdzk1 hessz(1,k1) = hessz(1,k1) - sk1*dtxdzk1 & + dtxkdzk1 hessz(2,k1) = hessz(2,k1) - sk1*dtydzk1 & + dtykdzk1 hessz(3,k1) = hessz(3,k1) - sk1*dtzdzk1 & + dtzkdzk1 hessz(1,k2) = hessz(1,k2) - sk2*dtxdzk1 & - dtxkdzk1 hessz(2,k2) = hessz(2,k2) - sk2*dtydzk1 & - dtykdzk1 hessz(3,k2) = hessz(3,k2) - sk2*dtzdzk1 & - dtzkdzk1 else if (i .eq. k2) then hessx(1,i1) = hessx(1,i1) + dtxdxk2 hessx(2,i1) = hessx(2,i1) + dtydxk2 hessx(3,i1) = hessx(3,i1) + dtzdxk2 hessx(1,k1) = hessx(1,k1) - sk1*dtxdxk2 & + dtxkdxk2 hessx(2,k1) = hessx(2,k1) - sk1*dtydxk2 & + dtykdxk2 hessx(3,k1) = hessx(3,k1) - sk1*dtzdxk2 & + dtzkdxk2 hessx(1,k2) = hessx(1,k2) - sk2*dtxdxk2 & - dtxkdxk2 hessx(2,k2) = hessx(2,k2) - sk2*dtydxk2 & - dtykdxk2 hessx(3,k2) = hessx(3,k2) - sk2*dtzdxk2 & - dtzkdxk2 hessy(1,i1) = hessy(1,i1) + dtxdyk2 hessy(2,i1) = hessy(2,i1) + dtydyk2 hessy(3,i1) = hessy(3,i1) + dtzdyk2 hessy(1,k1) = hessy(1,k1) - sk1*dtxdyk2 & + dtxkdyk2 hessy(2,k1) = hessy(2,k1) - sk1*dtydyk2 & + dtykdyk2 hessy(3,k1) = hessy(3,k1) - sk1*dtzdyk2 & + dtzkdyk2 hessy(1,k2) = hessy(1,k2) - sk2*dtxdyk2 & - dtxkdyk2 hessy(2,k2) = hessy(2,k2) - sk2*dtydyk2 & - dtykdyk2 hessy(3,k2) = hessy(3,k2) - sk2*dtzdyk2 & - dtzkdyk2 hessz(1,i1) = hessz(1,i1) + dtxdzk2 hessz(2,i1) = hessz(2,i1) + dtydzk2 hessz(3,i1) = hessz(3,i1) + dtzdzk2 hessz(1,k1) = hessz(1,k1) - sk1*dtxdzk2 & + dtxkdzk2 hessz(2,k1) = hessz(2,k1) - sk1*dtydzk2 & + dtykdzk2 hessz(3,k1) = hessz(3,k1) - sk1*dtzdzk2 & + dtzkdzk2 hessz(1,k2) = hessz(1,k2) - sk2*dtxdzk2 & - dtxkdzk2 hessz(2,k2) = hessz(2,k2) - sk2*dtydzk2 & - dtykdzk2 hessz(3,k2) = hessz(3,k2) - sk2*dtzdzk2 & - dtzkdzk2 end if c c more energy switching if near the cutoff distance c if (r2.gt.cut2 .and. i.eq.k1) then hessx(1,i1) = hessx(1,i1) - sk1*dtaperx*dedxi1 & + dtaperx*dedxk1 - sk1*d2taperxx hessx(2,i1) = hessx(2,i1) - sk1*dtaperx*dedyi1 & + dtapery*dedxk1 - sk1*d2taperxy hessx(3,i1) = hessx(3,i1) - sk1*dtaperx*dedzi1 & + dtaperz*dedxk1 - sk1*d2taperxz hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxk1 & - sk1*dtaperx*dedxk1 + sk1*sk1*d2taperxx hessx(2,k1) = hessx(2,k1) - sk1*dtaperx*dedyk1 & - sk1*dtapery*dedxk1 + sk1*sk1*d2taperxy hessx(3,k1) = hessx(3,k1) - sk1*dtaperx*dedzk1 & - sk1*dtaperz*dedxk1 + sk1*sk1*d2taperxz hessx(1,k2) = hessx(1,k2) - sk1*dtaperx*dedxk2 & - sk2*dtaperx*dedxk1 + sk1*sk2*d2taperxx hessx(2,k2) = hessx(2,k2) - sk1*dtaperx*dedyk2 & - sk2*dtapery*dedxk1 + sk1*sk2*d2taperxy hessx(3,k2) = hessx(3,k2) - sk1*dtaperx*dedzk2 & - sk2*dtaperz*dedxk1 + sk1*sk2*d2taperxz hessy(1,i1) = hessy(1,i1) - sk1*dtapery*dedxi1 & + dtaperx*dedyk1 - sk1*d2taperxy hessy(2,i1) = hessy(2,i1) - sk1*dtapery*dedyi1 & + dtapery*dedyk1 - sk1*d2taperyy hessy(3,i1) = hessy(3,i1) - sk1*dtapery*dedzi1 & + dtaperz*dedyk1 - sk1*d2taperyz hessy(1,k1) = hessy(1,k1) - sk1*dtapery*dedxk1 & - sk1*dtaperx*dedyk1 + sk1*sk1*d2taperxy hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyk1 & - sk1*dtapery*dedyk1 + sk1*sk1*d2taperyy hessy(3,k1) = hessy(3,k1) - sk1*dtapery*dedzk1 & - sk1*dtaperz*dedyk1 + sk1*sk1*d2taperyz hessy(1,k2) = hessy(1,k2) - sk1*dtapery*dedxk2 & - sk2*dtaperx*dedyk1 + sk1*sk2*d2taperxy hessy(2,k2) = hessy(2,k2) - sk1*dtapery*dedyk2 & - sk2*dtapery*dedyk1 + sk1*sk2*d2taperyy hessy(3,k2) = hessy(3,k2) - sk1*dtapery*dedzk2 & - sk2*dtaperz*dedyk1 + sk1*sk2*d2taperyz hessz(1,i1) = hessz(1,i1) - sk1*dtaperz*dedxi1 & + dtaperx*dedzk1 - sk1*d2taperxz hessz(2,i1) = hessz(2,i1) - sk1*dtaperz*dedyi1 & + dtapery*dedzk1 - sk1*d2taperyz hessz(3,i1) = hessz(3,i1) - sk1*dtaperz*dedzi1 & + dtaperz*dedzk1 - sk1*d2taperzz hessz(1,k1) = hessz(1,k1) - sk1*dtaperz*dedxk1 & - sk1*dtaperx*dedzk1 + sk1*sk1*d2taperxz hessz(2,k1) = hessz(2,k1) - sk1*dtaperz*dedyk1 & - sk1*dtapery*dedzk1 + sk1*sk1*d2taperyz hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzk1 & - sk1*dtaperz*dedzk1 + sk1*sk1*d2taperzz hessz(1,k2) = hessz(1,k2) - sk1*dtaperz*dedxk2 & - sk2*dtaperx*dedzk1 + sk1*sk2*d2taperxz hessz(2,k2) = hessz(2,k2) - sk1*dtaperz*dedyk2 & - sk2*dtapery*dedzk1 + sk1*sk2*d2taperyz hessz(3,k2) = hessz(3,k2) - sk1*dtaperz*dedzk2 & - sk2*dtaperz*dedzk1 + sk1*sk2*d2taperzz else if (r2.gt.cut2 .and. i.eq.k2) then hessx(1,i1) = hessx(1,i1) - sk2*dtaperx*dedxi1 & + dtaperx*dedxk2 - sk2*d2taperxx hessx(2,i1) = hessx(2,i1) - sk2*dtaperx*dedyi1 & + dtapery*dedxk2 - sk2*d2taperxy hessx(3,i1) = hessx(3,i1) - sk2*dtaperx*dedzi1 & + dtaperz*dedxk2 - sk2*d2taperxz hessx(1,k1) = hessx(1,k1) - sk2*dtaperx*dedxk1 & - sk1*dtaperx*dedxk2 + sk1*sk2*d2taperxx hessx(2,k1) = hessx(2,k1) - sk2*dtaperx*dedyk1 & - sk1*dtapery*dedxk2 + sk1*sk2*d2taperxy hessx(3,k1) = hessx(3,k1) - sk2*dtaperx*dedzk1 & - sk1*dtaperz*dedxk2 + sk1*sk2*d2taperxz hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxk2 & - sk2*dtaperx*dedxk2 + sk2*sk2*d2taperxx hessx(2,k2) = hessx(2,k2) - sk2*dtaperx*dedyk2 & - sk2*dtapery*dedxk2 + sk2*sk2*d2taperxy hessx(3,k2) = hessx(3,k2) - sk2*dtaperx*dedzk2 & - sk2*dtaperz*dedxk2 + sk2*sk2*d2taperxz hessy(1,i1) = hessy(1,i1) - sk2*dtapery*dedxi1 & + dtaperx*dedyk2 - sk2*d2taperxy hessy(2,i1) = hessy(2,i1) - sk2*dtapery*dedyi1 & + dtapery*dedyk2 - sk2*d2taperyy hessy(3,i1) = hessy(3,i1) - sk2*dtapery*dedzi1 & + dtaperz*dedyk2 - sk2*d2taperyz hessy(1,k1) = hessy(1,k1) - sk2*dtapery*dedxk1 & - sk1*dtaperx*dedyk2 + sk1*sk2*d2taperxy hessy(2,k1) = hessy(2,k1) - sk2*dtapery*dedyk1 & - sk1*dtapery*dedyk2 + sk1*sk2*d2taperyy hessy(3,k1) = hessy(3,k1) - sk2*dtapery*dedzk1 & - sk1*dtaperz*dedyk2 + sk1*sk2*d2taperyz hessy(1,k2) = hessy(1,k2) - sk2*dtapery*dedxk2 & - sk2*dtaperx*dedyk2 + sk2*sk2*d2taperxy hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyk2 & - sk2*dtapery*dedyk2 + sk2*sk2*d2taperyy hessy(3,k2) = hessy(3,k2) - sk2*dtapery*dedzk2 & - sk2*dtaperz*dedyk2 + sk2*sk2*d2taperyz hessz(1,i1) = hessz(1,i1) - sk2*dtaperz*dedxi1 & + dtaperx*dedzk2 - sk2*d2taperxz hessz(2,i1) = hessz(2,i1) - sk2*dtaperz*dedyi1 & + dtapery*dedzk2 - sk2*d2taperyz hessz(3,i1) = hessz(3,i1) - sk2*dtaperz*dedzi1 & + dtaperz*dedzk2 - sk2*d2taperzz hessz(1,k1) = hessz(1,k1) - sk2*dtaperz*dedxk1 & - sk1*dtaperx*dedzk2 + sk1*sk2*d2taperxz hessz(2,k1) = hessz(2,k1) - sk2*dtaperz*dedyk1 & - sk1*dtapery*dedzk2 + sk1*sk2*d2taperyz hessz(3,k1) = hessz(3,k1) - sk2*dtaperz*dedzk1 & - sk1*dtaperz*dedzk2 + sk1*sk2*d2taperzz hessz(1,k2) = hessz(1,k2) - sk2*dtaperz*dedxk2 & - sk2*dtaperx*dedzk2 + sk2*sk2*d2taperxz hessz(2,k2) = hessz(2,k2) - sk2*dtaperz*dedyk2 & - sk2*dtapery*dedzk2 + sk2*sk2*d2taperyz hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzk2 & - sk2*dtaperz*dedzk2 + sk2*sk2*d2taperzz end if end if end do end if end do 40 continue end do c c perform deallocation of some local arrays c deallocate (skip) deallocate (omit) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine echgdpl3 -- charge-dipole energy & analysis ## c ## ## c ################################################################ c c c "echgdpl3" calculates the charge-dipole interaction energy; c also partitions the energy among the atoms c c subroutine echgdpl3 use action use analyz use atomid use atoms use bound use cell use charge use chgpot use couple use dipole use energi use group use inform use inter use iounit use molcul use shunt use units use usage implicit none integer i,j,k integer ii,k1,k2 integer, allocatable :: skip(:) real*8 e,rk2,rkr3,dotk real*8 taper,fgrp real*8 f,fi,fik real*8 xi,yi,zi real*8 xk,yk,zk real*8 xr,yr,zr real*8 r,r2,r3,r4,r5 logical proceed logical header,huge character*6 mode c c c zero out the overall charge-dipole interaction energy c and partitioning; set up constants for the calculation c necd = 0 ecd = 0.0d0 do i = 1, n aecd(i) = 0.0d0 end do if (nion.eq.0 .or. ndipole.eq.0) return c c perform dynamic allocation of some local arrays c allocate (skip(n)) c c zero out the list of atoms to be skipped c do i = 1, n skip(i) = 0 end do c c set conversion factor and switching function coefficients c f = electric / (debye * dielec) mode = 'CHGDPL' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nion.ne.0 .and. ndipole.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge-Dipole Interactions :', & //,' Type',11x,'Charge',10x,'Dipole', & 20x,'Distance',6x,'Energy',/) end if c c get the total energy by looping over each charge-dipole pair c do ii = 1, nion i = iion(ii) skip(i) = i do k = 1, n12(i) skip(i12(k,i)) = i end do xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) c c decide whether to compute the current interaction c do k = 1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k1,k2,0,0,0) if (proceed) proceed = (use(i) .or. use(k1) .or. use(k2)) if (proceed) proceed = (skip(k1).ne.i .and. & skip(k2).ne.i) c c compute the energy contribution for this interaction c if (proceed) then xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) xr = x(k1) + xk*sdpl(k) - xi yr = y(k1) + yk*sdpl(k) - yi zr = z(k1) + zk*sdpl(k) - zi call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then fik = fi * bdpl(k) rk2 = xk*xk + yk*yk + zk*zk rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr e = fik * dotk / rkr3 c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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-dipole energy component c necd = necd + 1 ecd = ecd + e aecd(i) = aecd(i) + 0.5d0*e aecd(k1) = aecd(k1) + 0.25d0*e aecd(k2) = aecd(k2) + 0.25d0*e c c increment the total intermolecular energy c if (molcule(i) .ne. molcule(k1)) then einter = einter + e end if c c print a message if the energy of this interaction is large c huge = (abs(e) .gt. 25.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Charge-Dipole', & ' Interactions :', & //,' Type',11x,'Charge',10x,'Dipole', & 20x,'Distance',6x,'Energy',/) end if write (iout,30) i,name(i),k1,name(k1), & k2,name(k2),sqrt(r2),e 30 format (' Chg-Dpl',3x,3(i7,'-',a3), & 11x,f11.4,f12.4) end if end if end if 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) skip(i) = i do k = 1, n12(i) skip(i12(k,i)) = i end do xi = x(i) yi = y(i) zi = z(i) fi = f * pchg(i) c c decide whether to compute the current interaction c do k = 1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k1,k2,0,0,0) if (proceed) proceed = (use(i) .or. use(k1) .or. use(k2)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) xr = x(k1) + xk*sdpl(k) - xi yr = y(k1) + yk*sdpl(k) - yi zr = z(k1) + zk*sdpl(k) - zi call imager (xr,yr,zr,j) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then fik = fi * bdpl(k) if (use_polymer) then if (r2 .lt. polycut2) then if (skip(k1).eq.i .or. skip(k2).ne.i) & fik = 0.0d0 end if end if rk2 = xk*xk + yk*yk + zk*zk rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr e = fik * dotk / rkr3 c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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-dipole energy component c if (e .ne. 0.0d0) necd = necd + 1 ecd = ecd + e aecd(i) = aecd(i) + 0.5d0*e aecd(k1) = aecd(k1) + 0.25d0*e aecd(k2) = aecd(k2) + 0.25d0*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. 25.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual Charge-Dipole', & ' Interactions :', & //,' Type',11x,'Charge',10x,'Dipole', & 20x,'Distance',6x,'Energy',/) end if write (iout,50) i,name(i),k1,name(k1), & k2,name(k2),sqrt(r2),e 50 format (' Chg-Dpl',3x,3(i7,'-',a3), & 2x,'(XTAL)',3x,f11.4,f12.4) end if end if end do end if end do end do c c perform deallocation of some local arrays c deallocate (skip) return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################ c ## ## c ## subroutine echgtrn -- charge transfer potential energy ## c ## ## c ################################################################ c c c "echgtrn" calculates the charge transfer potential energy c c subroutine echgtrn use limits implicit none c c c choose method for summing over charge transfer interactions c if (use_mlist) then call echgtrn0c else if (use_lights) then call echgtrn0b else call echgtrn0a end if return end c c c ############################################################# c ## ## c ## subroutine echgtrn0a -- double loop charge transfer ## c ## ## c ############################################################# c c c "echgtrn0a" calculates the charge transfer interaction energy c using a double loop c c subroutine echgtrn0a use atoms use bound use chgpot use chgtrn use ctrpot use cell use couple use energi use group use mplpot use mpole use mutant use shunt use usage implicit none integer i,j,k integer ii,kk integer jcell real*8 e,f,fgrp real*8 r,r2,r3 real*8 r4,r5 real*8 xi,yi,zi real*8 xr,yr,zr real*8 chgi,chgk real*8 chgik real*8 alphai,alphak real*8 expi,expk real*8 expik real*8 taper real*8, allocatable :: mscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c zero out the charge transfer energy c ect = 0.0d0 if (nct .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (mscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n mscale(i) = 1.0d0 end do c c set conversion factor, cutoff and switching coefficients c f = electric / dielec mode = 'CHGTRN' call switch (mode) c c calculate the charge transfer energy term c do ii = 1, npole-1 i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi else chgik = sqrt(abs(chgi*chgk)) expik = exp(-0.5d0*(alphai+alphak)*r) e = -chgik * expik end if e = f * e * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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 transfer energy component c ect = ect + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 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 energy with other unit cells c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kk = ii, npole k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then do jcell = 2, ncell xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call imager (xr,yr,zr,jcell) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi else chgik = sqrt(abs(chgi*chgk)) expik = exp(-0.5d0*(alphai+alphak)*r) e = -chgik * expik end if e = f * e * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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 transfer energy component c if (i .eq. k) e = 0.5d0 * e ect = ect + e end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 1.0d0 end do end do end if c c perform deallocation of some local arrays c deallocate (mscale) return end c c c ################################################################## c ## ## c ## subroutine echgtrn0b -- method of lights charge transfer ## c ## ## c ################################################################## c c c "echgtrn0b" calculates the charge transfer interaction energy c using the method of lights c c subroutine echgtrn0b use atoms use bound use boxes use chgpot use chgtrn use cell use couple use ctrpot use energi use group use light use mplpot use mpole use mutant use shunt use usage implicit none integer i,j,k integer ii,kk integer kgy,kgz integer start,stop real*8 e,f,fgrp real*8 r,r2,r3 real*8 r4,r5 real*8 xi,yi,zi real*8 xr,yr,zr real*8 chgi,chgk real*8 chgik real*8 alphai,alphak real*8 expi,expk real*8 expik real*8 taper real*8, allocatable :: mscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei logical unique,repeat logical muti,mutk character*6 mode c c c zero out the charge transfer energy c ect = 0.0d0 if (nct .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (mscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c initialize connected atom exclusion coefficients c do i = 1, n mscale(i) = 1.0d0 end do c c set conversion factor, cutoff and switching coefficients c f = electric / dielec mode = 'CHGTRN' call switch (mode) c c transfer the interaction site coordinates to sorting arrays c do ii = 1, npole i = ipole(ii) xsort(ii) = x(i) ysort(ii) = y(i) zsort(ii) = z(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nct,xsort,ysort,zsort,unique) c c calculate the charge transfer energy term c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if k = ipole(kk-((kk-1)/npole)*npole) mutk = mut(k) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi else chgik = sqrt(abs(chgi*chgk)) expik = exp(-0.5d0*(alphai+alphak)*r) e = -chgik * expik end if e = f * e * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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 transfer energy component c ect = ect + e end if end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (mscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################### c ## ## c ## subroutine echgtrn0c -- neighbor list charge transfer ## c ## ## c ############################################################### c c c "echgtrn0c" calculates the charge transfer interaction energy c using a neighbor list c c subroutine echgtrn0c use atoms use bound use chgpot use chgtrn use couple use ctrpot use energi use group use mplpot use mpole use mutant use neigh use shunt use usage implicit none integer i,j,k integer ii,kk,kkk real*8 e,f,fgrp real*8 r,r2,r3 real*8 r4,r5 real*8 xi,yi,zi real*8 xr,yr,zr real*8 chgi,chgk real*8 chgik real*8 alphai,alphak real*8 expi,expk real*8 expik real*8 taper real*8, allocatable :: mscale(:) logical proceed,usei logical muti,mutk character*6 mode c c zero out the charge transfer energy c ect = 0.0d0 if (nct .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (mscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n mscale(i) = 1.0d0 end do c c set conversion factor, cutoff and switching coefficients c f = electric / dielec mode = 'CHGTRN' call switch (mode) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(npole,ipole,x,y,z,chgct,dmpct,n12,i12,n13,i13, !$OMP& n14,i14,n15,i15,m2scale,m3scale,m4scale,m5scale,nelst, !$OMP& elst,use,use_group,use_intra,use_bounds,ctrntyp,f,cut2, !$OMP& off2,elambda,mut,c0,c1,c2,c3,c4,c5) !$OMP& firstprivate(mscale) shared(ect) !$OMP DO reduction(+:ect) schedule(guided) c c compute the charge transfer energy c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kkk = 1, nelst(ii) kk = elst(kkk,ii) k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi else chgik = sqrt(abs(chgi*chgk)) expik = exp(-0.5d0*(alphai+alphak)*r) e = -chgik * expik end if e = f * e * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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 transfer energy component c ect = ect + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (mscale) return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################ c ## ## c ## subroutine echgtrn1 -- charge transfer energy & derivs ## c ## ## c ################################################################ c c c "echgtrn1" calculates the charge transfer energy and first c derivatives with respect to Cartesian coordinates c c subroutine echgtrn1 use limits implicit none c c c choose method for summing over charge transfer interactions c if (use_mlist) then call echgtrn1b else call echgtrn1a end if return end c c c ################################################################# c ## ## c ## subroutine echgtrn1a -- charge transfer derivs via loop ## c ## ## c ################################################################# c c c "echgtrn1a" calculates the charge transfer interaction energy c and first derivatives using a double loop c c subroutine echgtrn1a use atoms use bound use chgpot use chgtrn use cell use couple use ctrpot use deriv use energi use group use mplpot use mpole use mutant use shunt use usage use virial implicit none integer i,j,k integer ii,kk integer jcell real*8 e,de,f,fgrp real*8 rr1,r,r2 real*8 r3,r4,r5 real*8 xi,yi,zi real*8 xr,yr,zr real*8 chgi,chgk real*8 chgik real*8 alphai,alphak real*8 alphaik real*8 expi,expk real*8 expik real*8 frcx,frcy,frcz real*8 vxx,vyy,vzz real*8 vxy,vxz,vyz real*8 taper,dtaper real*8, allocatable :: mscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c zero out the charge transfer energy and first derivatives c ect = 0.0d0 do i = 1, n dect(1,i) = 0.0d0 dect(2,i) = 0.0d0 dect(3,i) = 0.0d0 end do if (nct .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (mscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n mscale(i) = 1.0d0 end do c c set conversion factor, cutoff and switching coefficients c f = electric / dielec mode = 'CHGTRN' call switch (mode) c c calculate the charge transfer energy and derivatives c do ii = 1, npole-1 i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rr1 = 1.0d0 / r chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi de = chgi*expk*alphak + chgk*expi*alphai else chgik = sqrt(abs(chgi*chgk)) alphaik = 0.5d0 * (alphai+alphak) expik = exp(-alphaik*r) e = -chgik * expik de = -e * alphaik end if e = f * e * mscale(k) de = f * de * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda de = de * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c compute the force components for this interaction c frcx = de * xr * rr1 frcy = de * yr * rr1 frcz = de * zr * rr1 c c increment the total charge transfer energy and derivatives c ect = ect + e dect(1,i) = dect(1,i) - frcx dect(2,i) = dect(2,i) - frcy dect(3,i) = dect(3,i) - frcz dect(1,k) = dect(1,k) + frcx dect(2,k) = dect(2,k) + frcy dect(3,k) = dect(3,k) + frcz c c increment the internal virial tensor components c vxx = xr * frcx vxy = yr * frcx vxz = zr * frcx vyy = yr * frcy vyz = zr * frcy vzz = zr * frcz vir(1,1) = vir(1,1) + vxx vir(2,1) = vir(2,1) + vxy vir(3,1) = vir(3,1) + vxz vir(1,2) = vir(1,2) + vxy vir(2,2) = vir(2,2) + vyy vir(3,2) = vir(3,2) + vyz vir(1,3) = vir(1,3) + vxz vir(2,3) = vir(2,3) + vyz vir(3,3) = vir(3,3) + vzz end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 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 components with other unit cells c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kk = ii, npole k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then do jcell = 2, ncell xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call imager (xr,yr,zr,jcell) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rr1 = 1.0d0 / r chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi de = chgi*expk*alphak + chgk*expi*alphai else chgik = sqrt(abs(chgi*chgk)) alphaik = 0.5d0 * (alphai+alphak) expik = exp(-alphaik*r) e = -chgik * expik de = -e * alphaik end if if (use_group) then e = e * fgrp de = de * fgrp end if e = f * e * mscale(k) de = f * de * mscale(k) if (i .eq. k) then e = 0.5d0 * e de = 0.5d0 * de end if c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda de = de * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c compute the force components for this interaction c frcx = de * xr * rr1 frcy = de * yr * rr1 frcz = de * zr * rr1 c c increment the total charge transfer energy and derivatives c ect = ect + e dect(1,i) = dect(1,i) - frcx dect(2,i) = dect(2,i) - frcy dect(3,i) = dect(3,i) - frcz dect(1,k) = dect(1,k) + frcx dect(2,k) = dect(2,k) + frcy dect(3,k) = dect(3,k) + frcz c c increment the internal virial tensor components c vxx = xr * frcx vxy = yr * frcx vxz = zr * frcx vyy = yr * frcy vyz = zr * frcy vzz = zr * frcz vir(1,1) = vir(1,1) + vxx vir(2,1) = vir(2,1) + vxy vir(3,1) = vir(3,1) + vxz vir(1,2) = vir(1,2) + vxy vir(2,2) = vir(2,2) + vyy vir(3,2) = vir(3,2) + vyz vir(1,3) = vir(1,3) + vxz vir(2,3) = vir(2,3) + vyz vir(3,3) = vir(3,3) + vzz end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 1.0d0 end do end do end if c c perform deallocation of some local arrays c deallocate (mscale) return end c c c ################################################################# c ## ## c ## subroutine echgtrn1b -- charge transfer derivs via list ## c ## ## c ################################################################# c c c "echgtrn1b" calculates the charge transfer energy and first c derivatives using a pairwise neighbor list c c subroutine echgtrn1b use atoms use bound use chgpot use chgtrn use cell use couple use ctrpot use deriv use energi use group use mplpot use mpole use mutant use neigh use shunt use usage use virial implicit none integer i,j,k integer ii,kk,kkk real*8 e,de,f,fgrp real*8 rr1,r,r2 real*8 r3,r4,r5 real*8 xi,yi,zi real*8 xr,yr,zr real*8 chgi,chgk real*8 chgik real*8 alphai,alphak real*8 alphaik real*8 expi,expk real*8 expik real*8 frcx,frcy,frcz real*8 vxx,vyy,vzz real*8 vxy,vxz,vyz real*8 taper,dtaper real*8, allocatable :: mscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c zero out the charge transfer energy and first derivatives c ect = 0.0d0 do i = 1, n dect(1,i) = 0.0d0 dect(2,i) = 0.0d0 dect(3,i) = 0.0d0 end do if (nct .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (mscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n mscale(i) = 1.0d0 end do c c set conversion factor, cutoff and switching coefficients c f = electric / dielec mode = 'CHGTRN' call switch (mode) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(npole,ipole,x,y,z,chgct,dmpct,n12,i12,n13,i13, !$OMP& n14,i14,n15,i15,m2scale,m3scale,m4scale,m5scale,nelst, !$OMP& elst,use,use_group,use_intra,use_bounds,ctrntyp,f,off2, !$OMP& elambda,mut,cut2,c0,c1,c2,c3,c4,c5) !$OMP& firstprivate(mscale) shared(ect,dect,vir) !$OMP DO reduction(+:ect,dect,vir) schedule(guided) c c compute the charge transfer energy and derivatives c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kkk = 1, nelst(ii) kk = elst(kkk,ii) k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rr1 = 1.0d0 / r chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi de = chgi*expk*alphak + chgk*expi*alphai else chgik = sqrt(abs(chgi*chgk)) alphaik = 0.5d0 * (alphai+alphak) expik = exp(-alphaik*r) e = -chgik * expik de = -e * alphaik end if e = f * e * mscale(k) de = f * de * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda de = de * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c compute the force components for this interaction c frcx = de * xr * rr1 frcy = de * yr * rr1 frcz = de * zr * rr1 c c increment the total charge transfer energy and derivatives c ect = ect + e dect(1,i) = dect(1,i) - frcx dect(2,i) = dect(2,i) - frcy dect(3,i) = dect(3,i) - frcz dect(1,k) = dect(1,k) + frcx dect(2,k) = dect(2,k) + frcy dect(3,k) = dect(3,k) + frcz c c increment the internal virial tensor components c vxx = xr * frcx vxy = yr * frcx vxz = zr * frcx vyy = yr * frcy vyz = zr * frcy vzz = zr * frcz vir(1,1) = vir(1,1) + vxx vir(2,1) = vir(2,1) + vxy vir(3,1) = vir(3,1) + vxz vir(1,2) = vir(1,2) + vxy vir(2,2) = vir(2,2) + vyy vir(3,2) = vir(3,2) + vyz vir(1,3) = vir(1,3) + vxz vir(2,3) = vir(2,3) + vyz vir(3,3) = vir(3,3) + vzz end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (mscale) return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################# c ## ## c ## subroutine echgtrn2 -- atomwise charge transfer Hessian ## c ## ## c ################################################################# c c c "echgtrn2" calculates the second derivatives of the charge c transfer energy using a double loop over relevant atom pairs c c subroutine echgtrn2 (iatom) use atoms use bound use cell use chgpot use chgtrn use couple use ctrpot use group use hessn use mplpot use mpole use mutant use shunt use usage implicit none integer i,j,k integer ii,kk,iii integer iatom,jcell integer nlist,list(5) real*8 e,dedr,d2edr2 real*8 term,f,fgrp real*8 termx,termy,termz real*8 rr1,r,r2 real*8 r3,r4,r5 real*8 xi,yi,zi real*8 xr,yr,zr real*8 chgi,chgk real*8 chgik real*8 alphai,alphak real*8 alphaik real*8 alphai2,alphak2 real*8 expi,expk real*8 expik real*8 taper,dtaper real*8 d2taper real*8 d2e(3,3) real*8, allocatable :: mscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c perform dynamic allocation of some local arrays c allocate (mscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n mscale(i) = 1.0d0 end do c c set conversion factor, cutoff and switching coefficients c f = electric / dielec mode = 'CHGTRN' call switch (mode) c c check to see if the atom of interest is a site c nlist = 0 do ii = 1, npole if (ipole(ii) .eq. iatom) then nlist = nlist + 1 list(nlist) = ii goto 10 end if end do return 10 continue c c calculate the charge transfer energy term c do iii = 1, nlist ii = list(iii) i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 alphai2 = alphai * alphai usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kk = 1, npole k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rr1 = 1.0d0 / r chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then alphak2 = alphak * alphak expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi dedr = chgi*expk*alphak + chgk*expi*alphai d2edr2 = -chgi*expk*alphak2 - chgk*expi*alphai2 else chgik = sqrt(abs(chgi*chgk)) alphaik = 0.5d0 * (alphai+alphak) expik = exp(-alphaik*r) e = -chgik * expik dedr = -e * alphaik d2edr2 = -dedr * alphaik end if e = f * e * mscale(k) dedr = f * dedr * mscale(k) d2edr2 = f * d2edr2 * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then dedr = dedr * elambda d2edr2 = d2edr2 * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r3 * r2 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 d2e = e*d2taper + 2.0d0*dedr*dtaper + d2edr2*taper dedr = e*dtaper + dedr*taper end if c c scale the interaction based on its group membership c if (use_group) then dedr = dedr * fgrp d2edr2 = d2edr2 * fgrp end if c c set the chain rule terms for the Hessian elements c if (r2 .eq. 0.0d0) then dedr = 0.0d0 term = 0.0d0 else dedr = dedr / r term = (d2edr2-dedr) / r2 end if termx = term * xr termy = term * yr termz = term * zr d2e(1,1) = termx*xr + dedr d2e(1,2) = termx*yr d2e(1,3) = termx*zr d2e(2,1) = d2e(1,2) d2e(2,2) = termy*yr + dedr d2e(2,3) = termy*zr d2e(3,1) = d2e(1,3) d2e(3,2) = d2e(2,3) d2e(3,3) = termz*zr + dedr c c increment diagonal and non-diagonal Hessian elements c do j = 1, 3 hessx(j,i) = hessx(j,i) + d2e(1,j) hessy(j,i) = hessy(j,i) + d2e(2,j) hessz(j,i) = hessz(j,i) + d2e(3,j) hessx(j,k) = hessx(j,k) - d2e(1,j) hessy(j,k) = hessy(j,k) - d2e(2,j) hessz(j,k) = hessz(j,k) - d2e(3,j) end do end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 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 energy with other unit cells c do iii = 1, nlist ii = list(iii) i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 alphai2 = alphai * alphai usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kk = 1, npole k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then do jcell = 2, ncell xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call imager (xr,yr,zr,jcell) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rr1 = 1.0d0 / r chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then alphak2 = alphak * alphak expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi dedr = chgi*expk*alphak + chgk*expi*alphai d2edr2 = -chgi*expk*alphak2 & - chgk*expi*alphai2 else chgik = sqrt(abs(chgi*chgk)) alphaik = 0.5d0 * (alphai+alphak) expik = exp(-alphaik*r) e = -chgik * expik dedr = -e * alphaik d2edr2 = -dedr * alphaik end if e = f * e * mscale(k) dedr = f * dedr * mscale(k) d2edr2 = f * d2edr2 * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then dedr = dedr * elambda d2edr2 = d2edr2 * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r3 * r2 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 d2e = e*d2taper + 2.0d0*dedr*dtaper & + d2edr2*taper dedr = e*dtaper + dedr*taper end if c c scale the interaction based on its group membership c if (use_group) then dedr = dedr * fgrp d2edr2 = d2edr2 * fgrp end if c c set the chain rule terms for the Hessian elements c if (r2 .eq. 0.0d0) then dedr = 0.0d0 term = 0.0d0 else dedr = dedr / r term = (d2edr2-dedr) / r2 end if termx = term * xr termy = term * yr termz = term * zr d2e(1,1) = termx*xr + dedr d2e(1,2) = termx*yr d2e(1,3) = termx*zr d2e(2,1) = d2e(1,2) d2e(2,2) = termy*yr + dedr d2e(2,3) = termy*zr d2e(3,1) = d2e(1,3) d2e(3,2) = d2e(2,3) d2e(3,3) = termz*zr + dedr c c increment diagonal and non-diagonal Hessian elements c do j = 1, 3 hessx(j,i) = hessx(j,i) + d2e(1,j) hessy(j,i) = hessy(j,i) + d2e(2,j) hessz(j,i) = hessz(j,i) + d2e(3,j) hessx(j,k) = hessx(j,k) - d2e(1,j) hessy(j,k) = hessy(j,k) - d2e(2,j) hessz(j,k) = hessz(j,k) - d2e(3,j) end do end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 1.0d0 end do end do end if c c perform deallocation of some local arrays c deallocate (mscale) return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################## c ## ## c ## subroutine echgtrn3 -- charge transfer energy & analysis ## c ## ## c ################################################################## c c c "echgtrn3" calculates the charge transfer energy; also partitions c the energy among the atoms c c subroutine echgtrn3 use limits implicit none c c c choose method for summing over charge transfer interactions c if (use_mlist) then call echgtrn3c else if (use_lights) then call echgtrn3b else call echgtrn3a end if return end c c c ############################################################# c ## ## c ## subroutine echgtrn3a -- double loop chgtrn analysis ## c ## ## c ############################################################# c c c "echgtrn3a" calculates the charge transfer interaction energy c and also partitions the energy among the atoms using a pairwise c double loop c c subroutine echgtrn3a use action use analyz use atomid use atoms use bound use chgpot use chgtrn use cell use couple use ctrpot use energi use group use inform use inter use iounit use molcul use mplpot use mpole use mutant use shunt use usage implicit none integer i,j,k integer ii,kk integer jcell real*8 e,f,fgrp real*8 r,r2,r3 real*8 r4,r5 real*8 xi,yi,zi real*8 xr,yr,zr real*8 chgi,chgk real*8 chgik real*8 alphai,alphak real*8 expi,expk real*8 expik real*8 taper real*8, allocatable :: mscale(:) logical proceed,usei logical muti,mutk logical header,huge character*6 mode c c c zero out the charge transfer energy and partitioning terms c nect = 0 ect = 0.0d0 do i = 1, n aect(i) = 0.0d0 end do if (nct .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (mscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n mscale(i) = 1.0d0 end do c c set conversion factor, cutoff and switching coefficients c f = electric / dielec mode = 'CHGTRN' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nct.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge Transfer Interactions :', & //,' Type',14x,'Atom Names',15x,'Distance', & 8x,'Energy',/) end if c c calculate the charge transfer energy term c do ii = 1, npole-1 i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi else chgik = sqrt(abs(chgi*chgk)) expik = exp(-0.5d0*(alphai+alphak)*r) e = -chgik * expik end if e = f * e * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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 transfer energy components c if (e .ne. 0.0d0) then nect = nect + 1 ect = ect + e aect(i) = aect(i) + 0.5d0*e aect(k) = aect(k) + 0.5d0*e end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Charge Transfer', & ' Interactions :', & //,' Type',14x,'Atom Names', & 15x,'Distance',8x,'Energy',/) end if write (iout,30) i,name(i),k,name(k),r,e 30 format (' ChgTrn',4x,2(i7,'-',a3), & 9x,f10.4,2x,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 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 energy with other unit cells c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kk = i, npole k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then do jcell = 2, ncell xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call imager (xr,yr,zr,jcell) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi else chgik = sqrt(abs(chgi*chgk)) expik = exp(-0.5d0*(alphai+alphak)*r) e = -chgik * expik end if e = f * e * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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 transfer energy components c if (e .ne. 0.0d0) then nect = nect + 1 if (i .eq. k) then ect = ect + 0.5d0*e aect(i) = aect(i) + 0.5d0*e else ect = ect + e aect(i) = aect(i) + 0.5d0*e aect(k) = aect(k) + 0.5d0*e end if end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual Charge Transfer', & ' Interactions :', & //,' Type',14x,'Atom Names', & 15x,'Distance',8x,'Energy',/) end if write (iout,50) i,name(i),k,name(k),r,e 50 format (' ChgTrn',4x,2(i7,'-',a3),2x, & '(XTAL)',1x,f10.4,2x,f12.4) end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 1.0d0 end do end do end if c c perform deallocation of some local arrays c deallocate (mscale) return end c c c ############################################################### c ## ## c ## subroutine echgtrn3b -- method lights chgtrn analysis ## c ## ## c ############################################################### c c c "echgtrn3b" calculates the charge transfer interaction energy c and also partitions the energy among the atoms using the method c of lights c c subroutine echgtrn3b use action use analyz use atomid use atoms use bound use boxes use chgpot use chgtrn use cell use couple use ctrpot use energi use group use inform use inter use iounit use light use molcul use mplpot use mpole use mutant use shunt use usage implicit none integer i,j,k integer ii,kk integer kgy,kgz integer start,stop real*8 e,f,fgrp real*8 r,r2,r3 real*8 r4,r5 real*8 xi,yi,zi real*8 xr,yr,zr real*8 chgi,chgk real*8 chgik real*8 alphai,alphak real*8 expi,expk real*8 expik real*8 taper real*8, allocatable :: mscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei logical unique,repeat logical muti,mutk logical header,huge character*6 mode c c c zero out the charge transfer energy c nect = 0 ect = 0.0d0 do i = 1, n aect(i) = 0.0d0 end do if (nct .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (mscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c initialize connected atom exclusion coefficients c do i = 1, n mscale(i) = 1.0d0 end do c c set conversion factor, cutoff and switching coefficients c f = electric / dielec mode = 'CHGTRN' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nct.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge Transfer Interactions :', & //,' Type',14x,'Atom Names',15x,'Distance', & 8x,'Energy',/) end if c c transfer the interaction site coordinates to sorting arrays c do ii = 1, npole i = ipole(ii) xsort(ii) = x(i) ysort(ii) = y(i) zsort(ii) = z(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nct,xsort,ysort,zsort,unique) c c calculate the charge transfer energy term c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 20 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 50 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 50 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 50 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 50 end if k = ipole(kk-((kk-1)/npole)*npole) mutk = mut(k) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi else chgik = sqrt(abs(chgi*chgk)) expik = exp(-0.5d0*(alphai+alphak)*r) e = -chgik * expik end if e = f * e * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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 transfer energy components c if (e .ne. 0.0d0) then nect = nect + 1 ect = ect + e aect(i) = aect(i) + 0.5d0*e aect(k) = aect(k) + 0.5d0*e end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,30) 30 format (/,' Individual Charge Transfer', & ' Interactions :', & //,' Type',14x,'Atom Names', & 15x,'Distance',8x,'Energy',/) end if write (iout,40) i,name(i),k,name(k),r,e 40 format (' ChgTrn',4x,2(i7,'-',a3), & 9x,f10.4,2x,f12.4) end if end if end if 50 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 20 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (mscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################### c ## ## c ## subroutine echgtrn3c -- neighbor list chgtrn analysis ## c ## ## c ############################################################### c c c "echgtrn3c" calculates the charge transfer interaction energy c and also partitions the energy among the atoms using a pairwise c neighbor list c c subroutine echgtrn3c use action use analyz use atomid use atoms use bound use chgpot use chgtrn use cell use couple use ctrpot use energi use group use inform use inter use iounit use molcul use mplpot use mpole use mutant use neigh use shunt use usage implicit none integer i,j,k integer ii,kk,kkk real*8 e,f,fgrp real*8 r,r2,r3 real*8 r4,r5 real*8 xi,yi,zi real*8 xr,yr,zr real*8 chgi,chgk real*8 chgik real*8 alphai,alphak real*8 expi,expk real*8 expik real*8 taper real*8, allocatable :: mscale(:) logical proceed,usei logical muti,mutk logical header,huge character*6 mode c c zero out the charge transfer energy and partitioning terms c nect = 0 ect = 0.0d0 do i = 1, n aect(i) = 0.0d0 end do if (nct .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (mscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n mscale(i) = 1.0d0 end do c c set conversion factor, cutoff and switching coefficients c f = electric / dielec mode = 'CHGTRN' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nct.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Charge Transfer Interactions :', & //,' Type',14x,'Atom Names',15x,'Distance', & 8x,'Energy',/) end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(npole,ipole,x,y,z,chgct,dmpct,n12,i12,n13,i13, !$OMP& n14,i14,n15,i15,m2scale,m3scale,m4scale,m5scale,nelst, !$OMP& elst,use,use_group,use_intra,use_bounds,ctrntyp,f,off2, !$OMP& elambda,mut,cut2,molcule,c0,c1,c2,c3,c4,c5,name,verbose, !$OMP& debug,header,iout) !$OMP& firstprivate(mscale) shared(ect,nect,aect,einter) !$OMP DO reduction(+:ect,nect,aect,einter) schedule(guided) c c compute the charge transfer energy c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) chgi = chgct(i) alphai = dmpct(i) if (alphai .eq. 0.0d0) alphai = 1000.0d0 usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = m2scale end do do j = 1, n13(i) mscale(i13(j,i)) = m3scale end do do j = 1, n14(i) mscale(i14(j,i)) = m4scale end do do j = 1, n15(i) mscale(i15(j,i)) = m5scale end do c c evaluate all sites within the cutoff distance c do kkk = 1, nelst(ii) kk = elst(kkk,ii) k = ipole(kk) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (.not. use_intra) proceed = .true. if (proceed) proceed = (usei .or. use(k)) if (proceed) then xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) chgk = chgct(k) alphak = dmpct(k) if (alphak .eq. 0.0d0) alphak = 1000.0d0 if (ctrntyp .eq. 'SEPARATE') then expi = exp(-alphai*r) expk = exp(-alphak*r) e = -chgi*expk - chgk*expi else chgik = sqrt(abs(chgi*chgk)) expik = exp(-0.5d0*(alphai+alphak)*r) e = -chgik * expik end if e = f * e * mscale(k) c c apply lambda scaling for interaction annihilation c if (muti .or. mutk) then e = e * elambda end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper 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 transfer energy components c if (e .ne. 0.0d0) then nect = nect + 1 ect = ect + e aect(i) = aect(i) + 0.5d0*e aect(k) = aect(k) + 0.5d0*e end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Charge Transfer', & ' Interactions :', & //,' Type',14x,'Atom Names', & 15x,'Distance',8x,'Energy',/) end if write (iout,30) i,name(i),k,name(k),r,e 30 format (' ChgTrn',4x,2(i7,'-',a3), & 9x,f10.4,2x,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) mscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) mscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) mscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) mscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (mscale) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine edipole -- dipole-dipole potential energy ## c ## ## c ############################################################## c c c "edipole" calculates the dipole-dipole interaction energy c c subroutine edipole use atoms use bound use cell use chgpot use dipole use energi use group use shunt use units use usage implicit none integer i,j,k integer i1,i2,k1,k2 real*8 xi,yi,zi real*8 xk,yk,zk real*8 xq,yq,zq real*8 xr,yr,zr real*8 f,fi,fik real*8 taper,fgrp real*8 e,ri2,rk2,rirkr3 real*8 doti,dotk,dotp real*8 r,r2,r3,r4,r5 logical proceed character*6 mode c c c zero out the overall dipole interaction energy c and set up the constants for the calculation c ed = 0.0d0 if (ndipole .eq. 0) return c c set conversion factor and switching function coefficients c f = electric / (debye**2 * dielec) mode = 'DIPOLE' call switch (mode) c c calculate the pairwise dipole interaction energy term c do i = 1, ndipole-1 i1 = idpl(1,i) i2 = idpl(2,i) xi = x(i2) - x(i1) yi = y(i2) - y(i1) zi = z(i2) - z(i1) if (use_polymer) call imager (xi,yi,zi,-1) ri2 = xi*xi + yi*yi + zi*zi xq = x(i1) + xi*sdpl(i) yq = y(i1) + yi*sdpl(i) zq = z(i1) + zi*sdpl(i) fi = f * bdpl(i) c c decide whether to compute the current interaction c do k = i+1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,i2,k1,k2,0,0) if (proceed) proceed = (use(i1) .or. use(i2) .or. & use(k1) .or. use(k2)) if (proceed) proceed = (k1.ne.i1 .and. k1.ne.i2 .and. & k2.ne.i1 .and. k2.ne.i2) c c compute the energy contribution for this interaction c if (proceed) then xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) if (use_polymer) call imager (xk,yk,zk,-1) xr = xq - x(k1) - xk*sdpl(k) yr = yq - y(k1) - yk*sdpl(k) zr = zq - z(k1) - zk*sdpl(k) call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rk2 = xk*xk + yk*yk + zk*zk rirkr3 = sqrt(ri2*rk2*r2) * r2 dotp = xi*xk + yi*yk + zi*zk doti = xi*xr + yi*yr + zi*zr dotk = xk*xr + yk*yr + zk*zr fik = fi * bdpl(k) e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3 c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall dipole-dipole energy component c ed = ed + e end if end if 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, ndipole i1 = idpl(1,i) i2 = idpl(2,i) xi = x(i2) - x(i1) yi = y(i2) - y(i1) zi = z(i2) - z(i1) if (use_polymer) call imager (xi,yi,zi,-1) ri2 = xi*xi + yi*yi + zi*zi xq = x(i1) + xi*sdpl(i) yq = y(i1) + yi*sdpl(i) zq = z(i1) + zi*sdpl(i) fi = f * bdpl(i) c c decide whether to compute the current interaction c do k = i, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,i2,k1,k2,0,0) if (proceed) proceed = (use(i1) .or. use(i2) .or. & use(k1) .or. use(k2)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) if (use_polymer) call imager (xk,yk,zk,-1) xr = xq - x(k1) - xk*sdpl(k) yr = yq - y(k1) - yk*sdpl(k) zr = zq - z(k1) - zk*sdpl(k) call imager (xr,yr,zr,j) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rk2 = xk*xk + yk*yk + zk*zk rirkr3 = sqrt(ri2*rk2*r2) * r2 dotp = xi*xk + yi*yk + zi*zk doti = xi*xr + yi*yr + zi*zr dotk = xk*xr + yk*yr + zk*zr fik = fi * bdpl(k) if (use_polymer) then if (r2 .lt. polycut2) then if (k1.eq.i1 .or. k1.eq.i2 .or. & k2.eq.i1 .or. k2.eq.i2) fik = 0.0d0 end if end if e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3 c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall dipole-dipole energy component c if (i .eq. k) e = 0.5d0 * e ed = ed + e end if end do end if end do end do return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine edipole1 -- dipole-dipole energy & derivs ## c ## ## c ############################################################## c c c "edipole1" calculates the dipole-dipole interaction energy c and first derivatives with respect to Cartesian coordinates c c subroutine edipole1 use atoms use bound use cell use chgpot use deriv use dipole use energi use group use shunt use units use usage use virial implicit none integer i,j,k integer i1,i2,k1,k2 real*8 xi,yi,zi real*8 xk,yk,zk real*8 xq,yq,zq real*8 xr,yr,zr real*8 xq1,yq1,zq1 real*8 xq2,yq2,zq2 real*8 f,fi,fik,fgrp real*8 e,r2,ri2,rk2,rirkr3 real*8 doti,dotk,dotp real*8 si1,si2,sk1,sk2 real*8 de,dedr,dedrirk real*8 deddoti,deddotk,deddotp real*8 termx,termy,termz real*8 dedrirkri2,dedrirkrk2 real*8 termxi,termyi,termzi real*8 termxk,termyk,termzk real*8 dedxi1,dedyi1,dedzi1 real*8 dedxi2,dedyi2,dedzi2 real*8 dedxk1,dedyk1,dedzk1 real*8 dedxk2,dedyk2,dedzk2 real*8 r,r3,r4,r5,taper,dtaper real*8 dtaperx,dtapery,dtaperz real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy logical proceed character*6 mode c c c zero out the overall dipole interaction energy and derivs, c then set up the constants for the calculation c ed = 0.0d0 do i = 1, n ded(1,i) = 0.0d0 ded(2,i) = 0.0d0 ded(3,i) = 0.0d0 end do if (ndipole .eq. 0) return c c set conversion factor and switching function coefficients c f = electric / (debye**2 * dielec) mode = 'DIPOLE' call switch (mode) c c compute the dipole interaction energy and first derivatives c do i = 1, ndipole-1 i1 = idpl(1,i) i2 = idpl(2,i) si1 = 1.0d0 - sdpl(i) si2 = sdpl(i) xi = x(i2) - x(i1) yi = y(i2) - y(i1) zi = z(i2) - z(i1) if (use_polymer) call imager (xi,yi,zi,-1) ri2 = xi*xi + yi*yi + zi*zi xq = x(i1) + xi*si2 yq = y(i1) + yi*si2 zq = z(i1) + zi*si2 fi = f * bdpl(i) c c decide whether to compute the current interaction c do k = i+1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,i2,k1,k2,0,0) if (proceed) proceed = (use(i1) .or. use(i2) .or. & use(k1) .or. use(k2)) if (proceed) proceed = (k1.ne.i1 .and. k1.ne.i2 .and. & k2.ne.i1 .and. k2.ne.i2) c c compute the energy contribution for this interaction c if (proceed) then sk1 = 1.0d0 - sdpl(k) sk2 = sdpl(k) xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) if (use_polymer) call imager (xk,yk,zk,-1) xr = xq - x(k1) - xk*sk2 yr = yq - y(k1) - yk*sk2 zr = zq - z(k1) - zk*sk2 call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rk2 = xk*xk + yk*yk + zk*zk rirkr3 = sqrt(ri2*rk2*r2) * r2 dotp = xi*xk + yi*yk + zi*zk doti = xi*xr + yi*yr + zi*zr dotk = xk*xr + yk*yr + zk*zr fik = fi * bdpl(k) c c form the energy and master chain rule term for derivatives c e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3 de = -fik / (rirkr3*r2) c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c secondary chain rule terms for derivative expressions c deddotp = -de * r2 deddoti = de * 3.0d0*dotk deddotk = de * 3.0d0*doti dedr = de * (3.0d0*dotp-15.0d0*doti*dotk/r2) dedrirk = -e dedrirkri2 = dedrirk / ri2 dedrirkrk2 = dedrirk / rk2 c c more chain rule terms for derivative expressions c termx = dedr*xr + deddoti*xi + deddotk*xk termy = dedr*yr + deddoti*yi + deddotk*yk termz = dedr*zr + deddoti*zi + deddotk*zk termxi = dedrirkri2*xi + deddotp*xk + deddoti*xr termyi = dedrirkri2*yi + deddotp*yk + deddoti*yr termzi = dedrirkri2*zi + deddotp*zk + deddoti*zr termxk = dedrirkrk2*xk + deddotp*xi + deddotk*xr termyk = dedrirkrk2*yk + deddotp*yi + deddotk*yr termzk = dedrirkrk2*zk + deddotp*zi + deddotk*zr c c finally, the individual first derivative components c dedxi1 = si1*termx - termxi dedyi1 = si1*termy - termyi dedzi1 = si1*termz - termzi dedxi2 = si2*termx + termxi dedyi2 = si2*termy + termyi dedzi2 = si2*termz + termzi dedxk1 = -sk1*termx - termxk dedyk1 = -sk1*termy - termyk dedzk1 = -sk1*termz - termzk dedxk2 = -sk2*termx + termxk dedyk2 = -sk2*termy + termyk dedzk2 = -sk2*termz + termzk c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 dtaper = dtaper * e/r dtaperx = xr * dtaper dtapery = yr * dtaper dtaperz = zr * dtaper e = e * taper dedxi1 = dedxi1*taper + si1*dtaperx dedyi1 = dedyi1*taper + si1*dtapery dedzi1 = dedzi1*taper + si1*dtaperz dedxi2 = dedxi2*taper + si2*dtaperx dedyi2 = dedyi2*taper + si2*dtapery dedzi2 = dedzi2*taper + si2*dtaperz dedxk1 = dedxk1*taper - sk1*dtaperx dedyk1 = dedyk1*taper - sk1*dtapery dedzk1 = dedzk1*taper - sk1*dtaperz dedxk2 = dedxk2*taper - sk2*dtaperx dedyk2 = dedyk2*taper - sk2*dtapery dedzk2 = dedzk2*taper - sk2*dtaperz end if c c increment the overall energy and derivative expressions c ed = ed + e ded(1,i1) = ded(1,i1) + dedxi1 ded(2,i1) = ded(2,i1) + dedyi1 ded(3,i1) = ded(3,i1) + dedzi1 ded(1,i2) = ded(1,i2) + dedxi2 ded(2,i2) = ded(2,i2) + dedyi2 ded(3,i2) = ded(3,i2) + dedzi2 ded(1,k1) = ded(1,k1) + dedxk1 ded(2,k1) = ded(2,k1) + dedyk1 ded(3,k1) = ded(3,k1) + dedzk1 ded(1,k2) = ded(1,k2) + dedxk2 ded(2,k2) = ded(2,k2) + dedyk2 ded(3,k2) = ded(3,k2) + dedzk2 c c increment the internal virial tensor components c xq1 = x(k1) - xq yq1 = y(k1) - yq zq1 = z(k1) - zq xq2 = x(k2) - xq yq2 = y(k2) - yq zq2 = z(k2) - zq vxx = xq1*dedxk1 + xq2*dedxk2 vyx = 0.5d0 * (yq1*dedxk1 + yq2*dedxk2 & + xq1*dedyk1 + xq2*dedyk2) vzx = 0.5d0 * (zq1*dedxk1 + zq2*dedxk2 & + xq1*dedzk1 + xq2*dedzk2) vyy = yq1*dedyk1 + yq2*dedyk2 vzy = 0.5d0 * (zq1*dedyk1 + zq2*dedyk2 & + yq1*dedzk1 + yq2*dedzk2) vzz = zq1*dedzk1 + zq2*dedzk2 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 if 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, ndipole i1 = idpl(1,i) i2 = idpl(2,i) si1 = 1.0d0 - sdpl(i) si2 = sdpl(i) xi = x(i2) - x(i1) yi = y(i2) - y(i1) zi = z(i2) - z(i1) if (use_polymer) call imager (xi,yi,zi,-1) ri2 = xi*xi + yi*yi + zi*zi xq = x(i1) + xi*si2 yq = y(i1) + yi*si2 zq = z(i1) + zi*si2 fi = f * bdpl(i) c c decide whether to compute the current interaction c do k = i, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,i2,k1,k2,0,0) if (proceed) proceed = (use(i1) .or. use(i2) .or. & use(k1) .or. use(k2)) c c compute the energy contribution for this interaction c if (proceed) then sk1 = 1.0d0 - sdpl(k) sk2 = sdpl(k) do j = 2, ncell xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) if (use_polymer) call imager (xk,yk,zk,-1) xr = xq - x(k1) - xk*sk2 yr = yq - y(k1) - yk*sk2 zr = zq - z(k1) - zk*sk2 call imager (xr,yr,zr,j) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rk2 = xk*xk + yk*yk + zk*zk rirkr3 = sqrt(ri2*rk2*r2) * r2 dotp = xi*xk + yi*yk + zi*zk doti = xi*xr + yi*yr + zi*zr dotk = xk*xr + yk*yr + zk*zr fik = fi * bdpl(k) if (use_polymer) then if (r2 .lt. polycut2) then if (k1.eq.i1 .or. k1.eq.i2 .or. & k2.eq.i1 .or. k2.eq.i2) fik = 0.0d0 end if end if c c form the energy and master chain rule term for derivatives c e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3 de = -fik / (rirkr3*r2) c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c secondary chain rule terms for derivative expressions c deddotp = -de * r2 deddoti = de * 3.0d0*dotk deddotk = de * 3.0d0*doti dedr = de * (3.0d0*dotp-15.0d0*doti*dotk/r2) dedrirk = -e dedrirkri2 = dedrirk / ri2 dedrirkrk2 = dedrirk / rk2 c c more chain rule terms for derivative expressions c termx = dedr*xr + deddoti*xi + deddotk*xk termy = dedr*yr + deddoti*yi + deddotk*yk termz = dedr*zr + deddoti*zi + deddotk*zk termxi = dedrirkri2*xi + deddotp*xk + deddoti*xr termyi = dedrirkri2*yi + deddotp*yk + deddoti*yr termzi = dedrirkri2*zi + deddotp*zk + deddoti*zr termxk = dedrirkrk2*xk + deddotp*xi + deddotk*xr termyk = dedrirkrk2*yk + deddotp*yi + deddotk*yr termzk = dedrirkrk2*zk + deddotp*zi + deddotk*zr c c finally, the individual first derivative components c dedxi1 = si1*termx - termxi dedyi1 = si1*termy - termyi dedzi1 = si1*termz - termzi dedxi2 = si2*termx + termxi dedyi2 = si2*termy + termyi dedzi2 = si2*termz + termzi dedxk1 = -sk1*termx - termxk dedyk1 = -sk1*termy - termyk dedzk1 = -sk1*termz - termzk dedxk2 = -sk2*termx + termxk dedyk2 = -sk2*termy + termyk dedzk2 = -sk2*termz + termzk c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 dtaper = dtaper * e/r dtaperx = xr * dtaper dtapery = yr * dtaper dtaperz = zr * dtaper e = e * taper dedxi1 = dedxi1*taper + si1*dtaperx dedyi1 = dedyi1*taper + si1*dtapery dedzi1 = dedzi1*taper + si1*dtaperz dedxi2 = dedxi2*taper + si2*dtaperx dedyi2 = dedyi2*taper + si2*dtapery dedzi2 = dedzi2*taper + si2*dtaperz dedxk1 = dedxk1*taper - sk1*dtaperx dedyk1 = dedyk1*taper - sk1*dtapery dedzk1 = dedzk1*taper - sk1*dtaperz dedxk2 = dedxk2*taper - sk2*dtaperx dedyk2 = dedyk2*taper - sk2*dtapery dedzk2 = dedzk2*taper - sk2*dtaperz end if c c increment the overall energy and derivative expressions c if (i .eq. k) e = 0.5d0 * e ed = ed + e ded(1,i1) = ded(1,i1) + dedxi1 ded(2,i1) = ded(2,i1) + dedyi1 ded(3,i1) = ded(3,i1) + dedzi1 ded(1,i2) = ded(1,i2) + dedxi2 ded(2,i2) = ded(2,i2) + dedyi2 ded(3,i2) = ded(3,i2) + dedzi2 if (i .ne. k) then ded(1,k1) = ded(1,k1) + dedxk1 ded(2,k1) = ded(2,k1) + dedyk1 ded(3,k1) = ded(3,k1) + dedzk1 ded(1,k2) = ded(1,k2) + dedxk2 ded(2,k2) = ded(2,k2) + dedyk2 ded(3,k2) = ded(3,k2) + dedzk2 end if c c increment the internal virial tensor components c xq1 = x(k1) - xq yq1 = y(k1) - yq zq1 = z(k1) - zq xq2 = x(k2) - xq yq2 = y(k2) - yq zq2 = z(k2) - zq vxx = xq1*dedxk1 + xq2*dedxk2 vyx = 0.5d0 * (yq1*dedxk1 + yq2*dedxk2 & + xq1*dedyk1 + xq2*dedyk2) vzx = 0.5d0 * (zq1*dedxk1 + zq2*dedxk2 & + xq1*dedzk1 + xq2*dedzk2) vyy = yq1*dedyk1 + yq2*dedyk2 vzy = 0.5d0 * (zq1*dedyk1 + zq2*dedyk2 & + yq1*dedzk1 + yq2*dedzk2) vzz = zq1*dedzk1 + zq2*dedzk2 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 if end do end do return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine edipole2 -- atomwise dipole-dipole Hessian ## c ## ## c ############################################################### c c c "edipole2" calculates second derivatives of the c dipole-dipole interaction energy for a single atom c c subroutine edipole2 (i) use atoms use bound use cell use chgpot use dipole use group use hessn use units use shunt implicit none integer i,i1,i2,k1,k2 integer jcell,idipole,kdipole real*8 f,fi,fik,fgrp real*8 xi,yi,zi,xk,yk,zk real*8 xq,yq,zq,xr,yr,zr real*8 e,r2,ri2,rk2,rirkr3 real*8 doti,dotk,dotp real*8 si1,si2,sk1,sk2 real*8 de,dedr,dedrirk real*8 deddoti,deddotk,deddotp real*8 termx,termy,termz real*8 termxi,termyi,termzi real*8 termxk,termyk,termzk real*8 enum,r2inv,ri2inv real*8 dotik,xrr2,yrr2,zrr2 real*8 xiri2,yiri2,ziri2 real*8 xkrk2,ykrk2,zkrk2 real*8 xixr,xiyr,xizr real*8 yixr,yiyr,yizr real*8 zixr,ziyr,zizr real*8 xkxr,xkyr,xkzr real*8 ykxr,ykyr,ykzr real*8 zkxr,zkyr,zkzr real*8 xixk,xiyk,xizk real*8 yixk,yiyk,yizk real*8 zixk,ziyk,zizk real*8 xrxr,xryr,xrzr real*8 yryr,yrzr,zrzr real*8 xidotk,yidotk,zidotk real*8 xkdoti,ykdoti,zkdoti real*8 factor,factori,factork real*8 part,partik real*8 dedxi1,dedyi1,dedzi1 real*8 dedxi2,dedyi2,dedzi2 real*8 dedxk1,dedyk1,dedzk1 real*8 dedxk2,dedyk2,dedzk2 real*8 dtdxi1,dtdyi1,dtdzi1 real*8 dtdxi2,dtdyi2,dtdzi2 real*8 dtxdxi1,dtxidxi1,dtxkdxi1 real*8 dtxdxi2,dtxidxi2,dtxkdxi2 real*8 dtydxi1,dtyidxi1,dtykdxi1 real*8 dtydxi2,dtyidxi2,dtykdxi2 real*8 dtzdxi1,dtzidxi1,dtzkdxi1 real*8 dtzdxi2,dtzidxi2,dtzkdxi2 real*8 dtxdyi1,dtxidyi1,dtxkdyi1 real*8 dtxdyi2,dtxidyi2,dtxkdyi2 real*8 dtydyi1,dtyidyi1,dtykdyi1 real*8 dtydyi2,dtyidyi2,dtykdyi2 real*8 dtzdyi1,dtzidyi1,dtzkdyi1 real*8 dtzdyi2,dtzidyi2,dtzkdyi2 real*8 dtxdzi1,dtxidzi1,dtxkdzi1 real*8 dtxdzi2,dtxidzi2,dtxkdzi2 real*8 dtydzi1,dtyidzi1,dtykdzi1 real*8 dtydzi2,dtyidzi2,dtykdzi2 real*8 dtzdzi1,dtzidzi1,dtzkdzi1 real*8 dtzdzi2,dtzidzi2,dtzkdzi2 real*8 r,r3,r4,r5 real*8 taper,dtaper,d2taper real*8 dtaperx,dtapery,dtaperz real*8 d2taperxx,d2taperyy,d2taperzz real*8 d2taperxy,d2taperxz,d2taperyz logical proceed character*6 mode c c c set conversion factor and switching function coefficients c if (ndipole .eq. 0) return f = electric / (debye**2 * dielec) mode = 'DIPOLE' call switch (mode) c c calculate the dipole interaction energy Hessian elements c do idipole = 1, ndipole i1 = idpl(1,idipole) i2 = idpl(2,idipole) si1 = 1.0d0 - sdpl(idipole) si2 = sdpl(idipole) if (i1.ne.i .and. i2.ne.i) goto 10 xi = x(i2) - x(i1) yi = y(i2) - y(i1) zi = z(i2) - z(i1) if (use_polymer) call imager (xi,yi,zi,-1) ri2 = xi*xi + yi*yi + zi*zi xq = x(i1) + xi*si2 yq = y(i1) + yi*si2 zq = z(i1) + zi*si2 fi = f * bdpl(idipole) c c decide whether to compute the current interaction c do kdipole = 1, ndipole k1 = idpl(1,kdipole) k2 = idpl(2,kdipole) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,i2,k1,k2,0,0) if (proceed) proceed = (k1.ne.i1 .and. k1.ne.i2 .and. & k2.ne.i1 .and. k2.ne.i2) c c compute the energy contribution for this interaction c if (proceed) then sk1 = 1.0d0 - sdpl(kdipole) sk2 = sdpl(kdipole) xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) if (use_polymer) call imager (xk,yk,zk,-1) xr = xq - x(k1) - xk*sk2 yr = yq - y(k1) - yk*sk2 zr = zq - z(k1) - zk*sk2 call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rk2 = xk*xk + yk*yk + zk*zk rirkr3 = sqrt(ri2*rk2*r2) * r2 dotp = xi*xk + yi*yk + zi*zk doti = xi*xr + yi*yr + zi*zr dotk = xk*xr + yk*yr + zk*zr fik = fi * bdpl(kdipole) c c some abbreviations used in various chain rule terms c dotik = doti * dotk enum = dotp*r2 - 3.0d0*dotik r2inv = 15.0d0 / r2 ri2inv = 1.0d0 / ri2 xrr2 = xr / r2 yrr2 = yr / r2 zrr2 = zr / r2 xiri2 = xi / ri2 yiri2 = yi / ri2 ziri2 = zi / ri2 xkrk2 = xk / rk2 ykrk2 = yk / rk2 zkrk2 = zk / rk2 xixr = xi * xr xiyr = xi * yr xizr = xi * zr yixr = yi * xr yiyr = yi * yr yizr = yi * zr zixr = zi * xr ziyr = zi * yr zizr = zi * zr xkxr = xk * xr xkyr = xk * yr xkzr = xk * zr ykxr = yk * xr ykyr = yk * yr ykzr = yk * zr zkxr = zk * xr zkyr = zk * yr zkzr = zk * zr xixk = xi * xk xiyk = xi * yk xizk = xi * zk yixk = yi * xk yiyk = yi * yk yizk = yi * zk zixk = zi * xk ziyk = zi * yk zizk = zi * zk xrxr = 3.0d0 * xr * xr xryr = 3.0d0 * xr * yr xrzr = 3.0d0 * xr * zr yryr = 3.0d0 * yr * yr yrzr = 3.0d0 * yr * zr zrzr = 3.0d0 * zr * zr xidotk = xi * dotk yidotk = yi * dotk zidotk = zi * dotk xkdoti = xk * doti ykdoti = yk * doti zkdoti = zk * doti c c scale the interaction based on its group membership c if (use_group) fik = fik * fgrp c c form the master chain rule term for derivatives c de = -fik / (rirkr3*r2) c c form the chain rule terms for first derivatives c deddotp = -de * r2 deddoti = de * 3.0d0*dotk deddotk = de * 3.0d0*doti dedr = de * (3.0d0*dotp-15.0d0*dotik/r2) dedrirk = de * enum c c more first derivative chain rule expressions c termx = dedr*xr + deddoti*xi + deddotk*xk termy = dedr*yr + deddoti*yi + deddotk*yk termz = dedr*zr + deddoti*zi + deddotk*zk termxi = dedrirk*xiri2 + deddotp*xk + deddoti*xr termyi = dedrirk*yiri2 + deddotp*yk + deddoti*yr termzi = dedrirk*ziri2 + deddotp*zk + deddoti*zr termxk = dedrirk*xkrk2 + deddotp*xi + deddotk*xr termyk = dedrirk*ykrk2 + deddotp*yi + deddotk*yr termzk = dedrirk*zkrk2 + deddotp*zi + deddotk*zr c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3 dedxi1 = si1*termx - termxi dedyi1 = si1*termy - termyi dedzi1 = si1*termz - termzi dedxi2 = si2*termx + termxi dedyi2 = si2*termy + termyi dedzi2 = si2*termz + termzi dedxk1 = -sk1*termx - termxk dedyk1 = -sk1*termy - termyk dedzk1 = -sk1*termz - termzk dedxk2 = -sk2*termx + termxk dedyk2 = -sk2*termy + termyk dedzk2 = -sk2*termz + termzk r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 dtaper = dtaper / r dtaperx = xr * dtaper dtapery = yr * dtaper dtaperz = zr * dtaper d2taper = e * (d2taper-dtaper) dtaper = e * dtaper d2taperxx = xr*xrr2*d2taper + dtaper d2taperxy = xr*yrr2*d2taper d2taperxz = xr*zrr2*d2taper d2taperyy = yr*yrr2*d2taper + dtaper d2taperyz = yr*zrr2*d2taper d2taperzz = zr*zrr2*d2taper + dtaper de = de * taper termx = termx * taper termy = termy * taper termz = termz * taper termxi = termxi * taper termyi = termyi * taper termzi = termzi * taper termxk = termxk * taper termyk = termyk * taper termzk = termzk * taper end if c c chain rule terms for second derivative components c if (i .eq. i1) then dtdxi1 = -5.0d0*si1*xrr2 + xiri2 part = si1*xkdoti - dotk*xr + si1*xidotk & - 2.0d0*si1*dotik*xrr2 partik = -xk*r2 + 2.0d0*si1*dotp*xr & - 3.0d0*si1*xkdoti + 3.0d0*xr*dotk & - 3.0d0*si1*xidotk factor = 3.0d0*si1*dotp - 6.0d0*xkxr & + 6.0d0*si1*xixk - 3.0d0*dotk & - r2inv*(xr*part+si1*dotik) factori = 3.0d0*si1*dotk + si1*xkxr + xiri2*partik & - enum*(ri2inv-2.0d0*xiri2*xiri2) factork = r2 + 3.0d0*si1*doti + si1*xixr & - xrxr + xkrk2*partik dtxdxi1 = dtdxi1*termx + de*factor dtxidxi1 = dtdxi1*termxi + de*factori dtxkdxi1 = dtdxi1*termxk + de*factork factor = -3.0d0*xkyr - 3.0d0*ykxr + 3.0d0*si1*xiyk & + 3.0d0*si1*yixk - r2inv*yr*part factori = -2.0d0*si1*ykxr + 3.0d0*si1*xkyr & + yiri2*partik + 2.0d0*enum*yiri2*xiri2 factork = -2.0d0*si1*yixr - xryr + 3.0d0*si1*xiyr & + ykrk2*partik dtydxi1 = dtdxi1*termy + de*factor dtyidxi1 = dtdxi1*termyi + de*factori dtykdxi1 = dtdxi1*termyk + de*factork factor = -3.0d0*xkzr - 3.0d0*zkxr + 3.0d0*si1*xizk & + 3.0d0*si1*zixk - r2inv*zr*part factori = -2.0d0*si1*zkxr + 3.0d0*si1*xkzr & + ziri2*partik + 2.0d0*enum*ziri2*xiri2 factork = -2.0d0*si1*zixr - xrzr + 3.0d0*si1*xizr & + zkrk2*partik dtzdxi1 = dtdxi1*termz + de*factor dtzidxi1 = dtdxi1*termzi + de*factori dtzkdxi1 = dtdxi1*termzk + de*factork dtdyi1 = -5.0d0*si1*yrr2 + yiri2 part = si1*ykdoti - dotk*yr + si1*yidotk & - 2.0d0*si1*dotik*yrr2 partik = -yk*r2 + 2.0d0*si1*dotp*yr & - 3.0d0*si1*ykdoti + 3.0d0*yr*dotk & - 3.0d0*si1*yidotk factor = -3.0d0*ykxr - 3.0d0*xkyr + 3.0d0*si1*yixk & + 3.0d0*si1*xiyk - r2inv*xr*part factori = -2.0d0*si1*xkyr + 3.0d0*si1*ykxr & + xiri2*partik + 2.0d0*enum*xiri2*yiri2 factork = -2.0d0*si1*xiyr - xryr + 3.0d0*si1*yixr & + xkrk2*partik dtxdyi1 = dtdyi1*termx + de*factor dtxidyi1 = dtdyi1*termxi + de*factori dtxkdyi1 = dtdyi1*termxk + de*factork factor = 3.0d0*si1*dotp - 6.0d0*ykyr & + 6.0d0*si1*yiyk - 3.0d0*dotk & - r2inv*(yr*part+si1*dotik) factori = 3.0d0*si1*dotk + si1*ykyr + yiri2*partik & - enum*(ri2inv-2.0d0*yiri2*yiri2) factork = r2 + 3.0d0*si1*doti + si1*yiyr & - yryr + ykrk2*partik dtydyi1 = dtdyi1*termy + de*factor dtyidyi1 = dtdyi1*termyi + de*factori dtykdyi1 = dtdyi1*termyk + de*factork factor = -3.0d0*ykzr - 3.0d0*zkyr + 3.0d0*si1*yizk & + 3.0d0*si1*ziyk - r2inv*zr*part factori = -2.0d0*si1*zkyr + 3.0d0*si1*ykzr & + ziri2*partik + 2.0d0*enum*ziri2*yiri2 factork = -2.0d0*si1*ziyr - yrzr + 3.0d0*si1*yizr & + zkrk2*partik dtzdyi1 = dtdyi1*termz + de*factor dtzidyi1 = dtdyi1*termzi + de*factori dtzkdyi1 = dtdyi1*termzk + de*factork dtdzi1 = -5.0d0*si1*zrr2 + ziri2 part = si1*zkdoti - dotk*zr + si1*zidotk & - 2.0d0*si1*dotik*zrr2 partik = -zk*r2 + 2.0d0*si1*dotp*zr & - 3.0d0*si1*zkdoti + 3.0d0*zr*dotk & - 3.0d0*si1*zidotk factor = -3.0d0*zkxr - 3.0d0*xkzr + 3.0d0*si1*zixk & + 3.0d0*si1*xizk - r2inv*xr*part factori = -2.0d0*si1*xkzr + 3.0d0*si1*zkxr & + xiri2*partik + 2.0d0*enum*xiri2*ziri2 factork = -2.0d0*si1*xizr - xrzr + 3.0d0*si1*zixr & + xkrk2*partik dtxdzi1 = dtdzi1*termx + de*factor dtxidzi1 = dtdzi1*termxi + de*factori dtxkdzi1 = dtdzi1*termxk + de*factork factor = -3.0d0*zkyr - 3.0d0*ykzr + 3.0d0*si1*ziyk & + 3.0d0*si1*yizk - r2inv*yr*part factori = -2.0d0*si1*ykzr + 3.0d0*si1*zkyr & + yiri2*partik + 2.0d0*enum*yiri2*ziri2 factork = -2.0d0*si1*yizr - yrzr + 3.0d0*si1*ziyr & + ykrk2*partik dtydzi1 = dtdzi1*termy + de*factor dtyidzi1 = dtdzi1*termyi + de*factori dtykdzi1 = dtdzi1*termyk + de*factork factor = 3.0d0*si1*dotp - 6.0d0*zkzr & + 6.0d0*si1*zizk - 3.0d0*dotk & - r2inv*(zr*part+si1*dotik) factori = 3.0d0*si1*dotk + si1*zkzr + ziri2*partik & - enum*(ri2inv-2.0d0*ziri2*ziri2) factork = r2 + 3.0d0*si1*doti + si1*zizr & - zrzr + zkrk2*partik dtzdzi1 = dtdzi1*termz + de*factor dtzidzi1 = dtdzi1*termzi + de*factori dtzkdzi1 = dtdzi1*termzk + de*factork else if (i .eq. i2) then dtdxi2 = -5.0d0*si2*xrr2 - xiri2 part = si2*xkdoti + dotk*xr + si2*xidotk & - 2.0d0*si2*dotik*xrr2 partik = xk*r2 + 2.0d0*si2*dotp*xr & - 3.0d0*si2*xkdoti - 3.0d0*xr*dotk & - 3.0d0*si2*xidotk factor = 3.0d0*si2*dotp + 6.0d0*xkxr & + 6.0d0*si2*xixk + 3.0d0*dotk & - r2inv*(xr*part+si2*dotik) factori = 3.0d0*si2*dotk + si2*xkxr + xiri2*partik & + enum*(ri2inv-2.0d0*xiri2*xiri2) factork = -r2 + 3.0d0*si2*doti + si2*xixr & + xrxr + xkrk2*partik dtxdxi2 = dtdxi2*termx + de*factor dtxidxi2 = dtdxi2*termxi + de*factori dtxkdxi2 = dtdxi2*termxk + de*factork factor = 3.0d0*xkyr + 3.0d0*ykxr + 3.0d0*si2*xiyk & + 3.0d0*si2*yixk - r2inv*yr*part factori = -2.0d0*si2*ykxr + 3.0d0*si2*xkyr & + yiri2*partik - 2.0d0*enum*yiri2*xiri2 factork = -2.0d0*si2*yixr + xryr + 3.0d0*si2*xiyr & + ykrk2*partik dtydxi2 = dtdxi2*termy + de*factor dtyidxi2 = dtdxi2*termyi + de*factori dtykdxi2 = dtdxi2*termyk + de*factork factor = 3.0d0*xkzr + 3.0d0*zkxr + 3.0d0*si2*xizk & + 3.0d0*si2*zixk - r2inv*zr*part factori = -2.0d0*si2*zkxr + 3.0d0*si2*xkzr & + ziri2*partik - 2.0d0*enum*ziri2*xiri2 factork = -2.0d0*si2*zixr + xrzr + 3.0d0*si2*xizr & + zkrk2*partik dtzdxi2 = dtdxi2*termz + de*factor dtzidxi2 = dtdxi2*termzi + de*factori dtzkdxi2 = dtdxi2*termzk + de*factork dtdyi2 = -5.0d0*si2*yrr2 - yiri2 part = si2*ykdoti + dotk*yr + si2*yidotk & - 2.0d0*si2*dotik*yrr2 partik = yk*r2 + 2.0d0*si2*dotp*yr & - 3.0d0*si2*ykdoti - 3.0d0*yr*dotk & - 3.0d0*si2*yidotk factor = 3.0d0*ykxr + 3.0d0*xkyr + 3.0d0*si2*yixk & + 3.0d0*si2*xiyk - r2inv*xr*part factori = -2.0d0*si2*xkyr + 3.0d0*si2*ykxr & + xiri2*partik - 2.0d0*enum*xiri2*yiri2 factork = -2.0d0*si2*xiyr + xryr + 3.0d0*si2*yixr & + xkrk2*partik dtxdyi2 = dtdyi2*termx + de*factor dtxidyi2 = dtdyi2*termxi + de*factori dtxkdyi2 = dtdyi2*termxk + de*factork factor = 3.0d0*si2*dotp + 6.0d0*ykyr & + 6.0d0*si2*yiyk + 3.0d0*dotk & - r2inv*(yr*part+si2*dotik) factori = 3.0d0*si2*dotk + si2*ykyr + yiri2*partik & + enum*(ri2inv-2.0d0*yiri2*yiri2) factork = -r2 + 3.0d0*si2*doti + si2*yiyr & + yryr + ykrk2*partik dtydyi2 = dtdyi2*termy + de*factor dtyidyi2 = dtdyi2*termyi + de*factori dtykdyi2 = dtdyi2*termyk + de*factork factor = 3.0d0*ykzr + 3.0d0*zkyr + 3.0d0*si2*yizk & + 3.0d0*si2*ziyk - r2inv*zr*part factori = -2.0d0*si2*zkyr + 3.0d0*si2*ykzr & + ziri2*partik - 2.0d0*enum*ziri2*yiri2 factork = -2.0d0*si2*ziyr + yrzr + 3.0d0*si2*yizr & + zkrk2*partik dtzdyi2 = dtdyi2*termz + de*factor dtzidyi2 = dtdyi2*termzi + de*factori dtzkdyi2 = dtdyi2*termzk + de*factork dtdzi2 = -5.0d0*si2*zrr2 - ziri2 part = si2*zkdoti + dotk*zr + si2*zidotk & - 2.0d0*si2*dotik*zrr2 partik = zk*r2 + 2.0d0*si2*dotp*zr & - 3.0d0*si2*zkdoti - 3.0d0*zr*dotk & - 3.0d0*si2*zidotk factor = 3.0d0*zkxr + 3.0d0*xkzr + 3.0d0*si2*zixk & + 3.0d0*si2*xizk - r2inv*xr*part factori = -2.0d0*si2*xkzr + 3.0d0*si2*zkxr & + xiri2*partik - 2.0d0*enum*xiri2*ziri2 factork = -2.0d0*si2*xizr + xrzr + 3.0d0*si2*zixr & + xkrk2*partik dtxdzi2 = dtdzi2*termx + de*factor dtxidzi2 = dtdzi2*termxi + de*factori dtxkdzi2 = dtdzi2*termxk + de*factork factor = 3.0d0*zkyr + 3.0d0*ykzr + 3.0d0*si2*ziyk & + 3.0d0*si2*yizk - r2inv*yr*part factori = -2.0d0*si2*ykzr + 3.0d0*si2*zkyr & + yiri2*partik - 2.0d0*enum*yiri2*ziri2 factork = -2.0d0*si2*yizr + yrzr + 3.0d0*si2*ziyr & + ykrk2*partik dtydzi2 = dtdzi2*termy + de*factor dtyidzi2 = dtdzi2*termyi + de*factori dtykdzi2 = dtdzi2*termyk + de*factork factor = 3.0d0*si2*dotp + 6.0d0*zkzr & + 6.0d0*si2*zizk + 3.0d0*dotk & - r2inv*(zr*part+si2*dotik) factori = 3.0d0*si2*dotk + si2*zkzr + ziri2*partik & + enum*(ri2inv-2.0d0*ziri2*ziri2) factork = -r2 + 3.0d0*si2*doti + si2*zizr & + zrzr + zkrk2*partik dtzdzi2 = dtdzi2*termz + de*factor dtzidzi2 = dtdzi2*termzi + de*factori dtzkdzi2 = dtdzi2*termzk + de*factork end if c c increment diagonal and off-diagonal Hessian elements c if (i .eq. i1) then hessx(1,i1) = hessx(1,i1) + si1*dtxdxi1 - dtxidxi1 hessx(2,i1) = hessx(2,i1) + si1*dtydxi1 - dtyidxi1 hessx(3,i1) = hessx(3,i1) + si1*dtzdxi1 - dtzidxi1 hessx(1,i2) = hessx(1,i2) + si2*dtxdxi1 + dtxidxi1 hessx(2,i2) = hessx(2,i2) + si2*dtydxi1 + dtyidxi1 hessx(3,i2) = hessx(3,i2) + si2*dtzdxi1 + dtzidxi1 hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi1 - dtxkdxi1 hessx(2,k1) = hessx(2,k1) - sk1*dtydxi1 - dtykdxi1 hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi1 - dtzkdxi1 hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi1 + dtxkdxi1 hessx(2,k2) = hessx(2,k2) - sk2*dtydxi1 + dtykdxi1 hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi1 + dtzkdxi1 hessy(1,i1) = hessy(1,i1) + si1*dtxdyi1 - dtxidyi1 hessy(2,i1) = hessy(2,i1) + si1*dtydyi1 - dtyidyi1 hessy(3,i1) = hessy(3,i1) + si1*dtzdyi1 - dtzidyi1 hessy(1,i2) = hessy(1,i2) + si2*dtxdyi1 + dtxidyi1 hessy(3,i2) = hessy(3,i2) + si2*dtzdyi1 + dtzidyi1 hessy(2,i2) = hessy(2,i2) + si2*dtydyi1 + dtyidyi1 hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi1 - dtxkdyi1 hessy(2,k1) = hessy(2,k1) - sk1*dtydyi1 - dtykdyi1 hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi1 - dtzkdyi1 hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi1 + dtxkdyi1 hessy(2,k2) = hessy(2,k2) - sk2*dtydyi1 + dtykdyi1 hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi1 + dtzkdyi1 hessz(1,i1) = hessz(1,i1) + si1*dtxdzi1 - dtxidzi1 hessz(2,i1) = hessz(2,i1) + si1*dtydzi1 - dtyidzi1 hessz(3,i1) = hessz(3,i1) + si1*dtzdzi1 - dtzidzi1 hessz(1,i2) = hessz(1,i2) + si2*dtxdzi1 + dtxidzi1 hessz(2,i2) = hessz(2,i2) + si2*dtydzi1 + dtyidzi1 hessz(3,i2) = hessz(3,i2) + si2*dtzdzi1 + dtzidzi1 hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi1 - dtxkdzi1 hessz(2,k1) = hessz(2,k1) - sk1*dtydzi1 - dtykdzi1 hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi1 - dtzkdzi1 hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi1 + dtxkdzi1 hessz(2,k2) = hessz(2,k2) - sk2*dtydzi1 + dtykdzi1 hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi1 + dtzkdzi1 else if (i .eq. i2) then hessx(1,i1) = hessx(1,i1) + si1*dtxdxi2 - dtxidxi2 hessx(2,i1) = hessx(2,i1) + si1*dtydxi2 - dtyidxi2 hessx(3,i1) = hessx(3,i1) + si1*dtzdxi2 - dtzidxi2 hessx(1,i2) = hessx(1,i2) + si2*dtxdxi2 + dtxidxi2 hessx(2,i2) = hessx(2,i2) + si2*dtydxi2 + dtyidxi2 hessx(3,i2) = hessx(3,i2) + si2*dtzdxi2 + dtzidxi2 hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi2 - dtxkdxi2 hessx(2,k1) = hessx(2,k1) - sk1*dtydxi2 - dtykdxi2 hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi2 - dtzkdxi2 hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi2 + dtxkdxi2 hessx(2,k2) = hessx(2,k2) - sk2*dtydxi2 + dtykdxi2 hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi2 + dtzkdxi2 hessy(1,i1) = hessy(1,i1) + si1*dtxdyi2 - dtxidyi2 hessy(2,i1) = hessy(2,i1) + si1*dtydyi2 - dtyidyi2 hessy(3,i1) = hessy(3,i1) + si1*dtzdyi2 - dtzidyi2 hessy(1,i2) = hessy(1,i2) + si2*dtxdyi2 + dtxidyi2 hessy(2,i2) = hessy(2,i2) + si2*dtydyi2 + dtyidyi2 hessy(3,i2) = hessy(3,i2) + si2*dtzdyi2 + dtzidyi2 hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi2 - dtxkdyi2 hessy(2,k1) = hessy(2,k1) - sk1*dtydyi2 - dtykdyi2 hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi2 - dtzkdyi2 hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi2 + dtxkdyi2 hessy(2,k2) = hessy(2,k2) - sk2*dtydyi2 + dtykdyi2 hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi2 + dtzkdyi2 hessz(1,i1) = hessz(1,i1) + si1*dtxdzi2 - dtxidzi2 hessz(2,i1) = hessz(2,i1) + si1*dtydzi2 - dtyidzi2 hessz(3,i1) = hessz(3,i1) + si1*dtzdzi2 - dtzidzi2 hessz(1,i2) = hessz(1,i2) + si2*dtxdzi2 + dtxidzi2 hessz(2,i2) = hessz(2,i2) + si2*dtydzi2 + dtyidzi2 hessz(3,i2) = hessz(3,i2) + si2*dtzdzi2 + dtzidzi2 hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi2 - dtxkdzi2 hessz(2,k1) = hessz(2,k1) - sk1*dtydzi2 - dtykdzi2 hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi2 - dtzkdzi2 hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi2 + dtxkdzi2 hessz(2,k2) = hessz(2,k2) - sk2*dtydzi2 + dtykdzi2 hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi2 + dtzkdzi2 end if c c more energy switching if near the cutoff distance c if (r2 .gt. cut2) then if (i .eq. i1) then hessx(1,i1) = hessx(1,i1) + si1*dtaperx*dedxi1 & + si1*dtaperx*dedxi1 + si1*si1*d2taperxx hessx(2,i1) = hessx(2,i1) + si1*dtapery*dedxi1 & + si1*dtaperx*dedyi1 + si1*si1*d2taperxy hessx(3,i1) = hessx(3,i1) + si1*dtaperz*dedxi1 & + si1*dtaperx*dedzi1 + si1*si1*d2taperxz hessx(1,i2) = hessx(1,i2) + si2*dtaperx*dedxi1 & + si1*dtaperx*dedxi2 + si2*si1*d2taperxx hessx(2,i2) = hessx(2,i2) + si2*dtapery*dedxi1 & + si1*dtaperx*dedyi2 + si2*si1*d2taperxy hessx(3,i2) = hessx(3,i2) + si2*dtaperz*dedxi1 & + si1*dtaperx*dedzi2 + si2*si1*d2taperxz hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxi1 & + si1*dtaperx*dedxk1 - sk1*si1*d2taperxx hessx(2,k1) = hessx(2,k1) - sk1*dtapery*dedxi1 & + si1*dtaperx*dedyk1 - sk1*si1*d2taperxy hessx(3,k1) = hessx(3,k1) - sk1*dtaperz*dedxi1 & + si1*dtaperx*dedzk1 - sk1*si1*d2taperxz hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxi1 & + si1*dtaperx*dedxk2 - sk2*si1*d2taperxx hessx(2,k2) = hessx(2,k2) - sk2*dtapery*dedxi1 & + si1*dtaperx*dedyk2 - sk2*si1*d2taperxy hessx(3,k2) = hessx(3,k2) - sk2*dtaperz*dedxi1 & + si1*dtaperx*dedzk2 - sk2*si1*d2taperxz hessy(1,i1) = hessy(1,i1) + si1*dtaperx*dedyi1 & + si1*dtapery*dedxi1 + si1*si1*d2taperxy hessy(2,i1) = hessy(2,i1) + si1*dtapery*dedyi1 & + si1*dtapery*dedyi1 + si1*si1*d2taperyy hessy(3,i1) = hessy(3,i1) + si1*dtaperz*dedyi1 & + si1*dtapery*dedzi1 + si1*si1*d2taperyz hessy(1,i2) = hessy(1,i2) + si2*dtaperx*dedyi1 & + si1*dtapery*dedxi2 + si2*si1*d2taperxy hessy(2,i2) = hessy(2,i2) + si2*dtapery*dedyi1 & + si1*dtapery*dedyi2 + si2*si1*d2taperyy hessy(3,i2) = hessy(3,i2) + si2*dtaperz*dedyi1 & + si1*dtapery*dedzi2 + si2*si1*d2taperyz hessy(1,k1) = hessy(1,k1) - sk1*dtaperx*dedyi1 & + si1*dtapery*dedxk1 - sk1*si1*d2taperxy hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyi1 & + si1*dtapery*dedyk1 - sk1*si1*d2taperyy hessy(3,k1) = hessy(3,k1) - sk1*dtaperz*dedyi1 & + si1*dtapery*dedzk1 - sk1*si1*d2taperyz hessy(1,k2) = hessy(1,k2) - sk2*dtaperx*dedyi1 & + si1*dtapery*dedxk2 - sk2*si1*d2taperxy hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyi1 & + si1*dtapery*dedyk2 - sk2*si1*d2taperyy hessy(3,k2) = hessy(3,k2) - sk2*dtaperz*dedyi1 & + si1*dtapery*dedzk2 - sk2*si1*d2taperyz hessz(1,i1) = hessz(1,i1) + si1*dtaperx*dedzi1 & + si1*dtaperz*dedxi1 + si1*si1*d2taperxz hessz(2,i1) = hessz(2,i1) + si1*dtapery*dedzi1 & + si1*dtaperz*dedyi1 + si1*si1*d2taperyz hessz(3,i1) = hessz(3,i1) + si1*dtaperz*dedzi1 & + si1*dtaperz*dedzi1 + si1*si1*d2taperzz hessz(1,i2) = hessz(1,i2) + si2*dtaperx*dedzi1 & + si1*dtaperz*dedxi2 + si2*si1*d2taperxz hessz(2,i2) = hessz(2,i2) + si2*dtapery*dedzi1 & + si1*dtaperz*dedyi2 + si2*si1*d2taperyz hessz(3,i2) = hessz(3,i2) + si2*dtaperz*dedzi1 & + si1*dtaperz*dedzi2 + si2*si1*d2taperzz hessz(1,k1) = hessz(1,k1) - sk1*dtaperx*dedzi1 & + si1*dtaperz*dedxk1 - sk1*si1*d2taperxz hessz(2,k1) = hessz(2,k1) - sk1*dtapery*dedzi1 & + si1*dtaperz*dedyk1 - sk1*si1*d2taperyz hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzi1 & + si1*dtaperz*dedzk1 - sk1*si1*d2taperzz hessz(1,k2) = hessz(1,k2) - sk2*dtaperx*dedzi1 & + si1*dtaperz*dedxk2 - sk2*si1*d2taperxz hessz(2,k2) = hessz(2,k2) - sk2*dtapery*dedzi1 & + si1*dtaperz*dedyk2 - sk2*si1*d2taperyz hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzi1 & + si1*dtaperz*dedzk2 - sk2*si1*d2taperzz else if (i .eq. i2) then hessx(1,i1) = hessx(1,i1) + si1*dtaperx*dedxi2 & + si2*dtaperx*dedxi1 + si1*si2*d2taperxx hessx(2,i1) = hessx(2,i1) + si1*dtapery*dedxi2 & + si2*dtaperx*dedyi1 + si1*si2*d2taperxy hessx(3,i1) = hessx(3,i1) + si1*dtaperz*dedxi2 & + si2*dtaperx*dedzi1 + si1*si2*d2taperxz hessx(1,i2) = hessx(1,i2) + si2*dtaperx*dedxi2 & + si2*dtaperx*dedxi2 + si2*si2*d2taperxx hessx(2,i2) = hessx(2,i2) + si2*dtapery*dedxi2 & + si2*dtaperx*dedyi2 + si2*si2*d2taperxy hessx(3,i2) = hessx(3,i2) + si2*dtaperz*dedxi2 & + si2*dtaperx*dedzi2 + si2*si2*d2taperxz hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxi2 & + si2*dtaperx*dedxk1 - sk1*si2*d2taperxx hessx(2,k1) = hessx(2,k1) - sk1*dtapery*dedxi2 & + si2*dtaperx*dedyk1 - sk1*si2*d2taperxy hessx(3,k1) = hessx(3,k1) - sk1*dtaperz*dedxi2 & + si2*dtaperx*dedzk1 - sk1*si2*d2taperxz hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxi2 & + si2*dtaperx*dedxk2 - sk2*si2*d2taperxx hessx(2,k2) = hessx(2,k2) - sk2*dtapery*dedxi2 & + si2*dtaperx*dedyk2 - sk2*si2*d2taperxy hessx(3,k2) = hessx(3,k2) - sk2*dtaperz*dedxi2 & + si2*dtaperx*dedzk2 - sk2*si2*d2taperxz hessy(1,i1) = hessy(1,i1) + si1*dtaperx*dedyi2 & + si2*dtapery*dedxi1 + si1*si2*d2taperxy hessy(2,i1) = hessy(2,i1) + si1*dtapery*dedyi2 & + si2*dtapery*dedyi1 + si1*si2*d2taperyy hessy(3,i1) = hessy(3,i1) + si1*dtaperz*dedyi2 & + si2*dtapery*dedzi1 + si1*si2*d2taperyz hessy(1,i2) = hessy(1,i2) + si2*dtaperx*dedyi2 & + si2*dtapery*dedxi2 + si2*si2*d2taperxy hessy(2,i2) = hessy(2,i2) + si2*dtapery*dedyi2 & + si2*dtapery*dedyi2 + si2*si2*d2taperyy hessy(3,i2) = hessy(3,i2) + si2*dtaperz*dedyi2 & + si2*dtapery*dedzi2 + si2*si2*d2taperyz hessy(1,k1) = hessy(1,k1) - sk1*dtaperx*dedyi2 & + si2*dtapery*dedxk1 - sk1*si2*d2taperxy hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyi2 & + si2*dtapery*dedyk1 - sk1*si2*d2taperyy hessy(3,k1) = hessy(3,k1) - sk1*dtaperz*dedyi2 & + si2*dtapery*dedzk1 - sk1*si2*d2taperyz hessy(1,k2) = hessy(1,k2) - sk2*dtaperx*dedyi2 & + si2*dtapery*dedxk2 - sk2*si2*d2taperxy hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyi2 & + si2*dtapery*dedyk2 - sk2*si2*d2taperyy hessy(3,k2) = hessy(3,k2) - sk2*dtaperz*dedyi2 & + si2*dtapery*dedzk2 - sk2*si2*d2taperyz hessz(1,i1) = hessz(1,i1) + si1*dtaperx*dedzi2 & + si2*dtaperz*dedxi1 + si1*si2*d2taperxz hessz(2,i1) = hessz(2,i1) + si1*dtapery*dedzi2 & + si2*dtaperz*dedyi1 + si1*si2*d2taperyz hessz(3,i1) = hessz(3,i1) + si1*dtaperz*dedzi2 & + si2*dtaperz*dedzi1 + si1*si2*d2taperzz hessz(1,i2) = hessz(1,i2) + si2*dtaperx*dedzi2 & + si2*dtaperz*dedxi2 + si2*si2*d2taperxz hessz(2,i2) = hessz(2,i2) + si2*dtapery*dedzi2 & + si2*dtaperz*dedyi2 + si2*si2*d2taperyz hessz(3,i2) = hessz(3,i2) + si2*dtaperz*dedzi2 & + si2*dtaperz*dedzi2 + si2*si2*d2taperzz hessz(1,k1) = hessz(1,k1) - sk1*dtaperx*dedzi2 & + si2*dtaperz*dedxk1 - sk1*si2*d2taperxz hessz(2,k1) = hessz(2,k1) - sk1*dtapery*dedzi2 & + si2*dtaperz*dedyk1 - sk1*si2*d2taperyz hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzi2 & + si2*dtaperz*dedzk1 - sk1*si2*d2taperzz hessz(1,k2) = hessz(1,k2) - sk2*dtaperx*dedzi2 & + si2*dtaperz*dedxk2 - sk2*si2*d2taperxz hessz(2,k2) = hessz(2,k2) - sk2*dtapery*dedzi2 & + si2*dtaperz*dedyk2 - sk2*si2*d2taperyz hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzi2 & + si2*dtaperz*dedzk2 - sk2*si2*d2taperzz end if end if end if end if end do 10 continue 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 idipole = 1, ndipole i1 = idpl(1,idipole) i2 = idpl(2,idipole) si1 = 1.0d0 - sdpl(idipole) si2 = sdpl(idipole) if (i1.ne.i .and. i2.ne.i) goto 30 xi = x(i2) - x(i1) yi = y(i2) - y(i1) zi = z(i2) - z(i1) if (use_polymer) call imager (xi,yi,zi,-1) ri2 = xi*xi + yi*yi + zi*zi xq = x(i1) + xi*si2 yq = y(i1) + yi*si2 zq = z(i1) + zi*si2 fi = f * bdpl(idipole) c c decide whether to compute the current interaction c do kdipole = 1, ndipole k1 = idpl(1,kdipole) k2 = idpl(2,kdipole) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,i2,k1,k2,0,0) if (.not. proceed) goto 20 c c compute the energy contribution for this interaction c sk1 = 1.0d0 - sdpl(kdipole) sk2 = sdpl(kdipole) do jcell = 2, ncell xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) if (use_polymer) call imager (xk,yk,zk,-1) xr = xq - x(k1) - xk*sk2 yr = yq - y(k1) - yk*sk2 zr = zq - z(k1) - zk*sk2 call imager (xr,yr,zr,jcell) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rk2 = xk*xk + yk*yk + zk*zk rirkr3 = sqrt(ri2*rk2*r2) * r2 dotp = xi*xk + yi*yk + zi*zk doti = xi*xr + yi*yr + zi*zr dotk = xk*xr + yk*yr + zk*zr fik = fi * bdpl(kdipole) if (use_polymer) then if (r2 .lt. polycut2) then if (k1.eq.i1 .or. k1.eq.i2 .or. & k2.eq.i1 .or. k2.eq.i2) fik = 0.0d0 end if end if c c some abbreviations used in various chain rule terms c dotik = doti * dotk enum = dotp*r2 - 3.0d0*dotik r2inv = 15.0d0 / r2 ri2inv = 1.0d0 / ri2 xrr2 = xr / r2 yrr2 = yr / r2 zrr2 = zr / r2 xiri2 = xi / ri2 yiri2 = yi / ri2 ziri2 = zi / ri2 xkrk2 = xk / rk2 ykrk2 = yk / rk2 zkrk2 = zk / rk2 xixr = xi * xr xiyr = xi * yr xizr = xi * zr yixr = yi * xr yiyr = yi * yr yizr = yi * zr zixr = zi * xr ziyr = zi * yr zizr = zi * zr xkxr = xk * xr xkyr = xk * yr xkzr = xk * zr ykxr = yk * xr ykyr = yk * yr ykzr = yk * zr zkxr = zk * xr zkyr = zk * yr zkzr = zk * zr xixk = xi * xk xiyk = xi * yk xizk = xi * zk yixk = yi * xk yiyk = yi * yk yizk = yi * zk zixk = zi * xk ziyk = zi * yk zizk = zi * zk xrxr = 3.0d0 * xr * xr xryr = 3.0d0 * xr * yr xrzr = 3.0d0 * xr * zr yryr = 3.0d0 * yr * yr yrzr = 3.0d0 * yr * zr zrzr = 3.0d0 * zr * zr xidotk = xi * dotk yidotk = yi * dotk zidotk = zi * dotk xkdoti = xk * doti ykdoti = yk * doti zkdoti = zk * doti c c scale the interaction based on its group membership c if (use_group) fik = fik * fgrp c c form the master chain rule term for derivatives c de = -fik / (rirkr3*r2) c c form the chain rule terms for first derivatives c deddotp = -de * r2 deddoti = de * 3.0d0*dotk deddotk = de * 3.0d0*doti dedr = de * (3.0d0*dotp-15.0d0*dotik/r2) dedrirk = de * enum c c more first derivative chain rule expressions c termx = dedr*xr + deddoti*xi + deddotk*xk termy = dedr*yr + deddoti*yi + deddotk*yk termz = dedr*zr + deddoti*zi + deddotk*zk termxi = dedrirk*xiri2 + deddotp*xk + deddoti*xr termyi = dedrirk*yiri2 + deddotp*yk + deddoti*yr termzi = dedrirk*ziri2 + deddotp*zk + deddoti*zr termxk = dedrirk*xkrk2 + deddotp*xi + deddotk*xr termyk = dedrirk*ykrk2 + deddotp*yi + deddotk*yr termzk = dedrirk*zkrk2 + deddotp*zi + deddotk*zr c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3 dedxi1 = si1*termx - termxi dedyi1 = si1*termy - termyi dedzi1 = si1*termz - termzi dedxi2 = si2*termx + termxi dedyi2 = si2*termy + termyi dedzi2 = si2*termz + termzi dedxk1 = -sk1*termx - termxk dedyk1 = -sk1*termy - termyk dedzk1 = -sk1*termz - termzk dedxk2 = -sk2*termx + termxk dedyk2 = -sk2*termy + termyk dedzk2 = -sk2*termz + termzk r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 dtaper = dtaper / r dtaperx = xr * dtaper dtapery = yr * dtaper dtaperz = zr * dtaper d2taper = e * (d2taper-dtaper) dtaper = e * dtaper d2taperxx = xr*xrr2*d2taper + dtaper d2taperxy = xr*yrr2*d2taper d2taperxz = xr*zrr2*d2taper d2taperyy = yr*yrr2*d2taper + dtaper d2taperyz = yr*zrr2*d2taper d2taperzz = zr*zrr2*d2taper + dtaper de = de * taper termx = termx * taper termy = termy * taper termz = termz * taper termxi = termxi * taper termyi = termyi * taper termzi = termzi * taper termxk = termxk * taper termyk = termyk * taper termzk = termzk * taper end if c c chain rule terms for second derivative components c if (i .eq. i1) then dtdxi1 = -5.0d0*si1*xrr2 + xiri2 part = si1*xkdoti - dotk*xr + si1*xidotk & - 2.0d0*si1*dotik*xrr2 partik = -xk*r2 + 2.0d0*si1*dotp*xr & - 3.0d0*si1*xkdoti + 3.0d0*xr*dotk & - 3.0d0*si1*xidotk factor = 3.0d0*si1*dotp - 6.0d0*xkxr & + 6.0d0*si1*xixk - 3.0d0*dotk & - r2inv*(xr*part+si1*dotik) factori = 3.0d0*si1*dotk + si1*xkxr + xiri2*partik & - enum*(ri2inv-2.0d0*xiri2*xiri2) factork = r2 + 3.0d0*si1*doti + si1*xixr & - xrxr + xkrk2*partik dtxdxi1 = dtdxi1*termx + de*factor dtxidxi1 = dtdxi1*termxi + de*factori dtxkdxi1 = dtdxi1*termxk + de*factork factor = -3.0d0*xkyr - 3.0d0*ykxr + 3.0d0*si1*xiyk & + 3.0d0*si1*yixk - r2inv*yr*part factori = -2.0d0*si1*ykxr + 3.0d0*si1*xkyr & + yiri2*partik + 2.0d0*enum*yiri2*xiri2 factork = -2.0d0*si1*yixr - xryr + 3.0d0*si1*xiyr & + ykrk2*partik dtydxi1 = dtdxi1*termy + de*factor dtyidxi1 = dtdxi1*termyi + de*factori dtykdxi1 = dtdxi1*termyk + de*factork factor = -3.0d0*xkzr - 3.0d0*zkxr + 3.0d0*si1*xizk & + 3.0d0*si1*zixk - r2inv*zr*part factori = -2.0d0*si1*zkxr + 3.0d0*si1*xkzr & + ziri2*partik + 2.0d0*enum*ziri2*xiri2 factork = -2.0d0*si1*zixr - xrzr + 3.0d0*si1*xizr & + zkrk2*partik dtzdxi1 = dtdxi1*termz + de*factor dtzidxi1 = dtdxi1*termzi + de*factori dtzkdxi1 = dtdxi1*termzk + de*factork dtdyi1 = -5.0d0*si1*yrr2 + yiri2 part = si1*ykdoti - dotk*yr + si1*yidotk & - 2.0d0*si1*dotik*yrr2 partik = -yk*r2 + 2.0d0*si1*dotp*yr & - 3.0d0*si1*ykdoti + 3.0d0*yr*dotk & - 3.0d0*si1*yidotk factor = -3.0d0*ykxr - 3.0d0*xkyr + 3.0d0*si1*yixk & + 3.0d0*si1*xiyk - r2inv*xr*part factori = -2.0d0*si1*xkyr + 3.0d0*si1*ykxr & + xiri2*partik + 2.0d0*enum*xiri2*yiri2 factork = -2.0d0*si1*xiyr - xryr + 3.0d0*si1*yixr & + xkrk2*partik dtxdyi1 = dtdyi1*termx + de*factor dtxidyi1 = dtdyi1*termxi + de*factori dtxkdyi1 = dtdyi1*termxk + de*factork factor = 3.0d0*si1*dotp - 6.0d0*ykyr & + 6.0d0*si1*yiyk - 3.0d0*dotk & - r2inv*(yr*part+si1*dotik) factori = 3.0d0*si1*dotk + si1*ykyr + yiri2*partik & - enum*(ri2inv-2.0d0*yiri2*yiri2) factork = r2 + 3.0d0*si1*doti + si1*yiyr & - yryr + ykrk2*partik dtydyi1 = dtdyi1*termy + de*factor dtyidyi1 = dtdyi1*termyi + de*factori dtykdyi1 = dtdyi1*termyk + de*factork factor = -3.0d0*ykzr - 3.0d0*zkyr + 3.0d0*si1*yizk & + 3.0d0*si1*ziyk - r2inv*zr*part factori = -2.0d0*si1*zkyr + 3.0d0*si1*ykzr & + ziri2*partik + 2.0d0*enum*ziri2*yiri2 factork = -2.0d0*si1*ziyr - yrzr + 3.0d0*si1*yizr & + zkrk2*partik dtzdyi1 = dtdyi1*termz + de*factor dtzidyi1 = dtdyi1*termzi + de*factori dtzkdyi1 = dtdyi1*termzk + de*factork dtdzi1 = -5.0d0*si1*zrr2 + ziri2 part = si1*zkdoti - dotk*zr + si1*zidotk & - 2.0d0*si1*dotik*zrr2 partik = -zk*r2 + 2.0d0*si1*dotp*zr & - 3.0d0*si1*zkdoti + 3.0d0*zr*dotk & - 3.0d0*si1*zidotk factor = -3.0d0*zkxr - 3.0d0*xkzr + 3.0d0*si1*zixk & + 3.0d0*si1*xizk - r2inv*xr*part factori = -2.0d0*si1*xkzr + 3.0d0*si1*zkxr & + xiri2*partik + 2.0d0*enum*xiri2*ziri2 factork = -2.0d0*si1*xizr - xrzr + 3.0d0*si1*zixr & + xkrk2*partik dtxdzi1 = dtdzi1*termx + de*factor dtxidzi1 = dtdzi1*termxi + de*factori dtxkdzi1 = dtdzi1*termxk + de*factork factor = -3.0d0*zkyr - 3.0d0*ykzr + 3.0d0*si1*ziyk & + 3.0d0*si1*yizk - r2inv*yr*part factori = -2.0d0*si1*ykzr + 3.0d0*si1*zkyr & + yiri2*partik + 2.0d0*enum*yiri2*ziri2 factork = -2.0d0*si1*yizr - yrzr + 3.0d0*si1*ziyr & + ykrk2*partik dtydzi1 = dtdzi1*termy + de*factor dtyidzi1 = dtdzi1*termyi + de*factori dtykdzi1 = dtdzi1*termyk + de*factork factor = 3.0d0*si1*dotp - 6.0d0*zkzr & + 6.0d0*si1*zizk - 3.0d0*dotk & - r2inv*(zr*part+si1*dotik) factori = 3.0d0*si1*dotk + si1*zkzr + ziri2*partik & - enum*(ri2inv-2.0d0*ziri2*ziri2) factork = r2 + 3.0d0*si1*doti + si1*zizr & - zrzr + zkrk2*partik dtzdzi1 = dtdzi1*termz + de*factor dtzidzi1 = dtdzi1*termzi + de*factori dtzkdzi1 = dtdzi1*termzk + de*factork else if (i .eq. i2) then dtdxi2 = -5.0d0*si2*xrr2 - xiri2 part = si2*xkdoti + dotk*xr + si2*xidotk & - 2.0d0*si2*dotik*xrr2 partik = xk*r2 + 2.0d0*si2*dotp*xr & - 3.0d0*si2*xkdoti - 3.0d0*xr*dotk & - 3.0d0*si2*xidotk factor = 3.0d0*si2*dotp + 6.0d0*xkxr & + 6.0d0*si2*xixk + 3.0d0*dotk & - r2inv*(xr*part+si2*dotik) factori = 3.0d0*si2*dotk + si2*xkxr + xiri2*partik & + enum*(ri2inv-2.0d0*xiri2*xiri2) factork = -r2 + 3.0d0*si2*doti + si2*xixr & + xrxr + xkrk2*partik dtxdxi2 = dtdxi2*termx + de*factor dtxidxi2 = dtdxi2*termxi + de*factori dtxkdxi2 = dtdxi2*termxk + de*factork factor = 3.0d0*xkyr + 3.0d0*ykxr + 3.0d0*si2*xiyk & + 3.0d0*si2*yixk - r2inv*yr*part factori = -2.0d0*si2*ykxr + 3.0d0*si2*xkyr & + yiri2*partik - 2.0d0*enum*yiri2*xiri2 factork = -2.0d0*si2*yixr + xryr + 3.0d0*si2*xiyr & + ykrk2*partik dtydxi2 = dtdxi2*termy + de*factor dtyidxi2 = dtdxi2*termyi + de*factori dtykdxi2 = dtdxi2*termyk + de*factork factor = 3.0d0*xkzr + 3.0d0*zkxr + 3.0d0*si2*xizk & + 3.0d0*si2*zixk - r2inv*zr*part factori = -2.0d0*si2*zkxr + 3.0d0*si2*xkzr & + ziri2*partik - 2.0d0*enum*ziri2*xiri2 factork = -2.0d0*si2*zixr + xrzr + 3.0d0*si2*xizr & + zkrk2*partik dtzdxi2 = dtdxi2*termz + de*factor dtzidxi2 = dtdxi2*termzi + de*factori dtzkdxi2 = dtdxi2*termzk + de*factork dtdyi2 = -5.0d0*si2*yrr2 - yiri2 part = si2*ykdoti + dotk*yr + si2*yidotk & - 2.0d0*si2*dotik*yrr2 partik = yk*r2 + 2.0d0*si2*dotp*yr & - 3.0d0*si2*ykdoti - 3.0d0*yr*dotk & - 3.0d0*si2*yidotk factor = 3.0d0*ykxr + 3.0d0*xkyr + 3.0d0*si2*yixk & + 3.0d0*si2*xiyk - r2inv*xr*part factori = -2.0d0*si2*xkyr + 3.0d0*si2*ykxr & + xiri2*partik - 2.0d0*enum*xiri2*yiri2 factork = -2.0d0*si2*xiyr + xryr + 3.0d0*si2*yixr & + xkrk2*partik dtxdyi2 = dtdyi2*termx + de*factor dtxidyi2 = dtdyi2*termxi + de*factori dtxkdyi2 = dtdyi2*termxk + de*factork factor = 3.0d0*si2*dotp + 6.0d0*ykyr & + 6.0d0*si2*yiyk + 3.0d0*dotk & - r2inv*(yr*part+si2*dotik) factori = 3.0d0*si2*dotk + si2*ykyr + yiri2*partik & + enum*(ri2inv-2.0d0*yiri2*yiri2) factork = -r2 + 3.0d0*si2*doti + si2*yiyr & + yryr + ykrk2*partik dtydyi2 = dtdyi2*termy + de*factor dtyidyi2 = dtdyi2*termyi + de*factori dtykdyi2 = dtdyi2*termyk + de*factork factor = 3.0d0*ykzr + 3.0d0*zkyr + 3.0d0*si2*yizk & + 3.0d0*si2*ziyk - r2inv*zr*part factori = -2.0d0*si2*zkyr + 3.0d0*si2*ykzr & + ziri2*partik - 2.0d0*enum*ziri2*yiri2 factork = -2.0d0*si2*ziyr + yrzr + 3.0d0*si2*yizr & + zkrk2*partik dtzdyi2 = dtdyi2*termz + de*factor dtzidyi2 = dtdyi2*termzi + de*factori dtzkdyi2 = dtdyi2*termzk + de*factork dtdzi2 = -5.0d0*si2*zrr2 - ziri2 part = si2*zkdoti + dotk*zr + si2*zidotk & - 2.0d0*si2*dotik*zrr2 partik = zk*r2 + 2.0d0*si2*dotp*zr & - 3.0d0*si2*zkdoti - 3.0d0*zr*dotk & - 3.0d0*si2*zidotk factor = 3.0d0*zkxr + 3.0d0*xkzr + 3.0d0*si2*zixk & + 3.0d0*si2*xizk - r2inv*xr*part factori = -2.0d0*si2*xkzr + 3.0d0*si2*zkxr & + xiri2*partik - 2.0d0*enum*xiri2*ziri2 factork = -2.0d0*si2*xizr + xrzr + 3.0d0*si2*zixr & + xkrk2*partik dtxdzi2 = dtdzi2*termx + de*factor dtxidzi2 = dtdzi2*termxi + de*factori dtxkdzi2 = dtdzi2*termxk + de*factork factor = 3.0d0*zkyr + 3.0d0*ykzr + 3.0d0*si2*ziyk & + 3.0d0*si2*yizk - r2inv*yr*part factori = -2.0d0*si2*ykzr + 3.0d0*si2*zkyr & + yiri2*partik - 2.0d0*enum*yiri2*ziri2 factork = -2.0d0*si2*yizr + yrzr + 3.0d0*si2*ziyr & + ykrk2*partik dtydzi2 = dtdzi2*termy + de*factor dtyidzi2 = dtdzi2*termyi + de*factori dtykdzi2 = dtdzi2*termyk + de*factork factor = 3.0d0*si2*dotp + 6.0d0*zkzr & + 6.0d0*si2*zizk + 3.0d0*dotk & - r2inv*(zr*part+si2*dotik) factori = 3.0d0*si2*dotk + si2*zkzr + ziri2*partik & + enum*(ri2inv-2.0d0*ziri2*ziri2) factork = -r2 + 3.0d0*si2*doti + si2*zizr & + zrzr + zkrk2*partik dtzdzi2 = dtdzi2*termz + de*factor dtzidzi2 = dtdzi2*termzi + de*factori dtzkdzi2 = dtdzi2*termzk + de*factork end if c c increment diagonal and off-diagonal Hessian elements c if (i .eq. i1) then hessx(1,i1) = hessx(1,i1) + si1*dtxdxi1 - dtxidxi1 hessx(2,i1) = hessx(2,i1) + si1*dtydxi1 - dtyidxi1 hessx(3,i1) = hessx(3,i1) + si1*dtzdxi1 - dtzidxi1 hessx(1,i2) = hessx(1,i2) + si2*dtxdxi1 + dtxidxi1 hessx(2,i2) = hessx(2,i2) + si2*dtydxi1 + dtyidxi1 hessx(3,i2) = hessx(3,i2) + si2*dtzdxi1 + dtzidxi1 hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi1 - dtxkdxi1 hessx(2,k1) = hessx(2,k1) - sk1*dtydxi1 - dtykdxi1 hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi1 - dtzkdxi1 hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi1 + dtxkdxi1 hessx(2,k2) = hessx(2,k2) - sk2*dtydxi1 + dtykdxi1 hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi1 + dtzkdxi1 hessy(1,i1) = hessy(1,i1) + si1*dtxdyi1 - dtxidyi1 hessy(2,i1) = hessy(2,i1) + si1*dtydyi1 - dtyidyi1 hessy(3,i1) = hessy(3,i1) + si1*dtzdyi1 - dtzidyi1 hessy(1,i2) = hessy(1,i2) + si2*dtxdyi1 + dtxidyi1 hessy(3,i2) = hessy(3,i2) + si2*dtzdyi1 + dtzidyi1 hessy(2,i2) = hessy(2,i2) + si2*dtydyi1 + dtyidyi1 hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi1 - dtxkdyi1 hessy(2,k1) = hessy(2,k1) - sk1*dtydyi1 - dtykdyi1 hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi1 - dtzkdyi1 hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi1 + dtxkdyi1 hessy(2,k2) = hessy(2,k2) - sk2*dtydyi1 + dtykdyi1 hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi1 + dtzkdyi1 hessz(1,i1) = hessz(1,i1) + si1*dtxdzi1 - dtxidzi1 hessz(2,i1) = hessz(2,i1) + si1*dtydzi1 - dtyidzi1 hessz(3,i1) = hessz(3,i1) + si1*dtzdzi1 - dtzidzi1 hessz(1,i2) = hessz(1,i2) + si2*dtxdzi1 + dtxidzi1 hessz(2,i2) = hessz(2,i2) + si2*dtydzi1 + dtyidzi1 hessz(3,i2) = hessz(3,i2) + si2*dtzdzi1 + dtzidzi1 hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi1 - dtxkdzi1 hessz(2,k1) = hessz(2,k1) - sk1*dtydzi1 - dtykdzi1 hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi1 - dtzkdzi1 hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi1 + dtxkdzi1 hessz(2,k2) = hessz(2,k2) - sk2*dtydzi1 + dtykdzi1 hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi1 + dtzkdzi1 else if (i .eq. i2) then hessx(1,i1) = hessx(1,i1) + si1*dtxdxi2 - dtxidxi2 hessx(2,i1) = hessx(2,i1) + si1*dtydxi2 - dtyidxi2 hessx(3,i1) = hessx(3,i1) + si1*dtzdxi2 - dtzidxi2 hessx(1,i2) = hessx(1,i2) + si2*dtxdxi2 + dtxidxi2 hessx(2,i2) = hessx(2,i2) + si2*dtydxi2 + dtyidxi2 hessx(3,i2) = hessx(3,i2) + si2*dtzdxi2 + dtzidxi2 hessx(1,k1) = hessx(1,k1) - sk1*dtxdxi2 - dtxkdxi2 hessx(2,k1) = hessx(2,k1) - sk1*dtydxi2 - dtykdxi2 hessx(3,k1) = hessx(3,k1) - sk1*dtzdxi2 - dtzkdxi2 hessx(1,k2) = hessx(1,k2) - sk2*dtxdxi2 + dtxkdxi2 hessx(2,k2) = hessx(2,k2) - sk2*dtydxi2 + dtykdxi2 hessx(3,k2) = hessx(3,k2) - sk2*dtzdxi2 + dtzkdxi2 hessy(1,i1) = hessy(1,i1) + si1*dtxdyi2 - dtxidyi2 hessy(2,i1) = hessy(2,i1) + si1*dtydyi2 - dtyidyi2 hessy(3,i1) = hessy(3,i1) + si1*dtzdyi2 - dtzidyi2 hessy(1,i2) = hessy(1,i2) + si2*dtxdyi2 + dtxidyi2 hessy(2,i2) = hessy(2,i2) + si2*dtydyi2 + dtyidyi2 hessy(3,i2) = hessy(3,i2) + si2*dtzdyi2 + dtzidyi2 hessy(1,k1) = hessy(1,k1) - sk1*dtxdyi2 - dtxkdyi2 hessy(2,k1) = hessy(2,k1) - sk1*dtydyi2 - dtykdyi2 hessy(3,k1) = hessy(3,k1) - sk1*dtzdyi2 - dtzkdyi2 hessy(1,k2) = hessy(1,k2) - sk2*dtxdyi2 + dtxkdyi2 hessy(2,k2) = hessy(2,k2) - sk2*dtydyi2 + dtykdyi2 hessy(3,k2) = hessy(3,k2) - sk2*dtzdyi2 + dtzkdyi2 hessz(1,i1) = hessz(1,i1) + si1*dtxdzi2 - dtxidzi2 hessz(2,i1) = hessz(2,i1) + si1*dtydzi2 - dtyidzi2 hessz(3,i1) = hessz(3,i1) + si1*dtzdzi2 - dtzidzi2 hessz(1,i2) = hessz(1,i2) + si2*dtxdzi2 + dtxidzi2 hessz(2,i2) = hessz(2,i2) + si2*dtydzi2 + dtyidzi2 hessz(3,i2) = hessz(3,i2) + si2*dtzdzi2 + dtzidzi2 hessz(1,k1) = hessz(1,k1) - sk1*dtxdzi2 - dtxkdzi2 hessz(2,k1) = hessz(2,k1) - sk1*dtydzi2 - dtykdzi2 hessz(3,k1) = hessz(3,k1) - sk1*dtzdzi2 - dtzkdzi2 hessz(1,k2) = hessz(1,k2) - sk2*dtxdzi2 + dtxkdzi2 hessz(2,k2) = hessz(2,k2) - sk2*dtydzi2 + dtykdzi2 hessz(3,k2) = hessz(3,k2) - sk2*dtzdzi2 + dtzkdzi2 end if c c more energy switching if near the cutoff distance c if (r2 .gt. cut2) then if (i .eq. i1) then hessx(1,i1) = hessx(1,i1) + si1*dtaperx*dedxi1 & + si1*dtaperx*dedxi1 + si1*si1*d2taperxx hessx(2,i1) = hessx(2,i1) + si1*dtapery*dedxi1 & + si1*dtaperx*dedyi1 + si1*si1*d2taperxy hessx(3,i1) = hessx(3,i1) + si1*dtaperz*dedxi1 & + si1*dtaperx*dedzi1 + si1*si1*d2taperxz hessx(1,i2) = hessx(1,i2) + si2*dtaperx*dedxi1 & + si1*dtaperx*dedxi2 + si2*si1*d2taperxx hessx(2,i2) = hessx(2,i2) + si2*dtapery*dedxi1 & + si1*dtaperx*dedyi2 + si2*si1*d2taperxy hessx(3,i2) = hessx(3,i2) + si2*dtaperz*dedxi1 & + si1*dtaperx*dedzi2 + si2*si1*d2taperxz hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxi1 & + si1*dtaperx*dedxk1 - sk1*si1*d2taperxx hessx(2,k1) = hessx(2,k1) - sk1*dtapery*dedxi1 & + si1*dtaperx*dedyk1 - sk1*si1*d2taperxy hessx(3,k1) = hessx(3,k1) - sk1*dtaperz*dedxi1 & + si1*dtaperx*dedzk1 - sk1*si1*d2taperxz hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxi1 & + si1*dtaperx*dedxk2 - sk2*si1*d2taperxx hessx(2,k2) = hessx(2,k2) - sk2*dtapery*dedxi1 & + si1*dtaperx*dedyk2 - sk2*si1*d2taperxy hessx(3,k2) = hessx(3,k2) - sk2*dtaperz*dedxi1 & + si1*dtaperx*dedzk2 - sk2*si1*d2taperxz hessy(1,i1) = hessy(1,i1) + si1*dtaperx*dedyi1 & + si1*dtapery*dedxi1 + si1*si1*d2taperxy hessy(2,i1) = hessy(2,i1) + si1*dtapery*dedyi1 & + si1*dtapery*dedyi1 + si1*si1*d2taperyy hessy(3,i1) = hessy(3,i1) + si1*dtaperz*dedyi1 & + si1*dtapery*dedzi1 + si1*si1*d2taperyz hessy(1,i2) = hessy(1,i2) + si2*dtaperx*dedyi1 & + si1*dtapery*dedxi2 + si2*si1*d2taperxy hessy(2,i2) = hessy(2,i2) + si2*dtapery*dedyi1 & + si1*dtapery*dedyi2 + si2*si1*d2taperyy hessy(3,i2) = hessy(3,i2) + si2*dtaperz*dedyi1 & + si1*dtapery*dedzi2 + si2*si1*d2taperyz hessy(1,k1) = hessy(1,k1) - sk1*dtaperx*dedyi1 & + si1*dtapery*dedxk1 - sk1*si1*d2taperxy hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyi1 & + si1*dtapery*dedyk1 - sk1*si1*d2taperyy hessy(3,k1) = hessy(3,k1) - sk1*dtaperz*dedyi1 & + si1*dtapery*dedzk1 - sk1*si1*d2taperyz hessy(1,k2) = hessy(1,k2) - sk2*dtaperx*dedyi1 & + si1*dtapery*dedxk2 - sk2*si1*d2taperxy hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyi1 & + si1*dtapery*dedyk2 - sk2*si1*d2taperyy hessy(3,k2) = hessy(3,k2) - sk2*dtaperz*dedyi1 & + si1*dtapery*dedzk2 - sk2*si1*d2taperyz hessz(1,i1) = hessz(1,i1) + si1*dtaperx*dedzi1 & + si1*dtaperz*dedxi1 + si1*si1*d2taperxz hessz(2,i1) = hessz(2,i1) + si1*dtapery*dedzi1 & + si1*dtaperz*dedyi1 + si1*si1*d2taperyz hessz(3,i1) = hessz(3,i1) + si1*dtaperz*dedzi1 & + si1*dtaperz*dedzi1 + si1*si1*d2taperzz hessz(1,i2) = hessz(1,i2) + si2*dtaperx*dedzi1 & + si1*dtaperz*dedxi2 + si2*si1*d2taperxz hessz(2,i2) = hessz(2,i2) + si2*dtapery*dedzi1 & + si1*dtaperz*dedyi2 + si2*si1*d2taperyz hessz(3,i2) = hessz(3,i2) + si2*dtaperz*dedzi1 & + si1*dtaperz*dedzi2 + si2*si1*d2taperzz hessz(1,k1) = hessz(1,k1) - sk1*dtaperx*dedzi1 & + si1*dtaperz*dedxk1 - sk1*si1*d2taperxz hessz(2,k1) = hessz(2,k1) - sk1*dtapery*dedzi1 & + si1*dtaperz*dedyk1 - sk1*si1*d2taperyz hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzi1 & + si1*dtaperz*dedzk1 - sk1*si1*d2taperzz hessz(1,k2) = hessz(1,k2) - sk2*dtaperx*dedzi1 & + si1*dtaperz*dedxk2 - sk2*si1*d2taperxz hessz(2,k2) = hessz(2,k2) - sk2*dtapery*dedzi1 & + si1*dtaperz*dedyk2 - sk2*si1*d2taperyz hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzi1 & + si1*dtaperz*dedzk2 - sk2*si1*d2taperzz else if (i .eq. i2) then hessx(1,i1) = hessx(1,i1) + si1*dtaperx*dedxi2 & + si2*dtaperx*dedxi1 + si1*si2*d2taperxx hessx(2,i1) = hessx(2,i1) + si1*dtapery*dedxi2 & + si2*dtaperx*dedyi1 + si1*si2*d2taperxy hessx(3,i1) = hessx(3,i1) + si1*dtaperz*dedxi2 & + si2*dtaperx*dedzi1 + si1*si2*d2taperxz hessx(1,i2) = hessx(1,i2) + si2*dtaperx*dedxi2 & + si2*dtaperx*dedxi2 + si2*si2*d2taperxx hessx(2,i2) = hessx(2,i2) + si2*dtapery*dedxi2 & + si2*dtaperx*dedyi2 + si2*si2*d2taperxy hessx(3,i2) = hessx(3,i2) + si2*dtaperz*dedxi2 & + si2*dtaperx*dedzi2 + si2*si2*d2taperxz hessx(1,k1) = hessx(1,k1) - sk1*dtaperx*dedxi2 & + si2*dtaperx*dedxk1 - sk1*si2*d2taperxx hessx(2,k1) = hessx(2,k1) - sk1*dtapery*dedxi2 & + si2*dtaperx*dedyk1 - sk1*si2*d2taperxy hessx(3,k1) = hessx(3,k1) - sk1*dtaperz*dedxi2 & + si2*dtaperx*dedzk1 - sk1*si2*d2taperxz hessx(1,k2) = hessx(1,k2) - sk2*dtaperx*dedxi2 & + si2*dtaperx*dedxk2 - sk2*si2*d2taperxx hessx(2,k2) = hessx(2,k2) - sk2*dtapery*dedxi2 & + si2*dtaperx*dedyk2 - sk2*si2*d2taperxy hessx(3,k2) = hessx(3,k2) - sk2*dtaperz*dedxi2 & + si2*dtaperx*dedzk2 - sk2*si2*d2taperxz hessy(1,i1) = hessy(1,i1) + si1*dtaperx*dedyi2 & + si2*dtapery*dedxi1 + si1*si2*d2taperxy hessy(2,i1) = hessy(2,i1) + si1*dtapery*dedyi2 & + si2*dtapery*dedyi1 + si1*si2*d2taperyy hessy(3,i1) = hessy(3,i1) + si1*dtaperz*dedyi2 & + si2*dtapery*dedzi1 + si1*si2*d2taperyz hessy(1,i2) = hessy(1,i2) + si2*dtaperx*dedyi2 & + si2*dtapery*dedxi2 + si2*si2*d2taperxy hessy(2,i2) = hessy(2,i2) + si2*dtapery*dedyi2 & + si2*dtapery*dedyi2 + si2*si2*d2taperyy hessy(3,i2) = hessy(3,i2) + si2*dtaperz*dedyi2 & + si2*dtapery*dedzi2 + si2*si2*d2taperyz hessy(1,k1) = hessy(1,k1) - sk1*dtaperx*dedyi2 & + si2*dtapery*dedxk1 - sk1*si2*d2taperxy hessy(2,k1) = hessy(2,k1) - sk1*dtapery*dedyi2 & + si2*dtapery*dedyk1 - sk1*si2*d2taperyy hessy(3,k1) = hessy(3,k1) - sk1*dtaperz*dedyi2 & + si2*dtapery*dedzk1 - sk1*si2*d2taperyz hessy(1,k2) = hessy(1,k2) - sk2*dtaperx*dedyi2 & + si2*dtapery*dedxk2 - sk2*si2*d2taperxy hessy(2,k2) = hessy(2,k2) - sk2*dtapery*dedyi2 & + si2*dtapery*dedyk2 - sk2*si2*d2taperyy hessy(3,k2) = hessy(3,k2) - sk2*dtaperz*dedyi2 & + si2*dtapery*dedzk2 - sk2*si2*d2taperyz hessz(1,i1) = hessz(1,i1) + si1*dtaperx*dedzi2 & + si2*dtaperz*dedxi1 + si1*si2*d2taperxz hessz(2,i1) = hessz(2,i1) + si1*dtapery*dedzi2 & + si2*dtaperz*dedyi1 + si1*si2*d2taperyz hessz(3,i1) = hessz(3,i1) + si1*dtaperz*dedzi2 & + si2*dtaperz*dedzi1 + si1*si2*d2taperzz hessz(1,i2) = hessz(1,i2) + si2*dtaperx*dedzi2 & + si2*dtaperz*dedxi2 + si2*si2*d2taperxz hessz(2,i2) = hessz(2,i2) + si2*dtapery*dedzi2 & + si2*dtaperz*dedyi2 + si2*si2*d2taperyz hessz(3,i2) = hessz(3,i2) + si2*dtaperz*dedzi2 & + si2*dtaperz*dedzi2 + si2*si2*d2taperzz hessz(1,k1) = hessz(1,k1) - sk1*dtaperx*dedzi2 & + si2*dtaperz*dedxk1 - sk1*si2*d2taperxz hessz(2,k1) = hessz(2,k1) - sk1*dtapery*dedzi2 & + si2*dtaperz*dedyk1 - sk1*si2*d2taperyz hessz(3,k1) = hessz(3,k1) - sk1*dtaperz*dedzi2 & + si2*dtaperz*dedzk1 - sk1*si2*d2taperzz hessz(1,k2) = hessz(1,k2) - sk2*dtaperx*dedzi2 & + si2*dtaperz*dedxk2 - sk2*si2*d2taperxz hessz(2,k2) = hessz(2,k2) - sk2*dtapery*dedzi2 & + si2*dtaperz*dedyk2 - sk2*si2*d2taperyz hessz(3,k2) = hessz(3,k2) - sk2*dtaperz*dedzi2 & + si2*dtaperz*dedzk2 - sk2*si2*d2taperzz end if end if end if end do 20 continue end do 30 continue end do return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine edipole3 -- dipole-dipole energy & analysis ## c ## ## c ################################################################ c c c "edipole3" calculates the dipole-dipole interaction energy; c also partitions the energy among the atoms c c subroutine edipole3 use action use analyz use atomid use atoms use bound use cell use chgpot use dipole use energi use group use inform use inter use iounit use molcul use shunt use units use usage implicit none integer i,j,k integer i1,i2,k1,k2 real*8 xi,yi,zi real*8 xk,yk,zk real*8 xq,yq,zq real*8 xr,yr,zr real*8 f,fi,fik real*8 taper,fgrp real*8 e,ri2,rk2,rirkr3 real*8 doti,dotk,dotp real*8 r,r2,r3,r4,r5 logical proceed logical header,huge character*6 mode c c c zero out the overall dipole interaction energy contribution c and set up the constants for the calculation c ned = 0 ed = 0.0d0 do i = 1, n aed(i) = 0.0d0 end do if (ndipole .eq. 0) return c c set conversion factor and switching function coefficients c f = electric / (debye**2 * dielec) mode = 'DIPOLE' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. ndipole.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Dipole-Dipole Interactions :', & //,' Type',15x,'Dipole 1',14x,'Dipole 2', & 8x,'Distance',6x,'Energy',/) end if c c compute and partition the dipole interaction energy c do i = 1, ndipole-1 i1 = idpl(1,i) i2 = idpl(2,i) xi = x(i2) - x(i1) yi = y(i2) - y(i1) zi = z(i2) - z(i1) if (use_polymer) call imager (xi,yi,zi,-1) ri2 = xi*xi + yi*yi + zi*zi xq = x(i1) + xi*sdpl(i) yq = y(i1) + yi*sdpl(i) zq = z(i1) + zi*sdpl(i) fi = f * bdpl(i) c c decide whether to compute the current interaction c do k = i+1, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,i2,k1,k2,0,0) if (proceed) proceed = (use(i1) .or. use(i2) .or. & use(k1) .or. use(k2)) if (proceed) proceed = (k1.ne.i1 .and. k1.ne.i2 .and. & k2.ne.i1 .and. k2.ne.i2) c c compute the energy contribution for this interaction c if (proceed) then xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) if (use_polymer) call imager (xk,yk,zk,-1) xr = xq - x(k1) - xk*sdpl(k) yr = yq - y(k1) - yk*sdpl(k) zr = zq - z(k1) - zk*sdpl(k) call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rk2 = xk*xk + yk*yk + zk*zk rirkr3 = sqrt(ri2*rk2*r2) * r2 dotp = xi*xk + yi*yk + zi*zk doti = xi*xr + yi*yr + zi*zr dotk = xk*xr + yk*yr + zk*zr fik = fi * bdpl(k) e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3 c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall dipole-dipole energy component c ned = ned + 1 ed = ed + e aed(i1) = aed(i1) + 0.25d0*e aed(i2) = aed(i2) + 0.25d0*e aed(k1) = aed(k1) + 0.25d0*e aed(k2) = aed(k2) + 0.25d0*e c c increment the total intermolecular energy c if (molcule(i1) .ne. molcule(k1)) then einter = einter + e end if c c print a message if the energy of this interaction is large c huge = (abs(e) .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Dipole-Dipole', & ' Interactions :', & //,' Type',15x,'Dipole 1',14x, & 'Dipole 2',8x,'Distance', & 6x,'Energy',/) end if write (iout,30) i1,name(i1),i2,name(i2), & k1,name(k1),k2,name(k2), & sqrt(r2),e 30 format (' Dipole',4x,4(i7,'-',a3),f11.4,f12.4) end if end if end if 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, ndipole i1 = idpl(1,i) i2 = idpl(2,i) xi = x(i2) - x(i1) yi = y(i2) - y(i1) zi = z(i2) - z(i1) if (use_polymer) call imager (xi,yi,zi,-1) ri2 = xi*xi + yi*yi + zi*zi xq = x(i1) + xi*sdpl(i) yq = y(i1) + yi*sdpl(i) zq = z(i1) + zi*sdpl(i) fi = f * bdpl(i) c c decide whether to compute the current interaction c do k = i, ndipole k1 = idpl(1,k) k2 = idpl(2,k) proceed = .true. if (use_group) call groups (proceed,fgrp,i1,i2,k1,k2,0,0) if (proceed) proceed = (use(i1) .or. use(i2) .or. & use(k1) .or. use(k2)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) if (use_polymer) call imager (xk,yk,zk,-1) xr = xq - x(k1) - xk*sdpl(k) yr = yq - y(k1) - yk*sdpl(k) zr = zq - z(k1) - zk*sdpl(k) call imager (xr,yr,zr,j) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. off2) then rk2 = xk*xk + yk*yk + zk*zk rirkr3 = sqrt(ri2*rk2*r2) * r2 dotp = xi*xk + yi*yk + zi*zk doti = xi*xr + yi*yr + zi*zr dotk = xk*xr + yk*yr + zk*zr fik = fi * bdpl(k) if (use_polymer) then if (r2 .lt. polycut2) then if (k1.eq.i1 .or. k1.eq.i2 .or. & k2.eq.i1 .or. k2.eq.i2) fik = 0.0d0 end if end if e = fik * (dotp-3.0d0*doti*dotk/r2) / rirkr3 c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r = sqrt(r2) r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall dipole-dipole energy component c if (e .ne. 0.0d0) ned = ned + 1 if (i .eq. k) then ed = ed + 0.5d0*e aed(i1) = aed(i1) + 0.25d0*e aed(i2) = aed(i2) + 0.25d0*e else ed = ed + e aed(i1) = aed(i1) + 0.25d0*e aed(i2) = aed(i2) + 0.25d0*e aed(k1) = aed(k1) + 0.25d0*e aed(k2) = aed(k2) + 0.25d0*e end if 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. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual Dipole-Dipole', & ' Interactions :', & //,' Type',15x,'Dipole 1',14x, & 'Dipole 2',8x,'Distance', & 6x,'Energy',/) end if write (iout,50) i1,name(i1),i2,name(i2), & k1,name(k1),k2,name(k2), & sqrt(r2),e 50 format (' Dipole',4x,4(i7,'-',a3),f11.4,f12.4) end if end if end do end if end do end do return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################ c ## ## c ## subroutine edisp -- damped dispersion potential energy ## c ## ## c ################################################################ c c c "edisp" calculates the damped dispersion potential energy c c literature reference: c c J. A. Rackers, C. Liu, P. Ren and J. W. Ponder, "A Physically c Grounded Damped Dispersion Model with Particle Mesh Ewald c Summation", Journal of Chemical Physics, 149, 084115 (2018) c c subroutine edisp use dsppot use energi use ewald use limits implicit none real*8 elrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_dewald) then if (use_dlist) then call edisp0d else call edisp0c end if else if (use_dlist) then call edisp0b else call edisp0a end if end if c c apply long range dispersion correction if desired c if (use_dcorr .and. .not.use_dewald) then mode = 'DISP' call evcorr (mode,elrc) edsp = edsp + elrc end if return end c c c ################################################################# c ## ## c ## subroutine edisp0a -- damped dispersion via double loop ## c ## ## c ################################################################# c c c "edisp0a" calculates the damped dispersion potential energy c using a pairwise double loop c c subroutine edisp0a use atoms use bound use boxes use couple use cell use disp use dsppot use energi use group use mutant use shunt use usage implicit none integer i,j,k integer ii,kk integer jcell real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,fgrp real*8 ci,ck real*8 r,r2,r3 real*8 r4,r5,r6 real*8 ai,ai2 real*8 ak,ak2 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 damp3,damp5 real*8 damp,taper real*8 vterm real*8, allocatable :: dspscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c zero out the total damped dispersion energy c edsp = 0.0d0 if (ndisp .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DISP' call switch (mode) c c find the damped dispersion energy via double loop search c do ii = 1, ndisp-1 i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii+1, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c e = e * dspscale(k) * damp**2 if (use_group) e = e * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then e = e * vterm else if (.not.muti .or. .not.mutk) then e = e * vterm end if end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper end if c c increment the overall damped dispersion energy component c edsp = edsp + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 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, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then do jcell = 2, 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) r6 = r2**3 e = -ci * ck / r6 c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c e = e * damp**2 if (use_polymer) then if (r2 .le. polycut2) e = e * dspscale(k) end if if (use_group) e = e * fgrp if (i .eq. k) e = 0.5d0 * e c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then e = e * vterm else if (.not.muti .or. .not.mutk) then e = e * vterm end if end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper end if c c increment the overall damped dispersion energy component c edsp = edsp + e end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ################################################################# c ## ## c ## subroutine edisp0b -- damp dispersion via neighbor list ## c ## ## c ################################################################# c c c "edisp0b" calculates the damped dispersion potential energy c using a pairwise neighbor list c c subroutine edisp0b use atoms use bound use boxes use couple use cell use disp use dsppot use energi use group use mutant use neigh use shunt use usage implicit none integer i,j,k integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,fgrp real*8 ci,ck real*8 r,r2,r3 real*8 r4,r5,r6 real*8 ai,ai2 real*8 ak,ak2 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 damp3,damp5 real*8 damp,taper real*8 vterm real*8, allocatable :: dspscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c zero out the total damped dispersion energy c edsp = 0.0d0 if (ndisp .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DISP' call switch (mode) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use, !$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group, !$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,cut2, !$OMP& c0,c1,c2,c3,c4,c5,vcouple,vterm) !$OMP& firstprivate(dspscale) shared(edsp) !$OMP DO reduction(+:edsp) schedule(guided) c c find the damped dispersion energy via neighbor list search c do ii = 1, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c e = e * dspscale(k) * damp**2 if (use_group) e = e * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then e = e * vterm else if (.not.muti .or. .not.mutk) then e = e * vterm end if end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper end if c c increment the overall dispersion energy component c edsp = edsp + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ################################################################ c ## ## c ## subroutine edisp0c -- Ewald dispersion energy via loop ## c ## ## c ################################################################ c c c "edisp0c" calculates the dispersion interaction energy using c particle mesh Ewald summation and a double loop c c subroutine edisp0c use disp use energi use ewald use pme implicit none integer i,ii real*8 e c c c zero out the total damped dispersion energy c edsp = 0.0d0 if (ndisp .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = ndfft1 nfft2 = ndfft2 nfft3 = ndfft3 bsorder = bsdorder aewald = adewald c c compute the real space portion of the Ewald summation c call edreal0c c c compute the reciprocal space part of the Ewald summation c call edrecip c c compute the self-energy portion of the Ewald summation c do ii = 1, ndisp i = idisp(i) e = csix(i)**2 * aewald**6 / 12.0d0 edsp = edsp + e end do return end c c c ############################################################### c ## ## c ## subroutine edreal0c -- real space dispersion via loop ## c ## ## c ############################################################### c c c "edreal0c" calculates the damped dispersion potential energy c using a particle mesh Ewald sum and pairwise double loop c c subroutine edreal0c use atoms use bound use boxes use couple use cell use disp use dsppot use energi use ewald use group use mutant use shunt use usage implicit none integer i,j,k integer ii,kk integer jcell real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,fgrp real*8 ci,ck real*8 r,r2,r6 real*8 ai,ai2 real*8 ak,ak2 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 ralpha2 real*8 expa,term real*8 damp3,damp5 real*8 damp,scale real*8 vterm real*8, allocatable :: dspscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DEWALD' call switch (mode) c c compute the real space portion of the Ewald summation c do ii = 1, ndisp-1 i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii+1, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 ralpha2 = r2 * aewald**2 term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2 expa = exp(-ralpha2) * term c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c scale = dspscale(k) * damp**2 if (use_group) scale = scale * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then scale = scale * vterm else if (.not.muti .or. .not.mutk) then scale = scale * vterm end if end if c c increment the overall dispersion energy component c scale = scale - 1.0d0 e = e * (expa+scale) edsp = edsp + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 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, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then do jcell = 2, 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) r6 = r2**3 e = -ci * ck / r6 ralpha2 = r2 * aewald**2 term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2 expa = exp(-ralpha2) * term c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c scale = damp**2 if (use_group) scale = scale * fgrp if (use_polymer) then if (r2 .le. polycut2) then scale = scale * dspscale(k) end if end if c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then scale = scale * vterm else if (.not.muti .or. .not.mutk) then scale = scale * vterm end if end if c c increment the overall dispersion energy component c scale = scale - 1.0d0 e = e * (expa+scale) if (i .eq. k) e = 0.5d0 * e edsp = edsp + e end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ################################################################ c ## ## c ## subroutine edisp0d -- Ewald dispersion energy via list ## c ## ## c ################################################################ c c c "edisp0d" calculates the dispersion interaction energy using c particle mesh Ewald summation and a neighbor list c c subroutine edisp0d use disp use energi use ewald use pme implicit none integer i,ii real*8 e c c c zero out the total damped dispersion energy c edsp = 0.0d0 if (ndisp .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = ndfft1 nfft2 = ndfft2 nfft3 = ndfft3 bsorder = bsdorder aewald = adewald c c compute the real space portion of the Ewald summation c call edreal0d c c compute the reciprocal space part of the Ewald summation c call edrecip c c compute the self-energy portion of the Ewald summation c do ii = 1, ndisp i = idisp(ii) e = csix(i)**2 * aewald**6 / 12.0d0 edsp = edsp + e end do return end c c c ############################################################### c ## ## c ## subroutine edreal0d -- real space dispersion via list ## c ## ## c ############################################################### c c c "edreal0d" evaluated the real space portion of the damped c dispersion energy using a neighbor list c c subroutine edreal0d use atoms use bound use boxes use couple use cell use disp use dsppot use energi use ewald use group use mutant use neigh use shunt use usage implicit none integer i,j,k integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,fgrp real*8 ci,ck real*8 r,r2,r6 real*8 ai,ai2 real*8 ak,ak2 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 ralpha2 real*8 expa,term real*8 damp3,damp5 real*8 damp,scale real*8 vterm real*8, allocatable :: dspscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DEWALD' call switch (mode) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use, !$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group, !$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,aewald, !$OMP& vcouple,vterm) !$OMP& firstprivate(dspscale) shared(edsp) !$OMP DO reduction(+:edsp) schedule(guided) c c compute the real space portion of the Ewald summation c do ii = 1, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 ralpha2 = r2 * aewald**2 term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2 expa = exp(-ralpha2) * term c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c scale = dspscale(k) * damp**2 if (use_group) scale = scale * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then scale = scale * vterm else if (.not.muti .or. .not.mutk) then scale = scale * vterm end if end if c c increment the overall dispersion energy component c scale = scale - 1.0d0 e = e * (expa+scale) edsp = edsp + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ################################################################# c ## ## c ## subroutine edrecip -- PME recip space damped dispersion ## c ## ## c ################################################################# c c c "edrecip" evaluates the reciprocal space portion of the particle c mesh Ewald energy due to damped dispersion c c subroutine edrecip use boxes use bound use disp use energi use ewald use math use pme implicit none integer i,j integer k1,k2,k3 integer m1,m2,m3 integer ntot,nff integer nf1,nf2,nf3 real*8 e,denom real*8 r1,r2,r3 real*8 h1,h2,h3 real*8 term,expterm real*8 eterm,denom0 real*8 hsq,struc2 real*8 h,hhh,b,bfac real*8 fac1,fac2,fac3 real*8 erfcterm 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 global arrays c ntot = nfft1 * nfft2 * nfft3 if (allocated(qgrid)) then if (size(qgrid) .ne. 2*ntot) call fftclose end if if (.not. allocated(qgrid)) call fftsetup c c setup spatial decomposition and B-spline coefficients c call getchunk call moduli call bspline_fill call table_fill c c assign PME grid and perform 3-D FFT forward transform c call grid_disp call fftfront c c use scalar sum to get the reciprocal space energy c bfac = pi / aewald fac1 = 2.0d0 * pi**(3.5d0) fac2 = aewald**3 fac3 = -2.0d0 * aewald * pi**2 denom0 = (6.0d0*volbox) / (pi**1.5d0) nf1 = (nfft1+1) / 2 nf2 = (nfft2+1) / 2 nf3 = (nfft3+1) / 2 nff = nfft1 * nfft2 ntot = nff * nfft3 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 h = sqrt(hsq) b = h * bfac hhh = h * hsq term = -b * b if (term .gt. -50.0d0) then denom = denom0 * bsmod1(k1) * bsmod2(k2) * bsmod3(k3) expterm = exp(term) erfcterm = erfc(b) if (.not. use_bounds) then expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) erfcterm = erfcterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) else if (nonprism) then if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 if (mod(m1+m2+m3,2) .ne. 0) erfcterm = 0.0d0 end if eterm = (-fac1*erfcterm*hhh-expterm*(fac2+fac3*hsq))/denom struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2 e = eterm * struc2 edsp = edsp + e end if end do c c account for the total energy correction term c e = -csixpr * aewald**3 / denom0 edsp = edsp + e return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################ c ## ## c ## subroutine edisp1 -- damped dispersion energy & derivs ## c ## ## c ################################################################ c c c "edisp1" calculates the damped dispersion energy and first c derivatives with respect to Cartesian coordinates c c literature reference: c c J. A. Rackers, C. Liu, P. Ren and J. W. Ponder, "A Physically c Grounded Damped Dispersion Model with Particle Mesh Ewald c Summation", Journal of Chemical Physics, 149, 084115 (2018) c c subroutine edisp1 use dsppot use energi use ewald use limits use virial implicit none real*8 elrc,vlrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_dewald) then if (use_dlist) then call edisp1d else call edisp1c end if else if (use_dlist) then call edisp1b else call edisp1a end if end if c c apply long range dispersion correction if desired c if (use_dcorr .and. .not.use_dewald) then mode = 'DISP' call evcorr1 (mode,elrc,vlrc) edsp = edsp + elrc vir(1,1) = vir(1,1) + vlrc vir(2,2) = vir(2,2) + vlrc vir(3,3) = vir(3,3) + vlrc end if return end c c c ############################################################# c ## ## c ## subroutine edisp1a -- double loop dispersion derivs ## c ## ## c ############################################################# c c c "edisp1a" calculates the damped dispersion energy and c derivatives with respect to Cartesian coordinates using c a pairwise double loop c c subroutine edisp1a use atoms use bound use cell use couple use deriv use disp use dsppot use energi use group use mutant use shunt use usage use virial implicit none integer i,j,k integer ii,kk integer jcell real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,de,fgrp real*8 ci,ck real*8 r,r2,r3 real*8 r4,r5,r6 real*8 ai,ai2,ai3 real*8 ak,ak2,ak3 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 damp3,damp5 real*8 damp,ddamp real*8 vterm real*8 taper,dtaper real*8 dedx,dedy,dedz real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: dspscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c zero out the dispersion energy and derivatives c edsp = 0.0d0 do i = 1, n dedsp(1,i) = 0.0d0 dedsp(2,i) = 0.0d0 dedsp(3,i) = 0.0d0 end do if (ndisp .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DISP' call switch (mode) c c find dispersion energy and derivatives via double loop c do ii = 1, ndisp-1 i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii+1, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 de = -6.0d0 * e / r c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ai3 = ai * ai2 ak2 = ak * ak ak3 = ak * ak2 dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) tk = ai2 / (ai2-ak2) ti2 = ti * ti tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk ddamp = 0.25d0 * di2 * ti2 * ai * expi & * (r*ai+4.0d0*tk-1.0d0) & + 0.25d0 * dk2 * tk2 * ak * expk & * (r*ak+4.0d0*ti-1.0d0) else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2) & / 96.0d0 end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then de = de * vterm e = e * vterm else if (.not.muti .or. .not.mutk) then de = de * vterm e = e * vterm end if end if c c apply damping and scaling factors for this interaction c de = de*damp**2 + 2.0d0*e*damp*ddamp e = e * damp**2 e = e * dspscale(k) de = de * dspscale(k) if (use_group) then e = e * fgrp de = de * fgrp end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 de = e*dtaper + de*taper e = e * taper end if c c increment the overall damped dispersion energy component c edsp = edsp + e c c increment the damped dispersion derivative components c dedx = de * xr/r dedy = de * yr/r dedz = de * zr/r dedsp(1,i) = dedsp(1,i) + dedx dedsp(2,i) = dedsp(2,i) + dedy dedsp(3,i) = dedsp(3,i) + dedz dedsp(1,k) = dedsp(1,k) - dedx dedsp(2,k) = dedsp(2,k) - dedy dedsp(3,k) = dedsp(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 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, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then do jcell = 2, 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) r6 = r2**3 e = -ci * ck / r6 de = -6.0d0 * e / r c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ai3 = ai * ai2 ak2 = ak * ak ak3 = ak * ak2 dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) tk = ai2 / (ai2-ak2) ti2 = ti * ti tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk ddamp = 0.25d0 * di2 * ti2 * ai * expi & * (r*ai+4.0d0*tk-1.0d0) & + 0.25d0 * dk2 * tk2 * ak * expk & * (r*ak+4.0d0*ti-1.0d0) else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2) & / 96.0d0 end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then de = de * vterm e = e * vterm else if (.not.muti .or. .not.mutk) then de = de * vterm e = e * vterm end if end if c c apply damping and scaling factors for this interaction c de = de*damp**2 + 2.0d0*e*damp*ddamp e = e * damp**2 if (use_polymer) then if (r2 .le. polycut2) then e = e * dspscale(k) de = de * dspscale(k) end if end if if (use_group) then e = e * fgrp de = de * fgrp end if if (i .eq. k) then e = 0.5d0 * e de = 0.5d0 * de end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 de = e*dtaper + de*taper e = e * taper end if c c increment the overall damped dispersion energy component c edsp = edsp + e c c increment the damped dispersion derivative components c dedx = de * xr/r dedy = de * yr/r dedz = de * zr/r dedsp(1,i) = dedsp(1,i) + dedx dedsp(2,i) = dedsp(2,i) + dedy dedsp(3,i) = dedsp(3,i) + dedz dedsp(1,k) = dedsp(1,k) - dedx dedsp(2,k) = dedsp(2,k) - dedy dedsp(3,k) = dedsp(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ############################################################### c ## ## c ## subroutine edisp1b -- neighbor list dispersion derivs ## c ## ## c ############################################################### c c c "edisp1b" calculates the damped dispersion energy and c derivatives with respect to Cartesian coordinates using c a pairwise neighbor list c c subroutine edisp1b use atoms use bound use cell use couple use deriv use disp use dsppot use energi use group use mutant use neigh use shunt use usage use virial implicit none integer i,j,k integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,de,fgrp real*8 ci,ck real*8 r,r2,r3 real*8 r4,r5,r6 real*8 ai,ai2,ai3 real*8 ak,ak2,ak3 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 damp3,damp5 real*8 damp,ddamp real*8 vterm real*8 taper,dtaper real*8 dedx,dedy,dedz real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: dspscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c zero out the dispersion energy and derivatives c edsp = 0.0d0 do i = 1, n dedsp(1,i) = 0.0d0 dedsp(2,i) = 0.0d0 dedsp(3,i) = 0.0d0 end do if (ndisp .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DISP' call switch (mode) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use, !$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group, !$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,cut2, !$OMP& c0,c1,c2,c3,c4,c5,vcouple,vterm) !$OMP& firstprivate(dspscale) shared(edsp,dedsp,vir) !$OMP DO reduction(+:edsp,dedsp,vir) schedule(guided) c c find dispersion energy and derivatives via neighbor list c do ii = 1, ndisp-1 i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 de = -6.0d0 * e / r c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ai3 = ai * ai2 ak2 = ak * ak ak3 = ak * ak2 dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) tk = ai2 / (ai2-ak2) ti2 = ti * ti tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk ddamp = 0.25d0 * di2 * ti2 * ai * expi & * (r*ai+4.0d0*tk-1.0d0) & + 0.25d0 * dk2 * tk2 * ak * expk & * (r*ak+4.0d0*ti-1.0d0) else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2) & / 96.0d0 end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then de = de * vterm e = e * vterm else if (.not.muti .or. .not.mutk) then de = de * vterm e = e * vterm end if end if c c apply damping and scaling factors for this interaction c de = de*damp**2 + 2.0d0*e*damp*ddamp e = e * damp**2 e = e * dspscale(k) de = de * dspscale(k) if (use_group) then e = e * fgrp de = de * fgrp end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 de = e*dtaper + de*taper e = e * taper end if c c increment the overall damped dispersion energy component c edsp = edsp + e c c increment the damped dispersion derivative components c dedx = de * xr/r dedy = de * yr/r dedz = de * zr/r dedsp(1,i) = dedsp(1,i) + dedx dedsp(2,i) = dedsp(2,i) + dedy dedsp(3,i) = dedsp(3,i) + dedz dedsp(1,k) = dedsp(1,k) - dedx dedsp(2,k) = dedsp(2,k) - dedy dedsp(3,k) = dedsp(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ################################################################ c ## ## c ## subroutine edisp1c -- Ewald dispersion derivs via loop ## c ## ## c ################################################################ c c c "edisp1c" calculates the damped dispersion energy and c derivatives with respect to Cartesian coordinates using c particle mesh Ewald summation and a double loop c c subroutine edisp1c use atoms use deriv use disp use energi use ewald use pme implicit none integer i,ii real*8 e c c c zero out the dispersion energy and derivatives c edsp = 0.0d0 do i = 1, n dedsp(1,i) = 0.0d0 dedsp(2,i) = 0.0d0 dedsp(3,i) = 0.0d0 end do if (ndisp .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = ndfft1 nfft2 = ndfft2 nfft3 = ndfft3 bsorder = bsdorder aewald = adewald c c compute the real space portion of the Ewald summation c call edreal1c c c compute the reciprocal space part of the Ewald summation c call edrecip1 c c compute the self-energy portion of the Ewald summation c do ii = 1, ndisp i = idisp(ii) e = csix(i)**2 * aewald**6 / 12.0d0 edsp = edsp + e end do return end c c c ################################################################ c ## ## c ## subroutine edreal1c -- Ewald real disp derivs via loop ## c ## ## c ################################################################ c c c "edreal1c" evaluates the real space portion of the Ewald c summation energy and gradient due to damped dispersion c interactions via a double loop c c subroutine edreal1c use atoms use bound use boxes use couple use cell use disp use dsppot use deriv use energi use ewald use group use mutant use shunt use usage use virial implicit none integer i,j,k integer ii,kk integer jcell real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,de,fgrp real*8 ci,ck real*8 r,r2,r6,r7 real*8 ai,ai2 real*8 ak,ak2 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 damp3,damp5 real*8 damp,ddamp real*8 vterm real*8 ralpha2,scale real*8 expterm,term real*8 expa,rterm real*8 dedx,dedy,dedz real*8 vxx,vyx,vzx real*8 vyy,vzy,vzz real*8, allocatable :: dspscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DEWALD' call switch (mode) c c compute the real space portion of the Ewald summation c do ii = 1, ndisp-1 i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii+1, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r6 = r2**3 e = -ci * ck / r6 ralpha2 = r2 * aewald**2 term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2 expterm = exp(-ralpha2) expa = expterm * term c c find the damping factor for the dispersion interaction c r = sqrt(r2) r7 = r6 * r di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk ddamp = 0.25d0 * di2 * ti2 * ai * expi & * (r*ai+4.0d0*tk-1.0d0) & + 0.25d0 * dk2 * tk2 * ak * expk & * (r*ak+4.0d0*ti-1.0d0) else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2) & / 96.0d0 end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c scale = dspscale(k) * damp**2 if (use_group) scale = scale * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then scale = scale * vterm ddamp = ddamp * vterm else if (.not.muti .or. .not.mutk) then scale = scale * vterm ddamp = ddamp * vterm end if end if c c increment the overall damped dispersion energy component c scale = scale - 1.0d0 e = e * (expa+scale) edsp = edsp + e c c increment the damped dispersion derivative components c rterm = -(ralpha2**3) * expterm / r de = -6.0d0*e/r2 - ci*ck*rterm/r7 & - 2.0d0*ci*ck*dspscale(k)*damp*ddamp/r7 dedx = de * xr dedy = de * yr dedz = de * zr dedsp(1,i) = dedsp(1,i) + dedx dedsp(2,i) = dedsp(2,i) + dedy dedsp(3,i) = dedsp(3,i) + dedz dedsp(1,k) = dedsp(1,k) - dedx dedsp(2,k) = dedsp(2,k) - dedy dedsp(3,k) = dedsp(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 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, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then do jcell = 2, 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 r6 = r2**3 e = -ci * ck / r6 ralpha2 = r2 * aewald**2 term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2 expterm = exp(-ralpha2) expa = expterm * term c c find the damping factor for the dispersion interaction c r = sqrt(r2) r7 = r6 * r di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk ddamp = 0.25d0 * di2 * ti2 * ai * expi & * (r*ai+4.0d0*tk-1.0d0) & + 0.25d0 * dk2 * tk2 * ak * expk & * (r*ak+4.0d0*ti-1.0d0) else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2) & / 96.0d0 end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c scale = dspscale(k) * damp**2 if (use_group) scale = scale * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then scale = scale * vterm ddamp = ddamp * vterm else if (.not.muti .or. .not.mutk) then scale = scale * vterm ddamp = ddamp * vterm end if end if c c increment the overall damped dispersion energy component c scale = scale - 1.0d0 e = e * (expa+scale) rterm = -(ralpha2**3) * expterm / r de = -6.0d0*e/r2 - ci*ck*rterm/r7 & - 2.0d0*ci*ck*dspscale(k)*damp*ddamp/r7 if (ii .eq. kk) then e = 0.5d0 * e de = 0.5d0 * de end if edsp = edsp + e c c increment the damped dispersion derivative components c dedx = de * xr dedy = de * yr dedz = de * zr dedsp(1,i) = dedsp(1,i) + dedx dedsp(2,i) = dedsp(2,i) + dedy dedsp(3,i) = dedsp(3,i) + dedz dedsp(1,k) = dedsp(1,k) - dedx dedsp(2,k) = dedsp(2,k) - dedy dedsp(3,k) = dedsp(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (dspscale) stop return end c c c ################################################################ c ## ## c ## subroutine edisp1d -- Ewald dispersion derivs via list ## c ## ## c ################################################################ c c c "edisp1d" calculates the damped dispersion energy and c derivatives with respect to Cartesian coordinates using c particle mesh Ewald summation and a neighbor list c c subroutine edisp1d use atoms use deriv use disp use energi use ewald use pme implicit none integer i,ii real*8 e c c c zero out the dispersion energy and derivatives c edsp = 0.0d0 do i = 1, n dedsp(1,i) = 0.0d0 dedsp(2,i) = 0.0d0 dedsp(3,i) = 0.0d0 end do if (ndisp .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = ndfft1 nfft2 = ndfft2 nfft3 = ndfft3 bsorder = bsdorder aewald = adewald c c compute the real space portion of the Ewald summation c call edreal1d c c compute the reciprocal space part of the Ewald summation c call edrecip1 c c compute the self-energy portion of the Ewald summation c do ii = 1, ndisp i = idisp(ii) e = csix(i)**2 * aewald**6 / 12.0d0 edsp = edsp + e end do return end c c c ################################################################ c ## ## c ## subroutine edreal1d -- Ewald real disp derivs via list ## c ## ## c ################################################################ c c c "edreal1d" evaluates the real space portion of the Ewald c summation energy and gradient due to damped dispersion c interactions via a neighbor list c c subroutine edreal1d use atoms use bound use boxes use couple use cell use deriv use disp use dsppot use energi use ewald use group use mutant use neigh use shunt use usage use virial implicit none integer i,j,k integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,de,fgrp real*8 ci,ck real*8 r,r2,r6,r7 real*8 ai,ai2 real*8 ak,ak2 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 damp3,damp5 real*8 damp,ddamp real*8 vterm real*8 ralpha2,scale real*8 expterm,term real*8 expa,rterm real*8 dedx,dedy,dedz real*8 vxx,vyx,vzx real*8 vyy,vzy,vzz real*8, allocatable :: dspscale(:) logical proceed,usei logical muti,mutk character*6 mode c c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DEWALD' call switch (mode) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use, !$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group, !$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,aewald, !$OMP& vcouple,vterm) !$OMP& firstprivate(dspscale) shared(edsp,dedsp,vir) !$OMP DO reduction(+:edsp,dedsp,vir) schedule(guided) c c compute the real space portion of the Ewald summation c do ii = 1, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r6 = r2**3 e = -ci * ck / r6 ralpha2 = r2 * aewald**2 term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2 expterm = exp(-ralpha2) expa = expterm * term c c find the damping factor for the dispersion interaction c r = sqrt(r2) r7 = r6 * r di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk ddamp = 0.25d0 * di2 * ti2 * ai * expi & * (r*ai+4.0d0*tk-1.0d0) & + 0.25d0 * dk2 * tk2 * ak * expk & * (r*ak+4.0d0*ti-1.0d0) else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi ddamp = ai * expi * (di5-3.0d0*di3-3.0d0*di2) & / 96.0d0 end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c scale = dspscale(k) * damp**2 if (use_group) scale = scale * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then scale = scale * vterm ddamp = ddamp * vterm else if (.not.muti .or. .not.mutk) then scale = scale * vterm ddamp = ddamp * vterm end if end if c c increment the overall damped dispersion energy component c scale = scale - 1.0d0 e = e * (expa+scale) edsp = edsp + e c c increment the damped dispersion derivative components c rterm = -(ralpha2**3) * expterm / r de = -6.0d0*e/r2 - ci*ck*rterm/r7 & - 2.0d0*ci*ck*dspscale(k)*damp*ddamp/r7 dedx = de * xr dedy = de * yr dedz = de * zr dedsp(1,i) = dedsp(1,i) + dedx dedsp(2,i) = dedsp(2,i) + dedy dedsp(3,i) = dedsp(3,i) + dedz dedsp(1,k) = dedsp(1,k) - dedx dedsp(2,k) = dedsp(2,k) - dedy dedsp(3,k) = dedsp(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ############################################################### c ## ## c ## subroutine edrecip1 -- PME recip disp energy & derivs ## c ## ## c ############################################################### c c c "edrecip1" evaluates the reciprocal space portion of particle c mesh Ewald energy and gradient due to damped dispersion c c subroutine edrecip1 use boxes use bound use disp use deriv use energi use ewald use math use pme use virial implicit none integer i,j,k,ii integer k1,k2,k3 integer m1,m2,m3 integer nf1,nf2,nf3 integer nff,ntot integer i0,iatm,igrd0 integer it1,it2,it3 integer j0,jgrd0 integer k0,kgrd0 real*8 e,fi,denom real*8 r1,r2,r3 real*8 h1,h2,h3 real*8 term,denom0 real*8 eterm,vterm real*8 expterm real*8 erfcterm real*8 hsq,struc2 real*8 h,hhh,b,bfac real*8 fac1,fac2,fac3 real*8 de1,de2,de3 real*8 dn1,dn2,dn3 real*8 dt1,dt2,dt3 real*8 t1,t2,t3 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 global arrays c ntot = nfft1 * nfft2 * nfft3 if (allocated(qgrid)) then if (size(qgrid) .ne. 2*ntot) call fftclose end if if (.not. allocated(qgrid)) call fftsetup c c setup spatial decomposition and B-spline coefficients c call getchunk call moduli call bspline_fill call table_fill c c assign PME grid and perform 3-D FFT forward transform c call grid_disp call fftfront c c use scalar sum to get the reciprocal space energy c qgrid(1,1,1,1) = 0.0d0 qgrid(2,1,1,1) = 0.0d0 bfac = pi / aewald fac1 = 2.0d0*pi**(3.5d0) fac2 = aewald**3 fac3 = -2.0d0*aewald*pi**2 denom0 = (6.0d0*volbox)/(pi**1.5d0) nf1 = (nfft1+1) / 2 nf2 = (nfft2+1) / 2 nf3 = (nfft3+1) / 2 nff = nfft1 * nfft2 ntot = nff * nfft3 do i = 1, ntot-1 k3 = i/nff + 1 j = i - (k3-1)*nff k2 = j/ndfft1 + 1 k1 = j - (k2-1)*ndfft1 + 1 m1 = k1 - 1 m2 = k2 - 1 m3 = k3 - 1 if (k1 .gt. nf1) m1 = m1 - ndfft1 if (k2 .gt. nf2) m2 = m2 - ndfft2 if (k3 .gt. nf3) m3 = m3 - ndfft3 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 h = sqrt(hsq) b = h*bfac hhh = h*hsq term = -b*b eterm = 0.0d0 denom = denom0*bsmod1(k1)*bsmod2(k2)*bsmod3(k3) if (term .gt. -50.0d0) then expterm = exp(term) erfcterm = erfc(b) if (.not. use_bounds) then expterm = expterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) erfcterm = erfcterm * (1.0d0-cos(pi*xbox*sqrt(hsq))) else if (nonprism) then if (mod(m1+m2+m3,2) .ne. 0) expterm = 0.0d0 if (mod(m1+m2+m3,2) .ne. 0) erfcterm = 0.0d0 end if eterm = (-fac1*erfcterm*hhh - expterm*(fac2+fac3*hsq))/denom struc2 = qgrid(1,k1,k2,k3)**2 + qgrid(2,k1,k2,k3)**2 vterm = 3.0d0*(fac1*erfcterm*h + fac3*expterm)*struc2/denom e = eterm * struc2 edsp = edsp + e vir(1,1) = vir(1,1) + h1*h1*vterm - e vir(2,1) = vir(2,1) + h1*h2*vterm vir(3,1) = vir(3,1) + h1*h3*vterm vir(1,2) = vir(1,2) + h2*h1*vterm vir(2,2) = vir(2,2) + h2*h2*vterm - e vir(3,2) = vir(3,2) + h2*h3*vterm vir(1,3) = vir(1,3) + h3*h1*vterm vir(2,3) = vir(2,3) + h3*h2*vterm vir(3,3) = vir(3,3) + h3*h3*vterm - e end if qgrid(1,k1,k2,k3) = eterm * qgrid(1,k1,k2,k3) qgrid(2,k1,k2,k3) = eterm * qgrid(2,k1,k2,k3) end do c c perform the 3-D FFT backward transformation c call fftback c c get first derivatives of the reciprocal space energy c dn1 = dble(ndfft1) dn2 = dble(ndfft2) dn3 = dble(ndfft3) do ii = 1, ndisp iatm = idisp(ii) igrd0 = igrid(1,iatm) jgrd0 = igrid(2,iatm) kgrd0 = igrid(3,iatm) fi = csix(iatm) de1 = 0.0d0 de2 = 0.0d0 de3 = 0.0d0 k0 = kgrd0 do it3 = 1, bsorder k0 = k0 + 1 k = k0 + 1 + (ndfft3-sign(ndfft3,k0))/2 t3 = thetai3(1,it3,iatm) dt3 = dn3 * thetai3(2,it3,iatm) j0 = jgrd0 do it2 = 1, bsorder j0 = j0 + 1 j = j0 + 1 + (ndfft2-sign(ndfft2,j0))/2 t2 = thetai2(1,it2,iatm) dt2 = dn2 * thetai2(2,it2,iatm) i0 = igrd0 do it1 = 1, bsorder i0 = i0 + 1 i = i0 + 1 + (ndfft1-sign(ndfft1,i0))/2 t1 = thetai1(1,it1,iatm) dt1 = dn1 * thetai1(2,it1,iatm) term = qgrid(1,i,j,k) de1 = de1 + 2.0d0*term*dt1*t2*t3 de2 = de2 + 2.0d0*term*dt2*t1*t3 de3 = de3 + 2.0d0*term*dt3*t1*t2 end do end do end do dedsp(1,iatm) = dedsp(1,iatm) + fi*(recip(1,1)*de1 & +recip(1,2)*de2+recip(1,3)*de3) dedsp(2,iatm) = dedsp(2,iatm) + fi*(recip(2,1)*de1 & +recip(2,2)*de2+recip(2,3)*de3) dedsp(3,iatm) = dedsp(3,iatm) + fi*(recip(3,1)*de1 & +recip(3,2)*de2+recip(3,3)*de3) end do c c account for the energy and virial correction terms c term = csixpr * aewald**3 / denom0 edsp = edsp - term vir(1,1) = vir(1,1) + term vir(2,2) = vir(2,2) + term vir(3,3) = vir(3,3) + term return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################# c ## ## c ## subroutine edisp2 -- atomwise damped dispersion Hessian ## c ## ## c ################################################################# c c c "edisp2" calculates the damped dispersion second derivatives c for a single atom at a time c c literature reference: c c J. A. Rackers, C. Liu, P. Ren and J. W. Ponder, "A Physically c Grounded Damped Dispersion Model with Particle Mesh Ewald c Summation", Journal of Chemical Physics, 149, 084115 (2018) c c subroutine edisp2 (iatom) use atoms use bound use cell use couple use disp use dsppot use group use hessn use shunt use usage implicit none integer i,j,k integer ii,kk integer iatom,jcell integer nlist,list(5) real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,de,d2e real*8 ci,ck,fgrp real*8 r,r2,r3 real*8 r4,r5,r6 real*8 ai,ai2 real*8 ai3,ai4 real*8 ak,ak2 real*8 ak3,ak4 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 damp3,damp5 real*8 damp,ddamp real*8 ddampi,ddampk real*8 d2damp real*8 taper,dtaper real*8 d2taper real*8 d2edx,d2edy,d2edz real*8 term(3,3) real*8, allocatable :: dspscale(:) logical proceed,usei character*6 mode c c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set cutoff and switching coefficients c mode = 'DISP' call switch (mode) c c check to see if atom of interest is a dispersion site c nlist = 0 do k = 1, ndisp if (idisp(k) .eq. iatom) then nlist = nlist + 1 list(nlist) = iatom goto 10 end if end do return 10 continue c c calculate the dispersion energy Hessian elements c do ii = 1, nlist i = list(ii) xi = x(i) yi = y(i) zi = z(i) ci = csix(i) ai = adisp(i) usei = use(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c evaluate all sites within the cutoff distance c do kk = 1, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (k .ne. i) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 de = -6.0d0 * e / r d2e = -7.0d0 * de / r c c find the damping factor for the dispersion interaction c ai2 = ai * ai di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai3 = ai * ai2 ai4 = ai2 * ai2 ak2 = ak * ak ak3 = ak * ak2 ak4 = ak2 * ak2 dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) tk = ai2 / (ai2-ak2) ti2 = ti * ti tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk ddampi = 0.25d0 * di2 * ti2 * ai * expi & * (r*ai+4.0d0*tk-1.0d0) ddampk = 0.25d0 * dk2 * tk2 * ak * expk & * (r*ak+4.0d0*ti-1.0d0) ddamp = ddampi + ddampk d2damp = 2.0d0*ddamp/r - ai*ddampi - ak*ddampk & + 0.25d0*di2*ti2*ai2*expi & + 0.25d0*dk2*tk2*ak2*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi ddamp = (di5-3.0d0*di3-3.0d0*di2) & *ai*expi/96.0d0 d2damp = (5.0d0*di4-9.0d0*di2-6.0d0*di) & *ai2*expi/96.0d0 - ai*ddamp end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c d2e = d2e*damp**2 + 4.0d0*de*damp*ddamp & + 2.0d0*e*(ddamp**2+damp*d2damp) de = de*damp**2 + 2.0d0*e*damp*ddamp e = e * damp**2 c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper de = e*dtaper + de*taper end if c c scale the interaction based on its group membership c de = de * dspscale(k) d2e = d2e * dspscale(k) if (use_group) then de = de * fgrp d2e = d2e * fgrp end if c c get chain rule terms for damped dispersion Hessian elements 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 reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 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, nlist i = list(ii) xi = x(i) yi = y(i) zi = z(i) ci = csix(i) ai = adisp(i) usei = use(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c evaluate all sites within the cutoff distance c do kk = 1, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) if (proceed) then do jcell = 2, ncell 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 de = -6.0d0 * e / r d2e = -7.0d0 * de / r c c find the damping factor for the dispersion interaction c ai2 = ai * ai di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai3 = ai * ai2 ai4 = ai2 * ai2 ak2 = ak * ak ak3 = ak * ak2 ak4 = ak2 * ak2 dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) tk = ai2 / (ai2-ak2) ti2 = ti * ti tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk ddampi = 0.25d0 * di2 * ti2 * ai * expi & * (r*ai+4.0d0*tk-1.0d0) ddampk = 0.25d0 * dk2 * tk2 * ak * expk & * (r*ak+4.0d0*ti-1.0d0) ddamp = ddampi + ddampk d2damp = 2.0d0*ddamp/r - ai*ddampi - ak*ddampk & + 0.25d0*di2*ti2*ai2*expi & + 0.25d0*dk2*tk2*ak2*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi ddamp = (di5-3.0d0*di3-3.0d0*di2) & *ai*expi/96.0d0 d2damp = (5.0d0*di4-9.0d0*di2-6.0d0*di) & *ai2*expi/96.0d0 - ai*ddamp end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c d2e = d2e*damp**2 + 4.0d0*de*damp*ddamp & + 2.0d0*e*(ddamp**2+damp*d2damp) de = de*damp**2 + 2.0d0*e*damp*ddamp e = e * damp**2 c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 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 d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper de = e*dtaper + de*taper end if c c scale the interaction based on its group membership c if (use_polymer) then if (r2 .le. polycut2) then de = de * dspscale(k) d2e = d2e * dspscale(k) end if end if if (use_group) then de = de * fgrp d2e = d2e * fgrp end if if (i .eq. k) then de = 0.5d0 * de d2e = 0.5d0 * d2e end if c c get chain rule terms for damped dispersion Hessian elements 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,ii) = hessx(j,ii) + term(1,j) hessy(j,ii) = hessy(j,ii) + term(2,j) hessz(j,ii) = hessz(j,ii) + term(3,j) hessx(j,kk) = hessx(j,kk) - term(1,j) hessy(j,kk) = hessy(j,kk) - term(2,j) hessz(j,kk) = hessz(j,kk) - term(3,j) end do end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################## c ## ## c ## subroutine edisp3 -- damped dispersion energy & analysis ## c ## ## c ################################################################## c c c "edisp3" calculates the dispersion energy; also partitions c the energy among the atoms c c literature reference: c c J. A. Rackers, C. Liu, P. Ren and J. W. Ponder, "A Physically c Grounded Damped Dispersion Model with Particle Mesh Ewald c Summation", Journal of Chemical Physics, 149, 084115 (2018) c c subroutine edisp3 use analyz use atoms use dsppot use energi use ewald use inform use iounit use limits implicit none integer i real*8 elrc,aelrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_dewald) then if (use_dlist) then call edisp3d else call edisp3c end if else if (use_dlist) then call edisp3b else call edisp3a end if end if c c apply long range dispersion correction if desired c if (use_dcorr .and. .not.use_dewald) then mode = 'DISP' call evcorr (mode,elrc) edsp = edsp + elrc aelrc = elrc / dble(n) do i = 1, n aedsp(i) = aedsp(i) + aelrc end do if (verbose .and. elrc.ne.0.0d0) then if (digits .ge. 8) then write (iout,10) elrc 10 format (/,' Long-Range Dispersion :',9x,f16.8) else if (digits .ge. 6) then write (iout,20) elrc 20 format (/,' Long-Range Dispersion :',9x,f16.6) else write (iout,30) elrc 30 format (/,' Long-Range Dispersion :',9x,f16.4) end if end if end if return end c c c ################################################################# c ## ## c ## subroutine edisp3a -- damp dispersion analysis via loop ## c ## ## c ################################################################# c c c "edisp3a" calculates the dispersion potential energy and c also partitions the energy among the atoms using a pairwise c double loop c c subroutine edisp3a use action use analyz use atomid use atoms use bound use boxes use couple use cell use disp use dsppot use energi use group use inform use inter use iounit use molcul use mutant use shunt use usage implicit none integer i,j,k integer ii,kk integer jcell real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,fgrp real*8 ci,ck real*8 r,r2,r3 real*8 r4,r5,r6 real*8 ai,ai2 real*8 ak,ak2 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 damp3,damp5 real*8 damp,taper real*8 vterm real*8, allocatable :: dspscale(:) logical proceed,usei logical header,huge logical muti,mutk character*6 mode c c c zero out the dispersion energy and partitioning terms c nedsp = 0 edsp = 0.0d0 do i = 1, n aedsp(i) = 0.0d0 end do if (ndisp .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DISP' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. ndisp.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Dispersion Interactions :', & //,' Type',14x,'Atom Names',15x,'Distance', & 8x,'Energy',/) end if c c find the damped dispersion energy via double loop search c do ii = 1, ndisp-1 i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii+1, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c e = e * dspscale(k) * damp**2 if (use_group) e = e * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then e = e * vterm else if (.not.muti .or. .not.mutk) then e = e * vterm end if end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper end if c c increment the overall dispersion energy components c if (e .ne. 0.0d0) then edsp = edsp + e nedsp = nedsp + 1 aedsp(i) = aedsp(i) + 0.5d0*e aedsp(k) = aedsp(k) + 0.5d0*e end if 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. 4.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Dispersion', & ' Interactions :', & //,' Type',14x,'Atom Names', & 15x,'Distance',8x,'Energy',/) end if write (iout,30) i,name(i),k,name(k),r,e 30 format (' Disper',4x,2(i7,'-',a3), & 9x,f10.4,2x,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 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, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then do jcell = 2, 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) r6 = r2**3 e = -ci * ck / r6 c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c e = e * damp**2 if (use_polymer) then if (r2 .le. polycut2) e = e * dspscale(k) end if if (use_group) e = e * fgrp if (i .eq. k) e = 0.5d0 * e c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then e = e * vterm else if (.not.muti .or. .not.mutk) then e = e * vterm end if end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper end if c c increment the overall dispersion energy components c if (e .ne. 0.0d0) then edsp = edsp + e nedsp = nedsp + 1 aedsp(i) = aedsp(i) + 0.5d0*e aedsp(k) = aedsp(k) + 0.5d0*e end if 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. 4.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual Dispersion', & ' Interactions :', & //,' Type',14x,'Atom Names', & 15x,'Distance',8x,'Energy',/) end if write (iout,50) i,name(i),k,name(k),r,e 50 format (' Disper',4x,2(i7,'-',a3),1x, & '(XTAL)',2x,f10.4,2x,f12.4) end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ################################################################# c ## ## c ## subroutine edisp3b -- damp dispersion analysis via list ## c ## ## c ################################################################# c c c "edisp3b" calculates the damped dispersion potential energy c and also partitions the energy among the atoms using a pairwise c neighbor list c c subroutine edisp3b use action use analyz use atomid use atoms use bound use boxes use couple use cell use disp use dsppot use energi use group use inform use inter use iounit use molcul use mutant use neigh use shunt use usage implicit none integer i,j,k integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,fgrp real*8 ci,ck real*8 r,r2,r3 real*8 r4,r5,r6 real*8 ai,ai2 real*8 ak,ak2 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 damp3,damp5 real*8 damp,taper real*8 vterm real*8, allocatable :: dspscale(:) logical proceed,usei logical header,huge logical muti,mutk character*6 mode c c c zero out the dispersion energy and partitioning terms c nedsp = 0 edsp = 0.0d0 do i = 1, n aedsp(i) = 0.0d0 end do if (ndisp .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DISP' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. ndisp.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Dispersion Interactions :', & //,' Type',14x,'Atom Names',15x,'Distance', & 8x,'Energy',/) end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use, !$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group, !$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,cut2,c0,c1,c2, !$OMP& c3,c4,c5,vcouple,vterm,molcule,name,verbose,debug,header,iout) !$OMP& firstprivate(dspscale),shared(edsp,nedsp,aedsp,einter) !$OMP DO reduction(+:edsp,nedsp,aedsp,einter) schedule(guided) c c find the damped dispersion energy via neighbor list search c do ii = 1, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c e = e * dspscale(k) * damp**2 if (use_group) e = e * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then e = e * vterm else if (.not.muti .or. .not.mutk) then e = e * vterm end if end if c c use energy switching if near the cutoff distance c if (r2 .gt. cut2) then r3 = r2 * r r4 = r2 * r2 r5 = r2 * r3 taper = c5*r5 + c4*r4 + c3*r3 & + c2*r2 + c1*r + c0 e = e * taper end if c c increment the overall dispersion energy components c if (e .ne. 0.0d0) then edsp = edsp + e nedsp = nedsp + 1 aedsp(i) = aedsp(i) + 0.5d0*e aedsp(k) = aedsp(k) + 0.5d0*e end if 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. 4.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Dispersion', & ' Interactions :', & //,' Type',14x,'Atom Names', & 15x,'Distance',8x,'Energy',/) end if write (iout,30) i,name(i),k,name(k),r,e 30 format (' Disper',4x,2(i7,'-',a3), & 9x,f10.4,2x,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ################################################################## c ## ## c ## subroutine edisp3c -- Ewald dispersion analysis via loop ## c ## ## c ################################################################## c c c "edisp3c" calculates the dispersion interaction energy using c particle mesh Ewald summation and a double loop c c subroutine edisp3c use action use analyz use atoms use disp use energi use ewald use pme implicit none integer i,ii real*8 e c c c zero out the dispersion energy and partitioning terms c nedsp = 0 edsp = 0.0d0 do i = 1, n aedsp(i) = 0.0d0 end do if (ndisp .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = ndfft1 nfft2 = ndfft2 nfft3 = ndfft3 bsorder = bsdorder aewald = adewald c c compute the real space portion of the Ewald summation c call edreal3c c c compute the reciprocal space part of the Ewald summation c call edrecip c c compute the self-energy portion of the Ewald summation c do ii = 1, ndisp i = idisp(ii) e = csix(i)**2 * aewald**6 / 12.0d0 edsp = edsp + e nedsp = nedsp + 1 aedsp(i) = aedsp(i) + e end do return end c c c ############################################################### c ## ## c ## subroutine edreal3c -- real space dispersion via loop ## c ## ## c ############################################################### c c c "edreal3c" calculates the real space portion of the damped c dispersion energy and analysis using Ewald and a double loop c c subroutine edreal3c use action use analyz use atomid use atoms use bound use boxes use couple use cell use disp use dsppot use energi use ewald use group use inform use inter use iounit use molcul use mutant use shunt use usage implicit none integer i,j,k integer ii,kk integer jcell real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,efull real*8 fgrp,ci,ck real*8 r,r2,r6 real*8 ai,ai2 real*8 ak,ak2 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 ralpha2 real*8 expa,term real*8 damp3,damp5 real*8 damp,scale real*8 vterm real*8, allocatable :: dspscale(:) logical proceed,usei logical muti,mutk logical header,huge character*6 mode c c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DEWALD' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. ndisp.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Dispersion Interactions :', & //,' Type',14x,'Atom Names',15x,'Distance', & 8x,'Energy',/) end if c c compute the real space portion of the Ewald summation c do ii = 1, ndisp-1 i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii+1, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 ralpha2 = r2 * aewald**2 term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2 expa = exp(-ralpha2) * term c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c scale = dspscale(k) * damp**2 if (use_group) scale = scale * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then scale = scale * vterm else if (.not.muti .or. .not.mutk) then scale = scale * vterm end if end if c c compute the full undamped energy for this interaction c efull = e * scale if (efull .ne. 0.0d0) then nedsp = nedsp + 1 aedsp(i) = aedsp(i) + 0.5d0*efull aedsp(k) = aedsp(k) + 0.5d0*efull if (molcule(i) .ne. molcule(k)) then einter = einter + efull end if end if c c increment the overall dispersion energy component c scale = scale - 1.0d0 e = e * (expa+scale) edsp = edsp + e c c print a message if the energy of this interaction is large c huge = (abs(efull) .gt. 4.0d0) if ((debug.and.efull.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Dispersion', & ' Interactions :', & //,' Type',14x,'Atom Names', & 15x,'Distance',8x,'Energy',/) end if write (iout,30) i,name(i),k,name(k),r,efull 30 format (' Disper',4x,2(i7,'-',a3),9x, & f10.4,2x,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 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, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = ii, ndisp k = idisp(kk) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) c c compute the energy contribution for this interaction c if (proceed) then do jcell = 2, 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) r6 = r2**3 ralpha2 = r2 * aewald**2 term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2 expa = exp(-ralpha2) * term c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c scale = damp**2 if (use_group) scale = scale * fgrp if (use_polymer) then if (r2 .le. polycut2) then scale = scale * dspscale(k) end if end if c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then scale = scale * vterm else if (.not.muti .or. .not.mutk) then scale = scale * vterm end if end if c c compute the full undamped energy for this interaction c if (i .eq. k) e = 0.5d0 * e efull = e * scale if (efull .ne. 0.0d0) then nedsp = nedsp + 1 aedsp(i) = aedsp(i) + 0.5d0*efull aedsp(k) = aedsp(k) + 0.5d0*efull if (molcule(i) .ne. molcule(k)) then einter = einter + efull end if end if c c increment the overall dispersion energy component c scale = scale - 1.0d0 e = e * (expa+scale) edsp = edsp + e c c print a message if the energy of this interaction is large c huge = (abs(efull) .gt. 4.0d0) if ((debug.and.efull.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual Dispersion', & ' Interactions :', & //,' Type',14x,'Atom Names', & 15x,'Distance',8x,'Energy',/) end if write (iout,50) i,name(i),k,name(k),r,efull 50 format (' Disper',4x,2(i7,'-',a3),1x, & '(XTAL)',2x,f10.4,2x,f12.4) end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ################################################################## c ## ## c ## subroutine edisp3d -- Ewald dispersion analysis via list ## c ## ## c ################################################################## c c c "edisp3d" calculates the damped dispersion energy and analysis c using particle mesh Ewald summation and a neighbor list c c subroutine edisp3d use action use analyz use atoms use disp use energi use ewald use pme implicit none integer i,ii real*8 e c c c zero out the dispersion energy and partitioning terms c nedsp = 0 edsp = 0.0d0 do i = 1, n aedsp(i) = 0.0d0 end do if (ndisp .eq. 0) return c c set grid size, spline order and Ewald coefficient c nfft1 = ndfft1 nfft2 = ndfft2 nfft3 = ndfft3 bsorder = bsdorder aewald = adewald c c compute the real space portion of the Ewald summation c call edreal3d c c compute the reciprocal space part of the Ewald summation c call edrecip c c compute the self-energy portion of the Ewald summation c do ii = 1, ndisp i = idisp(ii) e = csix(i)**2 * aewald**6 / 12.0d0 edsp = edsp + e nedsp = nedsp + 1 aedsp(i) = aedsp(i) + e end do return end c c c ################################################################## c ## ## c ## subroutine edreal3d -- real space disp analysis via list ## c ## ## c ################################################################## c c c "edreal3d" evaluated the real space portion of the damped c dispersion energy and analysis using Ewald and a neighbor list c c subroutine edreal3d use action use analyz use atomid use atoms use bound use boxes use couple use cell use disp use dsppot use energi use ewald use group use inform use inter use iounit use molcul use mutant use neigh use shunt use usage implicit none integer i,j,k integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 e,efull real*8 fgrp,ci,ck real*8 r,r2,r6 real*8 ai,ai2 real*8 ak,ak2 real*8 di,di2,di3 real*8 di4,di5 real*8 dk,dk2,dk3 real*8 ti,ti2 real*8 tk,tk2 real*8 expi,expk real*8 ralpha2 real*8 expa,term real*8 damp3,damp5 real*8 damp,scale real*8 vterm real*8, allocatable :: dspscale(:) logical proceed,usei logical muti,mutk logical header,huge character*6 mode c c c perform dynamic allocation of some local arrays c allocate (dspscale(n)) c c initialize connected atom exclusion coefficients c do i = 1, n dspscale(i) = 1.0d0 end do c c set lambda scaling values for mutated interactions c if (nmut .ne. 0) then vterm = vlambda**4 / sqrt(1.0d0+vlambda**2-vlambda**3) end if c c set conversion factor, cutoff and switching coefficients c mode = 'DEWALD' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. ndisp.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Dispersion Interactions :', & //,' Type',14x,'Atom Names',15x,'Distance', & 8x,'Energy',/) end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(ndisp,idisp,csix,adisp,use, !$OMP& x,y,z,n12,n13,n14,n15,i12,i13,i14,i15,nvlst,vlst,use_group, !$OMP& dsp2scale,dsp3scale,dsp4scale,dsp5scale,mut,off2,aewald, !$OMP& molcule,vcouple,vterm,name,verbose,debug,header,iout) !$OMP& firstprivate(dspscale),shared(edsp,nedsp,aedsp,einter) !$OMP DO reduction(+:edsp,nedsp,aedsp,einter) schedule(guided) c c compute the real space portion of the Ewald summation c do ii = 1, ndisp i = idisp(ii) ci = csix(i) ai = adisp(i) xi = x(i) yi = y(i) zi = z(i) usei = use(i) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = dsp2scale end do do j = 1, n13(i) dspscale(i13(j,i)) = dsp3scale end do do j = 1, n14(i) dspscale(i14(j,i)) = dsp4scale end do do j = 1, n15(i) dspscale(i15(j,i)) = dsp5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) ck = csix(k) ak = adisp(k) mutk = mut(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (usei .or. use(k)) 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. off2) then r = sqrt(r2) r6 = r2**3 e = -ci * ck / r6 ralpha2 = r2 * aewald**2 term = 1.0d0 + ralpha2 + 0.5d0*ralpha2**2 expa = exp(-ralpha2) * term c c find the damping factor for the dispersion interaction c di = ai * r di2 = di * di di3 = di * di2 dk = ak * r expi = exp(-di) expk = exp(-dk) if (ai .ne. ak) then ai2 = ai * ai ak2 = ak * ak dk2 = dk * dk dk3 = dk * dk2 ti = ak2 / (ak2-ai2) ti2 = ti * ti tk = ai2 / (ai2-ak2) tk2 = tk * tk damp3 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2)*expi & - tk2*(1.0d0+dk+0.5d0*dk2)*expk & - 2.0d0*ti2*tk*(1.0d0+di)*expi & - 2.0d0*tk2*ti*(1.0d0+dk)*expk damp5 = 1.0d0 - ti2*(1.0d0+di+0.5d0*di2 & +di3/6.0d0)*expi & - tk2*(1.0d0+dk+0.5d0*dk2 & +dk3/6.0d0)*expk & - 2.0d0*ti2*tk*(1.0+di+di2/3.0d0)*expi & - 2.0d0*tk2*ti*(1.0+dk+dk2/3.0d0)*expk else di4 = di2 * di2 di5 = di2 * di3 damp3 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +7.0d0*di3/48.0d0+di4/48.0d0)*expi damp5 = 1.0d0 - (1.0d0+di+0.5d0*di2 & +di3/6.0d0+di4/24.0d0+di5/144.0d0)*expi end if damp = 1.5d0*damp5 - 0.5d0*damp3 c c apply damping and scaling factors for this interaction c scale = dspscale(k) * damp**2 if (use_group) scale = scale * fgrp c c set use of lambda scaling for decoupling or annihilation c if (muti .or. mutk) then if (vcouple .eq. 1) then scale = scale * vterm else if (.not.muti .or. .not.mutk) then scale = scale * vterm end if end if c c compute the full undamped energy for this interaction c efull = e * scale if (efull .ne. 0.0d0) then nedsp = nedsp + 1 aedsp(i) = aedsp(i) + 0.5d0*efull aedsp(k) = aedsp(k) + 0.5d0*efull if (molcule(i) .ne. molcule(k)) then einter = einter + efull end if end if c c increment the overall dispersion energy component c scale = scale - 1.0d0 e = e * (expa+scale) edsp = edsp + e c c print a message if the energy of this interaction is large c huge = (abs(efull) .gt. 4.0d0) if ((debug.and.efull.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Dispersion', & ' Interactions :', & //,' Type',14x,'Atom Names', & 15x,'Distance',8x,'Energy',/) end if write (iout,30) i,name(i),k,name(k),r,efull 30 format (' Disper',4x,2(i7,'-',a3),9x, & f10.4,2x,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) dspscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dspscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dspscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dspscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (dspscale) return end c c c ################################################### c ## COPYRIGHT (C) 1994 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine egauss -- Gaussian van der Waals energy ## c ## ## c ############################################################ c c c "egauss" calculates the Gaussian expansion van der Waals energy c c subroutine egauss use limits use warp implicit none c c c choose the method for summing over pairwise interactions c if (use_smooth) then call egauss0d else if (use_vlist) then call egauss0c else if (use_lights) then call egauss0b else call egauss0a end if return end c c c ################################################################ c ## ## c ## subroutine egauss0a -- double loop Gaussian vdw energy ## c ## ## c ################################################################ c c c "egauss0a" calculates the Gaussian expansion van der Waals c energy using a pairwise double loop c c subroutine egauss0a use atomid use atoms use bound use cell use couple use energi use group use shunt use usage use vdw use vdwpot implicit none integer i,j,k,m integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,eps,rdn real*8 rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expterm real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set cutoff distances and switching function coefficients c mode = 'VDW' call switch (mode) expcut = -50.0d0 c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) & e = e + a(j)*exp(expterm) end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do m = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,m) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) & e = e + a(j)*exp(expterm) end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy component; c interaction of an atom with its own image counts half c if (i .eq. k) e = 0.5d0 * e ev = ev + e end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ############################################################### c ## ## c ## subroutine egauss0b -- Gaussian vdw energy via lights ## c ## ## c ############################################################### c c c "egauss0b" calculates the Gaussian expansion van der Waals energy c using the method of lights c c subroutine egauss0b use atomid use atoms use bound use boxes use cell use couple use energi use group use light use shunt use usage use vdw use vdwpot implicit none integer i,j,k,m integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer, allocatable :: iv14(:) real*8 e,eps,rdn real*8 rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expterm real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set cutoff distances and switching function coefficients c mode = 'VDW' call switch (mode) expcut = -50.0d0 c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do m = start, stop kk = locx(m) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(m) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) & e = e + a(j)*exp(expterm) end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy component c ev = ev + e end if end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################# c ## ## c ## subroutine egauss0c -- Gaussian vdw energy via list ## c ## ## c ############################################################# c c c "egauss0c" calculates the Gaussian expansion van der Waals c energy using a pairwise neighbor list c c subroutine egauss0c use atomid use atoms use bound use couple use energi use group use neigh use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,eps,rdn real*8 rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expterm real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set cutoff distances and switching function coefficients c mode = 'VDW' call switch (mode) expcut = -50.0d0 c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired, !$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13, !$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group,off2, !$OMP& radmin,epsilon,radmin4,epsilon4,ngauss,igauss,expcut, !$OMP& cut2,c0,c1,c2,c3,c4,c5) !$OMP& firstprivate(vscale,iv14) shared(ev) !$OMP DO reduction(+:ev) schedule(guided) c c find the van der Waals energy via neighbor list search c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) & e = e + a(j)*exp(expterm) end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################## c ## ## c ## subroutine egauss0d -- Gaussian vdw energy for smoothing ## c ## ## c ################################################################## c c c "egauss0d" calculates the Gaussian expansion van der Waals c energy for use with potential energy smoothing c c subroutine egauss0d use atomid use atoms use couple use energi use group use math use usage use vdw use vdwpot use warp implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,rik,rik2,rdn real*8 eps,rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 erf,expcut,broot real*8 expterm,expterm2 real*8 width,wterm real*8 t1,t2,term real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) logical proceed,usei external erf c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the extent of smoothing to be performed c expcut = -50.0d0 width = 0.0d0 if (use_dem) then width = 4.0d0 * diffv * deform else if (use_gda) then wterm = (2.0d0/3.0d0) * diffv else if (use_tophat) then width = max(diffv*deform,0.0001d0) end if c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 c c transform the potential function via smoothing c if (use_tophat) then rik = sqrt(rik2) do j = 1, ngauss broot = sqrt(b(j)) expterm = -b(j) * (rik+width)**2 if (expterm .gt. expcut) then expterm = exp(expterm) else expterm = 0.0d0 end if expterm2 = -b(j) * (width-rik)**2 if (expterm2 .gt. expcut) then expterm2 = exp(expterm2) else expterm2 = 0.0d0 end if term = broot * (expterm-expterm2) term = term + rootpi*b(j)*rik & * (erf(broot*(rik+width)) & +erf(broot*(width-rik))) e = e + term*a(j)/(b(j)*b(j)*broot) end do e = e * 3.0d0/(8.0d0*rik*width**3) else if (use_gda) width = wterm * (m2(i)+m2(k)) do j = 1, ngauss t1 = 1.0d0 + b(j)*width t2 = sqrt(t1**3) expterm = -b(j) * rik2 / t1 if (expterm .gt. expcut) & e = e + (a(j)/t2)*exp(expterm) end do end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1994 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine egauss1 -- Gaussian vdw energy & derivatives ## c ## ## c ################################################################# c c c "egauss1" calculates the Gaussian expansion van der Waals c interaction energy and its first derivatives with respect c to Cartesian coordinates c c subroutine egauss1 use limits use warp implicit none c c c choose the method for summing over pairwise interactions c if (use_smooth) then call egauss1d else if (use_vlist) then call egauss1c else if (use_lights) then call egauss1b else call egauss1a end if return end c c c ################################################################ c ## ## c ## subroutine egauss1a -- double loop Gaussian vdw derivs ## c ## ## c ################################################################ c c c "egauss1a" calculates the Gaussian expansion van der Waals c interaction energy and its first derivatives using a pairwise c double loop c c subroutine egauss1a use atomid use atoms use bound use cell use couple use deriv use energi use group use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k,m integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,de,rdn real*8 eps,rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 expcut,expterm real*8 taper,dtaper real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) expcut = -50.0d0 c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find van der Waals energy and derivatives via double loop c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 de = 0.0d0 rik = sqrt(rik2) do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) then expterm = a(j)*exp(expterm) e = e + expterm de = de - 2.0d0*b(j)*rik*expterm end if end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do m = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,m) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 de = 0.0d0 rik = sqrt(rik2) do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) then expterm = a(j)*exp(expterm) e = e + expterm de = de - 2.0d0*b(j)*rik*expterm end if end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c if (i .eq. k) e = 0.5d0 * e ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (i .ne. k) then if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ############################################################### c ## ## c ## subroutine egauss1b -- Gaussian vdw derivs via lights ## c ## ## c ############################################################### c c c "egauss1b" calculates the Gaussian expansion van der Waals c energy and its first derivatives with respect to Cartesian c coordinates using the method of lights c c subroutine egauss1b use atomid use atoms use bound use boxes use cell use couple use deriv use energi use group use light use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k,m integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer, allocatable :: iv14(:) real*8 e,de,rdn real*8 eps,rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 expcut,expterm real*8 taper,dtaper real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) expcut = -50.0d0 c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do m = start, stop kk = locx(m) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(m) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 de = 0.0d0 rik = sqrt(rik2) do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) then expterm = a(j)*exp(expterm) e = e + expterm de = de - 2.0d0*b(j)*rik*expterm end if end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################# c ## ## c ## subroutine egauss1c -- Gaussian vdw derivs via list ## c ## ## c ############################################################# c c c "egauss1c" calculates the Gaussian expansion van der Waals c energy and its first derivatives with respect to Cartesian c coordinates using a pairwise neighbor list c c subroutine egauss1c use atomid use atoms use bound use couple use deriv use energi use group use neigh use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,de,rdn real*8 eps,rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 expcut,expterm real*8 taper,dtaper real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) logical proceed,usei character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) expcut = -50.0d0 c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired, !$OMP& kred,xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15, !$OMP& i12,i13,i14,i15,v2scale,v3scale,v4scale,v5scale, !$OMP& use_group,off2,radmin,epsilon,radmin4,epsilon4, !$OMP& ngauss,igauss,expcut,cut2,c0,c1,c2,c3,c4,c5) !$OMP& firstprivate(vscale,iv14) shared(ev,dev,vir) !$OMP DO reduction(+:ev,dev,vir) schedule(guided) c c find van der Waals energy and derivatives via neighbor list c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 de = 0.0d0 rik = sqrt(rik2) do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) then expterm = a(j)*exp(expterm) e = e + expterm de = de - 2.0d0*b(j)*rik*expterm end if end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################## c ## ## c ## subroutine egauss1d -- Gaussian vdw derivs for smoothing ## c ## ## c ################################################################## c c c "egauss1d" calculates the Gaussian expansion van der Waals c interaction energy and its first derivatives for use with c potential energy smoothing c c subroutine egauss1d use atomid use atoms use couple use deriv use energi use group use math use usage use vdw use vdwpot use virial use warp implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,de,rdn real*8 eps,rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 expcut,broot real*8 erf,term,term2 real*8 expterm,expterm2 real*8 width,wterm real*8 rik,rik2 real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8 t1,t2 real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) logical proceed,usei external erf c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the extent of smoothing to be performed c expcut = -50.0d0 width = 0.0d0 if (use_dem) then width = 4.0d0 * diffv * deform else if (use_gda) then wterm = (2.0d0/3.0d0) * diffv else if (use_tophat) then width = max(diffv*deform,0.0001d0) end if c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find van der Waals energy and derivatives via double loop c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 de = 0.0d0 rik = sqrt(rik2) c c transform the potential function via smoothing c if (use_tophat) then rik = sqrt(rik2) do j = 1, ngauss broot = sqrt(b(j)) expterm = -b(j) * (rik+width)**2 if (expterm .gt. expcut) then expterm = exp(expterm) else expterm = 0.0d0 end if expterm2 = -b(j) * (width-rik)**2 if (expterm2 .gt. expcut) then expterm2 = exp(expterm2) else expterm2 = 0.0d0 end if term = broot * (expterm-expterm2) term = term + rootpi*b(j)*rik & * (erf(broot*(rik+width)) & +erf(broot*(width-rik))) e = e + term*a(j)/(b(j)*b(j)*broot) term = expterm * (2.0d0*rik*b(j)*width+1.0d0) term2 = expterm2 * (2.0d0*rik*b(j)*width-1.0d0) de = de + a(j)*(term+term2)/(b(j)*b(j)) end do term = 3.0d0 / (8.0d0*rik*width**3) e = e * term de = -de * term / rik else if (use_gda) width = wterm * (m2(i)+m2(k)) do j = 1, ngauss t1 = 1.0d0 + b(j)*width t2 = sqrt(t1**3) expterm = -b(j) * rik2 / t1 if (expterm .gt. expcut) then expterm = (a(j)/t2)*exp(expterm) e = e + expterm de = de - (2.0d0*b(j)*rik/t1)*expterm end if end do end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1994 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine egauss2 -- atom-by-atom Gaussian vdw Hessian ## c ## ## c ################################################################# c c c "egauss2" calculates the Gaussian expansion van der Waals c second derivatives for a single atom at a time c c subroutine egauss2 (i) use warp implicit none integer i c c c choose the method for summing over pairwise interactions c if (use_smooth) then call egauss2b (i) else call egauss2a (i) end if return end c c c ################################################################# c ## ## c ## subroutine egauss2a -- double loop Gaussian vdw Hessian ## c ## ## c ################################################################# c c c "egauss2a" calculates the Gaussian expansion van der Waals c second derivatives using a pairwise double loop c c subroutine egauss2a (iatom) use atomid use atoms use bound use cell use couple use group use hessn use shunt use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer iatom,jcell integer nlist,list(5) integer, allocatable :: iv14(:) real*8 de,d2e real*8 rik,rik2 real*8 eps,rdn real*8 rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 redi2,rediv2 real*8 rediiv real*8 redik,redivk real*8 redikv,redivkv real*8 d2edx,d2edy,d2edz real*8 expcut,expterm real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) real*8 term(3,3) logical proceed character*6 mode c c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) expcut = -50.0d0 c c check to see if the atom of interest is a vdw site c nlist = 0 do k = 1, nvdw if (ivdw(k) .eq. iatom) then nlist = nlist + 1 list(nlist) = iatom goto 10 end if end do return 10 continue c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c determine the atoms involved via reduction factors c nlist = 1 list(nlist) = iatom do k = 1, n12(iatom) i = i12(k,iatom) if (ired(i) .eq. iatom) then nlist = nlist + 1 list(nlist) = i end if end do c c find van der Waals Hessian elements for involved atoms c do ii = 1, nlist i = list(ii) it = jvdw(i) iv = ired(i) redi = kred(i) if (i .ne. iv) then rediv = 1.0d0 - redi redi2 = redi * redi rediv2 = rediv * rediv rediiv = redi * rediv end if xi = xred(i) yi = yred(i) zi = zred(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) proceed = (k .ne. i) if (proceed .and. use_group) & call groups (proceed,fgrp,i,k,0,0,0,0) c c compute the Hessian elements for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do de = 0.0d0 d2e = 0.0d0 rik = sqrt(rik2) do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) then expterm = a(j)*b(j)*exp(expterm) de = de - 2.0d0*rik*expterm d2e = d2e + (4.0d0*b(j)*rik2-2.0d0)*expterm end if end do 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 get chain rule terms for van der Waals Hessian elements c de = de / rik d2e = (d2e-de) / rik2 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 if (i .eq. iatom) then if (i.eq.iv .and. k.eq.kv) then 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 else if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redi hessy(j,k) = hessy(j,k) - term(2,j)*redi hessz(j,k) = hessz(j,k) - term(3,j)*redi hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv end do else if (i .eq. iv) then redk = kred(k) redkv = 1.0d0 - redk 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)*redk hessy(j,k) = hessy(j,k) - term(2,j)*redk hessz(j,k) = hessz(j,k) - term(3,j)*redk hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv end do else redk = kred(k) redkv = 1.0d0 - redk redik = redi * redk redikv = redi * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redik hessy(j,k) = hessy(j,k) - term(2,j)*redik hessz(j,k) = hessz(j,k) - term(3,j)*redik hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv end do end if else if (iv .eq. iatom) then if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*rediv hessy(j,k) = hessy(j,k) - term(2,j)*rediv hessz(j,k) = hessz(j,k) - term(3,j)*rediv hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 end do else redk = kred(k) redkv = 1.0d0 - redk redivk = rediv * redk redivkv = rediv * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*redivk hessy(j,k) = hessy(j,k) - term(2,j)*redivk hessz(j,k) = hessz(j,k) - term(3,j)*redivk hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv end do end if end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nlist i = list(ii) it = jvdw(i) iv = ired(i) redi = kred(i) if (i .ne. iv) then rediv = 1.0d0 - redi redi2 = redi * redi rediv2 = rediv * rediv rediiv = redi * rediv end if xi = xred(i) yi = yred(i) zi = zred(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) c c compute the Hessian elements for this interaction c if (proceed) then do jcell = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,jcell) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do de = 0.0d0 d2e = 0.0d0 rik = sqrt(rik2) do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) then expterm = a(j)*b(j)*exp(expterm) de = de - 2.0d0*rik*expterm d2e = d2e + (4.0d0*b(j)*rik2-2.0d0)*expterm end if end do 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 get chain rule terms for van der Waals Hessian elements c de = de / rik d2e = (d2e-de) / rik2 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 if (i .eq. iatom) then if (i.eq.iv .and. k.eq.kv) then 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 else if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redi hessy(j,k) = hessy(j,k) - term(2,j)*redi hessz(j,k) = hessz(j,k) - term(3,j)*redi hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediiv end do else if (i .eq. iv) then redk = kred(k) redkv = 1.0d0 - redk 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)*redk hessy(j,k) = hessy(j,k) - term(2,j)*redk hessz(j,k) = hessz(j,k) - term(3,j)*redk hessx(j,kv) = hessx(j,kv) & - term(1,j)*redkv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redkv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redkv end do else redk = kred(k) redkv = 1.0d0 - redk redik = redi * redk redikv = redi * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redik hessy(j,k) = hessy(j,k) - term(2,j)*redik hessz(j,k) = hessz(j,k) - term(3,j)*redik hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediiv hessx(j,kv) = hessx(j,kv) & - term(1,j)*redikv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redikv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redikv end do end if else if (iv .eq. iatom) then if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*rediv hessy(j,k) = hessy(j,k) - term(2,j)*rediv hessz(j,k) = hessz(j,k) - term(3,j)*rediv hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediv2 end do else redk = kred(k) redkv = 1.0d0 - redk redivk = rediv * redk redivkv = rediv * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*redivk hessy(j,k) = hessy(j,k) - term(2,j)*redivk hessz(j,k) = hessz(j,k) - term(3,j)*redivk hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediv2 hessx(j,kv) = hessx(j,kv) & - term(1,j)*redivkv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redivkv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redivkv end do end if end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ############################################################### c ## ## c ## subroutine egauss2b -- Gaussian Hessian for smoothing ## c ## ## c ############################################################### c c c "egauss2b" calculates the Gaussian expansion van der Waals c second derivatives for use with potential energy smoothing c c subroutine egauss2b (iatom) use atomid use atoms use couple use group use hessn use vdw use vdwpot use warp implicit none integer i,j,k,iatom integer ii,it,iv integer kk,kt,kv integer nlist,list(5) integer, allocatable :: iv14(:) real*8 de,d2e real*8 rik,rik2 real*8 eps,rdn real*8 rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 redi2,rediv2 real*8 rediiv real*8 redik,redivk real*8 redikv,redivkv real*8 d2edx,d2edy,d2edz real*8 expcut,b2 real*8 term1,term2 real*8 width,wterm real*8 expterm real*8 expterm2 real*8 t1,t2 real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) real*8 term(3,3) logical proceed c c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the extent of smoothing to be performed c expcut = -50.0d0 width = 0.0d0 if (use_dem) then width = 4.0d0 * diffv * deform else if (use_gda) then wterm = (2.0d0/3.0d0) * diffv else if (use_tophat) then width = max(diffv*deform,0.0001d0) end if c c check to see if the atom of interest is a vdw site c nlist = 0 do k = 1, nvdw if (ivdw(k) .eq. iatom) then nlist = nlist + 1 list(nlist) = iatom goto 10 end if end do return 10 continue c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c determine the atoms involved via reduction factors c nlist = 1 list(nlist) = iatom do k = 1, n12(iatom) i = i12(k,iatom) if (ired(i) .eq. iatom) then nlist = nlist + 1 list(nlist) = i end if end do c c find van der Waals Hessian elements for involved atoms c do ii = 1, nlist i = list(ii) it = jvdw(i) iv = ired(i) redi = kred(i) if (i .ne. iv) then rediv = 1.0d0 - redi redi2 = redi * redi rediv2 = rediv * rediv rediiv = redi * rediv end if xi = xred(i) yi = yred(i) zi = zred(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) proceed = (k .ne. i) if (proceed .and. use_group) & call groups (proceed,fgrp,i,k,0,0,0,0) c c compute the Hessian elements for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do de = 0.0d0 d2e = 0.0d0 rik = sqrt(rik2) c c transform the potential function via smoothing c if (use_tophat) then rik = sqrt(rik2) do j = 1, ngauss expterm = -b(j) * (rik+width)**2 if (expterm .gt. expcut) then expterm = exp(expterm) else expterm = 0.0d0 end if expterm2 = -b(j) * (width-rik)**2 if (expterm2 .gt. expcut) then expterm2 = exp(expterm2) else expterm2 = 0.0d0 end if b2 = b(j)*b(j) term1 = expterm * (2.0d0*rik*b(j)*width+1.0d0) term2 = expterm2 * (2.0d0*rik*b(j)*width-1.0d0) de = de + a(j)*(term1+term2)/b2 term1 = 2.0d0*b(j)*width*rik * (b(j)*rik2+1.0d0) & * (expterm+expterm2) term2 = (2.0d0*rik2*(b(j)*width)**2 + 1.0d0 & + b(j)*rik2) * (expterm-expterm2) d2e = d2e + a(j)*(term1+term2)/b2 end do term1 = 3.0d0 / (8.0d0*rik*width**3) de = -de * term1 d2e = 2.0d0 * d2e * term1 / rik else if (use_gda) width = wterm * (m2(i)+m2(k)) do j = 1, ngauss t1 = 1.0d0 + b(j)*width t2 = sqrt(t1**3) expterm = -b(j) * rik2 / t1 if (expterm .gt. expcut) then expterm = (a(j)*b(j)/(t2*t1))*exp(expterm) de = de - 2.0d0*rik*expterm d2e = d2e + (4.0d0*b(j)*rik2/t1-2.0d0)*expterm end if end do 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 get chain rule terms for van der Waals Hessian elements c de = de / rik d2e = (d2e-de) / rik2 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 if (i .eq. iatom) then if (i.eq.iv .and. k.eq.kv) then 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 else if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redi hessy(j,k) = hessy(j,k) - term(2,j)*redi hessz(j,k) = hessz(j,k) - term(3,j)*redi hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv end do else if (i .eq. iv) then redk = kred(k) redkv = 1.0d0 - redk 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)*redk hessy(j,k) = hessy(j,k) - term(2,j)*redk hessz(j,k) = hessz(j,k) - term(3,j)*redk hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv end do else redk = kred(k) redkv = 1.0d0 - redk redik = redi * redk redikv = redi * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redik hessy(j,k) = hessy(j,k) - term(2,j)*redik hessz(j,k) = hessz(j,k) - term(3,j)*redik hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv end do end if else if (iv .eq. iatom) then if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*rediv hessy(j,k) = hessy(j,k) - term(2,j)*rediv hessz(j,k) = hessz(j,k) - term(3,j)*rediv hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 end do else redk = kred(k) redkv = 1.0d0 - redk redivk = rediv * redk redivkv = rediv * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*redivk hessy(j,k) = hessy(j,k) - term(2,j)*redivk hessz(j,k) = hessz(j,k) - term(3,j)*redivk hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv end do end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1994 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine egauss3 -- Gaussian vdw energy & analysis ## c ## ## c ############################################################## c c c "egauss3" calculates the Gaussian expansion van der Waals c interaction energy and partitions the energy among the atoms c c subroutine egauss3 use limits use warp implicit none c c c choose the method for summing over pairwise interactions c if (use_smooth) then call egauss3d else if (use_vlist) then call egauss3c else if (use_lights) then call egauss3b else call egauss3a end if return end c c c ################################################################## c ## ## c ## subroutine egauss3a -- double loop Gaussian vdw analysis ## c ## ## c ################################################################## c c c "egauss3a" calculates the Gaussian expansion van der Waals c energy and partitions the energy among the atoms using a c pairwise double loop c c subroutine egauss3a use action use analyz use atomid use atoms use bound use cell use couple use energi use group use inform use inter use iounit use molcul use shunt use usage use vdw use vdwpot implicit none integer i,j,k,m integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,eps,rdn real*8 rad,rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expterm real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) logical proceed,usei logical header,huge character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) expcut = -50.0d0 c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) & e = e + a(j)*exp(expterm) end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total van der Waals energy components c nev = nev + 1 aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e ev = ev + 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 = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if rad = sqrt(rad2) write (iout,30) i,name(i),k,name(k), & rad,sqrt(rik2),e 30 format (' VDW-Gauss',1x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do m = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,m) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) & e = e + a(j)*exp(expterm) end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy component c if (e .ne. 0.0d0) then nev = nev + 1 if (i .eq. k) then ev = ev + 0.5d0*e aev(i) = aev(i) + 0.5d0*e else ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if rad = sqrt(rad2) write (iout,50) i,name(i),k,name(k), & rad,sqrt(rik2),e 50 format (' VDW-Gauss',1x,2(i7,'-',a3), & 1x,'(XTAL)',6x,2f10.4,f12.4) end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################# c ## ## c ## subroutine egauss3b -- Gaussian vdw analysis via lights ## c ## ## c ################################################################# c c c "egauss3b" calculates the Gaussian expansion van der Waals c energy and partitions the energy among the atoms using the c method of lights c c subroutine egauss3b use action use analyz use atomid use atoms use bound use boxes use cell use couple use energi use group use inform use inter use iounit use light use molcul use shunt use usage use vdw use vdwpot implicit none integer i,j,k,m integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer ikmin,ikmax integer, allocatable :: iv14(:) real*8 e,eps,rdn real*8 rad,rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expterm real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat logical header,huge character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set cutoff distances and switching function coefficients c mode = 'VDW' call switch (mode) expcut = -50.0d0 c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 20 continue do m = start, stop kk = locx(m) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 60 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 60 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 60 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 60 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(m) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) & e = e + a(j)*exp(expterm) end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if c c increment the total intermolecular energy c if (.not.prime .or. 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,30) 30 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if rad = sqrt(rad2) ikmin = min(i,k) ikmax = max(i,k) if (prime) then write (iout,40) ikmin,name(ikmin),ikmax, & name(ikmax),rad,sqrt(rik2),e 40 format (' VDW-Gauss',1x,2(i7,'-',a3), & 13x,2f10.4,f12.4) else write (iout,50) ikmin,name(ikmin),ikmax, & name(ikmax),rad,sqrt(rik2),e 50 format (' VDW-Gauss',1x,2(i7,'-',a3), & 1x,'(XTAL)',6x,2f10.4,f12.4) end if end if end if end if 60 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 20 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################### c ## ## c ## subroutine egauss3c -- Gaussian vdw analysis via list ## c ## ## c ############################################################### c c c "egauss3c" calculates the Gaussian expansion van der Waals c energy and partitions the energy among the atoms using a c pairwise neighbor list c c subroutine egauss3c use action use analyz use atomid use atoms use bound use couple use energi use group use inform use inter use iounit use molcul use neigh use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,eps,rdn real*8 rad,rad2,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8 expcut,expterm real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) logical proceed,usei logical header,huge character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set cutoff distances and switching function coefficients c mode = 'VDW' call switch (mode) expcut = -50.0d0 c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired, !$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13, !$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group, !$OMP& off2,radmin,epsilon,radmin4,epsilon4,ngauss,igauss, !$OMP& expcut,cut2,c0,c1,c2,c3,c4,c5,molcule,name,verbose, !$OMP& debug,header,iout) !$OMP& firstprivate(vscale,iv14) shared(ev,nev,aev,einter) !$OMP DO reduction(+:ev,nev,aev,einter) schedule(guided) c c find the van der Waals energy via neighbor list search c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 do j = 1, ngauss expterm = -b(j) * rik2 if (expterm .gt. expcut) & e = e + a(j)*exp(expterm) end do c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total van der Waals energy components c nev = nev + 1 aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e ev = ev + 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 = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if rad = sqrt(rad2) write (iout,30) i,name(i),k,name(k), & rad,sqrt(rik2),e 30 format (' VDW-Gauss',1x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################ c ## ## c ## subroutine egauss3d -- Gaussian analysis for smoothing ## c ## ## c ################################################################ c c c "egauss3d" calculates the Gaussian expansion van der Waals c interaction energy and partitions the energy among the atoms c for use with potential energy smoothing c c subroutine egauss3d use action use analyz use atomid use atoms use couple use energi use group use inform use inter use iounit use math use molcul use usage use vdw use vdwpot use warp implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,eps,rdn real*8 rad,rad2,fgrp real*8 rik,rik2 real*8 xi,yi,zi real*8 xr,yr,zr real*8 erf,expcut,broot real*8 expterm,expterm2 real*8 width,wterm real*8 t1,t2,term real*8 a(maxgauss) real*8 b(maxgauss) real*8, allocatable :: vscale(:) logical proceed,usei logical header,huge external erf c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c set the extent of smoothing to be performed c expcut = -50.0d0 width = 0.0d0 if (use_dem) then width = 4.0d0 * diffv * deform else if (use_gda) then wterm = (2.0d0/3.0d0) * diffv else if (use_tophat) then width = max(diffv*deform,0.0001d0) end if c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) do j = ii+1, nvdw vscale(ivdw(j)) = 1.0d0 end do do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) if (proceed) proceed = (vscale(k) .ne. 0.0d0) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c rad2 = radmin(kt,it)**2 eps = epsilon(kt,it) if (iv14(k) .eq. i) then rad2 = radmin4(kt,it)**2 eps = epsilon4(kt,it) end if eps = eps * vscale(k) do j = 1, ngauss a(j) = igauss(1,j) * eps b(j) = igauss(2,j) / rad2 end do e = 0.0d0 c c transform the potential function via smoothing c if (use_tophat) then rik = sqrt(rik2) do j = 1, ngauss broot = sqrt(b(j)) expterm = -b(j) * (rik+width)**2 if (expterm .gt. expcut) then expterm = exp(expterm) else expterm = 0.0d0 end if expterm2 = -b(j) * (width-rik)**2 if (expterm2 .gt. expcut) then expterm2 = exp(expterm2) else expterm2 = 0.0d0 end if term = broot * (expterm-expterm2) term = term + rootpi*b(j)*rik & * (erf(broot*(rik+width)) & +erf(broot*(width-rik))) e = e + term*a(j)/(b(j)*b(j)*broot) end do e = e * 3.0d0/(8.0d0*rik*width**3) else if (use_gda) width = wterm * (m2(i)+m2(k)) do j = 1, ngauss t1 = 1.0d0 + b(j)*width t2 = sqrt(t1**3) expterm = -b(j) * rik2 / t1 if (expterm .gt. expcut) & e = e + (a(j)/t2)*exp(expterm) end do end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total van der Waals energy components c nev = nev + 1 aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e ev = ev + 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 = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if rad = sqrt(rad2) write (iout,30) i,name(i),k,name(k), & rad,sqrt(rik2),e 30 format (' VDW-Gauss',1x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine egeom -- geometric restraint energy terms ## c ## ## c ############################################################## c c c "egeom" calculates the energy due to restraints on positions, c distances, angles and torsions as well as Gaussian basin and c spherical droplet restraints c c subroutine egeom use atomid use atoms use bound use boxes use cell use energi use group use math use molcul use restrn use usage implicit none integer i,j,k integer ia,ib,ic,id real*8 e,eps,fgrp real*8 dt,dt2 real*8 xr,yr,zr real*8 r,r2,r6,r12 real*8 angle,target real*8 dot,force real*8 cosine,sine real*8 rab2,rcb2 real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2 real*8 rtru,rcb real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xab,yab,zab real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 df1,df2 real*8 af1,af2 real*8 tf1,tf2,t1,t2 real*8 xa,ya,za real*8 xb,yb,zb real*8 xk,yk,zk real*8 gf1,gf2,weigh real*8 weigha,weighb real*8 mola,molb,molk real*8 cf1,cf2,vol real*8 c1,c2,c3 real*8 xi,yi,zi,ri real*8 rflat2 real*8 a,b,buffer,term real*8 xorig,xorig2 real*8 yorig,yorig2 real*8 zorig,zorig2 logical proceed,intermol c c c zero out the geometric restraint energy terms c eg = 0.0d0 c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c disable replica mechanism when computing restraint terms c if (use_replica) then xorig = xcell yorig = ycell zorig = zcell xorig2 = xcell2 yorig2 = ycell2 zorig2 = zcell2 xcell = xbox ycell = ybox zcell = zbox xcell2 = xbox2 ycell2 = ybox2 zcell2 = zbox2 end if c c compute the energy for position restraint terms c do i = 1, npfix ia = ipfix(i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,0,0,0,0,0) if (proceed) proceed = (use(ia)) if (proceed) then xr = 0.0d0 yr = 0.0d0 zr = 0.0d0 if (kpfix(1,i) .ne. 0) xr = x(ia) - xpfix(i) if (kpfix(2,i) .ne. 0) yr = y(ia) - ypfix(i) if (kpfix(3,i) .ne. 0) zr = z(ia) - zpfix(i) if (use_bounds) call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) force = pfix(1,i) dt = max(0.0d0,r-pfix(2,i)) dt2 = dt * dt e = force * dt2 if (use_group) e = e * fgrp eg = eg + e end if end do c c compute the energy for distance restraint terms c do i = 1, ndfix ia = idfix(1,i) ib = idfix(2,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,0,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib)) if (proceed) then xr = x(ia) - x(ib) yr = y(ia) - y(ib) zr = z(ia) - z(ib) intermol = (molcule(ia) .ne. molcule(ib)) if (use_bounds .and. intermol) call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) force = dfix(1,i) df1 = dfix(2,i) df2 = dfix(3,i) target = r if (r .lt. df1) target = df1 if (r .gt. df2) target = df2 dt = r - target dt2 = dt * dt e = force * dt2 if (use_group) e = e * fgrp eg = eg + e end if end do c c compute the energy for angle restraint terms c do i = 1, nafix ia = iafix(1,i) ib = iafix(2,i) ic = iafix(3,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. use(ic)) if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) force = afix(1,i) af1 = afix(2,i) af2 = afix(3,i) target = angle if (angle .lt. af1) target = af1 if (angle .gt. af2) target = af2 dt = angle - target dt = dt / radian dt2 = dt * dt e = force * dt2 if (use_group) e = e * fgrp eg = eg + e end if end do c c compute the energy for torsional restraint terms c do i = 1, ntfix ia = itfix(1,i) ib = itfix(2,i) ic = itfix(3,i) id = itfix(4,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xdc = xid - xic ydc = yid - yic zdc = zid - zic xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (sine .lt. 0.0d0) angle = -angle force = tfix(1,i) tf1 = tfix(2,i) tf2 = tfix(3,i) if (angle.gt.tf1 .and. angle.lt.tf2) then target = angle else if (angle.gt.tf1 .and. tf1.gt.tf2) then target = angle else if (angle.lt.tf2 .and. tf1.gt.tf2) then target = angle else t1 = angle - tf1 t2 = angle - tf2 if (t1 .gt. 180.0d0) then t1 = t1 - 360.0d0 else if (t1 .lt. -180.0d0) then t1 = t1 + 360.0d0 end if if (t2 .gt. 180.0d0) then t2 = t2 - 360.0d0 else if (t2 .lt. -180.0d0) then t2 = t2 + 360.0d0 end if if (abs(t1) .lt. abs(t2)) then target = tf1 else target = tf2 end if end if dt = angle - target if (dt .gt. 180.0d0) then dt = dt - 360.0d0 else if (dt .lt. -180.0d0) then dt = dt + 360.0d0 end if dt = dt / radian dt2 = dt * dt e = force * dt2 if (use_group) e = e * fgrp eg = eg + e end if end do c c compute the energy for group distance restraint terms c do i = 1, ngfix ia = igfix(1,i) ib = igfix(2,i) xa = 0.0d0 ya = 0.0d0 za = 0.0d0 j = kgrp(igrp(1,ia)) xr = x(j) yr = y(j) zr = z(j) mola = molcule(j) do j = igrp(1,ia), igrp(2,ia) k = kgrp(j) weigh = mass(k) xk = x(k) - xr yk = y(k) - yr zk = z(k) - zr molk = molcule(k) intermol = (molk .ne. mola) if (use_bounds .and. intermol) call image (xk,yk,zk) xa = xa + xk*weigh ya = ya + yk*weigh za = za + zk*weigh end do weigha = max(1.0d0,grpmass(ia)) xa = xr + xa/weigha ya = yr + ya/weigha za = zr + za/weigha xb = 0.0d0 yb = 0.0d0 zb = 0.0d0 j = kgrp(igrp(1,ib)) xr = x(j) yr = y(j) zr = z(j) molb = molcule(j) do j = igrp(1,ib), igrp(2,ib) k = kgrp(j) weigh = mass(k) xk = x(k) - xr yk = y(k) - yr zk = z(k) - zr molk = molcule(k) intermol = (molk .ne. molb) if (use_bounds .and. intermol) call image (xk,yk,zk) xb = xb + xk*weigh yb = yb + yk*weigh zb = zb + zk*weigh end do weighb = max(1.0d0,grpmass(ib)) xb = xr + xb/weighb yb = yr + yb/weighb zb = zr + zb/weighb xr = xa - xb yr = ya - yb zr = za - zb intermol = (mola .ne. molb) if (use_bounds .and. intermol) call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) force = gfix(1,i) gf1 = gfix(2,i) gf2 = gfix(3,i) target = r if (r .lt. gf1) target = gf1 if (r .gt. gf2) target = gf2 dt = r - target dt2 = dt * dt e = force * dt2 eg = eg + e end do c c compute the energy for chirality restraint terms c do i = 1, nchir ia = ichir(1,i) ib = ichir(2,i) ic = ichir(3,i) id = ichir(4,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) if (proceed) then xad = x(ia) - x(id) yad = y(ia) - y(id) zad = z(ia) - z(id) xbd = x(ib) - x(id) ybd = y(ib) - y(id) zbd = z(ib) - z(id) xcd = x(ic) - x(id) ycd = y(ic) - y(id) zcd = z(ic) - z(id) c1 = ybd*zcd - zbd*ycd c2 = ycd*zad - zcd*yad c3 = yad*zbd - zad*ybd vol = xad*c1 + xbd*c2 + xcd*c3 force = chir(1,i) cf1 = chir(2,i) cf2 = chir(3,i) target = vol if (vol .lt. min(cf1,cf2)) target = min(cf1,cf2) if (vol .gt. max(cf1,cf2)) target = max(cf1,cf2) dt = vol - target dt2 = dt * dt e = force * dt2 if (use_group) e = e * fgrp eg = eg + e end if end do c c compute the energy for a Gaussian basin restraint c if (use_basin) then rflat2 = rflat * rflat do i = 1, n-1 xi = x(i) yi = y(i) zi = z(i) do k = i+1, n proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (use(i) .or. use(k)) if (proceed) then xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) r2 = xr*xr + yr*yr + zr*zr r2 = max(0.0d0,r2-rflat2) term = -width * r2 e = 0.0d0 if (term .gt. -50.0d0) e = depth * exp(term) e = e - depth if (use_group) e = e * fgrp eg = eg + e end if end do end do end if c c compute the energy for a spherical droplet restraint c if (use_wall) then buffer = 2.5d0 a = 2048.0d0 b = 64.0d0 do i = 1, n proceed = .true. if (use_group) call groups (proceed,fgrp,i,0,0,0,0,0) if (proceed) proceed = (use(i)) if (proceed) then xi = x(i) yi = y(i) zi = z(i) ri = sqrt(xi**2 + yi**2 + zi**2) r = rwall + buffer - ri r2 = r * r r6 = r2 * r2 * r2 r12 = r6 * r6 e = a/r12 - b/r6 if (use_group) e = e * fgrp eg = eg + e end if end do end if c c reinstate the replica mechanism if it is being used c if (use_replica) then xcell = xorig ycell = yorig zcell = zorig xcell2 = xorig2 ycell2 = yorig2 zcell2 = zorig2 end if return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine egeom1 -- restraint energy & derivatives ## c ## ## c ############################################################# c c c "egeom1" calculates the energy and first derivatives c with respect to Cartesian coordinates due to restraints c on positions, distances, angles and torsions as well as c Gaussian basin and spherical droplet restraints c c subroutine egeom1 use atomid use atoms use bound use boxes use cell use deriv use energi use group use molcul use math use restrn use usage use virial implicit none integer i,j,k integer ia,ib,ic,id real*8 e,eps,fgrp real*8 de,dt,dt2,deddt real*8 xr,yr,zr real*8 r,r2,r6,r12 real*8 dedx,dedy,dedz real*8 angle,target real*8 dot,force real*8 cosine,sine real*8 terma,termc real*8 rab2,rcb2 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xab,yab,zab real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 xca,yca,zca real*8 xdb,ydb,zdb real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 xp,yp,zp,rp real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru real*8 rcb,dedphi real*8 dedxt,dedyt,dedzt real*8 dedxu,dedyu,dedzu real*8 dedxia,dedyia,dedzia real*8 dedxib,dedyib,dedzib real*8 dedxic,dedyic,dedzic real*8 dedxid,dedyid,dedzid real*8 df1,df2 real*8 af1,af2 real*8 tf1,tf2,t1,t2 real*8 xa,ya,za real*8 xb,yb,zb real*8 xk,yk,zk real*8 gf1,gf2 real*8 weigh,ratio real*8 weigha,weighb real*8 mola,molb,molk real*8 cf1,cf2,vol real*8 c1,c2,c3 real*8 xi,yi,zi,ri real*8 rflat2 real*8 a,b,buffer,term real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8 xorig,xorig2 real*8 yorig,yorig2 real*8 zorig,zorig2 logical proceed,intermol c c c zero out the restraint energy term and first derivatives c eg = 0.0d0 do i = 1, n deg(1,i) = 0.0d0 deg(2,i) = 0.0d0 deg(3,i) = 0.0d0 end do c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c disable replica mechanism when computing restraint terms c if (use_replica) then xorig = xcell yorig = ycell zorig = zcell xorig2 = xcell2 yorig2 = ycell2 zorig2 = zcell2 xcell = xbox ycell = ybox zcell = zbox xcell2 = xbox2 ycell2 = ybox2 zcell2 = zbox2 end if c c get energy and derivatives for position restraint terms c do i = 1, npfix ia = ipfix(i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,0,0,0,0,0) if (proceed) proceed = (use(ia)) if (proceed) then xr = 0.0d0 yr = 0.0d0 zr = 0.0d0 if (kpfix(1,i) .ne. 0) xr = x(ia) - xpfix(i) if (kpfix(2,i) .ne. 0) yr = y(ia) - ypfix(i) if (kpfix(3,i) .ne. 0) zr = z(ia) - zpfix(i) if (use_bounds) call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) force = pfix(1,i) dt = max(0.0d0,r-pfix(2,i)) dt2 = dt * dt e = force * dt2 de = 2.0d0 * force * dt / max(r,eps) c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c compute chain rule terms needed for derivatives c dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total energy and first derivatives c eg = eg + e deg(1,ia) = deg(1,ia) + dedx deg(2,ia) = deg(2,ia) + dedy deg(3,ia) = deg(3,ia) + dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 get energy and derivatives for distance restraint terms c do i = 1, ndfix ia = idfix(1,i) ib = idfix(2,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,0,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib)) if (proceed) then xr = x(ia) - x(ib) yr = y(ia) - y(ib) zr = z(ia) - z(ib) intermol = (molcule(ia) .ne. molcule(ib)) if (use_bounds .and. intermol) call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) force = dfix(1,i) df1 = dfix(2,i) df2 = dfix(3,i) target = r if (r .lt. df1) target = df1 if (r .gt. df2) target = df2 dt = r - target dt2 = dt * dt e = force * dt2 de = 2.0d0 * force * dt / max(r,eps) c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c compute chain rule terms needed for derivatives c dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total energy and first derivatives c eg = eg + e deg(1,ia) = deg(1,ia) + dedx deg(2,ia) = deg(2,ia) + dedy deg(3,ia) = deg(3,ia) + dedz deg(1,ib) = deg(1,ib) - dedx deg(2,ib) = deg(2,ib) - dedy deg(3,ib) = deg(3,ib) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 get energy and derivatives for angle restraint terms c do i = 1, nafix ia = iafix(1,i) ib = iafix(2,i) ic = iafix(3,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. use(ic)) if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) xp = ycb*zab - zcb*yab yp = zcb*xab - xcb*zab zp = xcb*yab - ycb*xab rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps)) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) force = afix(1,i) af1 = afix(2,i) af2 = afix(3,i) target = angle if (angle .lt. af1) target = af1 if (angle .gt. af2) target = af2 dt = angle - target dt = dt / radian dt2 = dt * dt e = force * dt2 deddt = 2.0d0 * force * dt c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp deddt = deddt * fgrp end if c c compute derivative components for this interaction c terma = -deddt / (rab2*rp) termc = deddt / (rcb2*rp) dedxia = terma * (yab*zp-zab*yp) dedyia = terma * (zab*xp-xab*zp) dedzia = terma * (xab*yp-yab*xp) dedxic = termc * (ycb*zp-zcb*yp) dedyic = termc * (zcb*xp-xcb*zp) dedzic = termc * (xcb*yp-ycb*xp) dedxib = -dedxia - dedxic dedyib = -dedyia - dedyic dedzib = -dedzia - dedzic c c increment the overall energy term and derivatives c eg = eg + e deg(1,ia) = deg(1,ia) + dedxia deg(2,ia) = deg(2,ia) + dedyia deg(3,ia) = deg(3,ia) + dedzia deg(1,ib) = deg(1,ib) + dedxib deg(2,ib) = deg(2,ib) + dedyib deg(3,ib) = deg(3,ib) + dedzib deg(1,ic) = deg(1,ic) + dedxic deg(2,ic) = deg(2,ic) + dedyic deg(3,ic) = deg(3,ic) + dedzic c c increment the internal virial tensor components c vxx = xab*dedxia + xcb*dedxic vyx = yab*dedxia + ycb*dedxic vzx = zab*dedxia + zcb*dedxic vyy = yab*dedyia + ycb*dedyic vzy = zab*dedyia + zcb*dedyic vzz = zab*dedzia + zcb*dedzic 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 get energy and derivatives for torsion restraint terms c do i = 1, ntfix ia = itfix(1,i) ib = itfix(2,i) ic = itfix(3,i) id = itfix(4,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xdc = xid - xic ydc = yid - yic zdc = zid - zic xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (sine .lt. 0.0d0) angle = -angle force = tfix(1,i) tf1 = tfix(2,i) tf2 = tfix(3,i) if (angle.gt.tf1 .and. angle.lt.tf2) then target = angle else if (angle.gt.tf1 .and. tf1.gt.tf2) then target = angle else if (angle.lt.tf2 .and. tf1.gt.tf2) then target = angle else t1 = angle - tf1 t2 = angle - tf2 if (t1 .gt. 180.0d0) then t1 = t1 - 360.0d0 else if (t1 .lt. -180.0d0) then t1 = t1 + 360.0d0 end if if (t2 .gt. 180.0d0) then t2 = t2 - 360.0d0 else if (t2 .lt. -180.0d0) then t2 = t2 + 360.0d0 end if if (abs(t1) .lt. abs(t2)) then target = tf1 else target = tf2 end if end if dt = angle - target if (dt .gt. 180.0d0) then dt = dt - 360.0d0 else if (dt .lt. -180.0d0) then dt = dt + 360.0d0 end if dt = dt / radian dt2 = dt * dt e = force * dt2 dedphi = 2.0d0 * force * dt c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp dedphi = dedphi * fgrp end if c c chain rule terms for first derivative components c xca = xic - xia yca = yic - yia zca = zic - zia xdb = xid - xib ydb = yid - yib zdb = zid - zib dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb) dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb) dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb) dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb) dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb) dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb) c c compute derivative components for this interaction c dedxia = zcb*dedyt - ycb*dedzt dedyia = xcb*dedzt - zcb*dedxt dedzia = ycb*dedxt - xcb*dedyt dedxib = yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu dedyib = zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu dedzib = xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu dedxic = zba*dedyt - yba*dedzt + ydb*dedzu - zdb*dedyu dedyic = xba*dedzt - zba*dedxt + zdb*dedxu - xdb*dedzu dedzic = yba*dedxt - xba*dedyt + xdb*dedyu - ydb*dedxu dedxid = zcb*dedyu - ycb*dedzu dedyid = xcb*dedzu - zcb*dedxu dedzid = ycb*dedxu - xcb*dedyu c c increment the overall energy term and derivatives c eg = eg + e deg(1,ia) = deg(1,ia) + dedxia deg(2,ia) = deg(2,ia) + dedyia deg(3,ia) = deg(3,ia) + dedzia deg(1,ib) = deg(1,ib) + dedxib deg(2,ib) = deg(2,ib) + dedyib deg(3,ib) = deg(3,ib) + dedzib deg(1,ic) = deg(1,ic) + dedxic deg(2,ic) = deg(2,ic) + dedyic deg(3,ic) = deg(3,ic) + dedzic deg(1,id) = deg(1,id) + dedxid deg(2,id) = deg(2,id) + dedyid deg(3,id) = deg(3,id) + dedzid c c increment the internal virial tensor components c vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid 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 get energy and derivatives for group distance restraint terms c do i = 1, ngfix ia = igfix(1,i) ib = igfix(2,i) xa = 0.0d0 ya = 0.0d0 za = 0.0d0 j = kgrp(igrp(1,ia)) xr = x(j) yr = y(j) zr = z(j) mola = molcule(j) do j = igrp(1,ia), igrp(2,ia) k = kgrp(j) weigh = mass(k) xk = x(k) - xr yk = y(k) - yr zk = z(k) - zr molk = molcule(k) intermol = (molk .ne. mola) if (use_bounds .and. intermol) call image (xk,yk,zk) xa = xa + xk*weigh ya = ya + yk*weigh za = za + zk*weigh end do weigha = max(1.0d0,grpmass(ia)) xa = xr + xa/weigha ya = yr + ya/weigha za = zr + za/weigha xb = 0.0d0 yb = 0.0d0 zb = 0.0d0 j = kgrp(igrp(1,ib)) xr = x(j) yr = y(j) zr = z(j) molb = molcule(j) do j = igrp(1,ib), igrp(2,ib) k = kgrp(j) weigh = mass(k) xk = x(k) - xr yk = y(k) - yr zk = z(k) - zr molk = molcule(k) intermol = (molk .ne. molb) if (use_bounds .and. intermol) call image (xk,yk,zk) xb = xb + xk*weigh yb = yb + yk*weigh zb = zb + zk*weigh end do weighb = max(1.0d0,grpmass(ib)) xb = xr + xb/weighb yb = yr + yb/weighb zb = zr + zb/weighb xr = xa - xb yr = ya - yb zr = za - zb intermol = (mola .ne. molb) if (use_bounds .and. intermol) call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) force = gfix(1,i) gf1 = gfix(2,i) gf2 = gfix(3,i) target = r if (r .lt. gf1) target = gf1 if (r .gt. gf2) target = gf2 dt = r - target dt2 = dt * dt e = force * dt2 de = 2.0d0 * force * dt / max(r,eps) c c compute chain rule terms needed for derivatives c dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total energy and first derivatives c eg = eg + e do j = igrp(1,ia), igrp(2,ia) k = kgrp(j) ratio = mass(k) / weigha deg(1,k) = deg(1,k) + dedx*ratio deg(2,k) = deg(2,k) + dedy*ratio deg(3,k) = deg(3,k) + dedz*ratio end do do j = igrp(1,ib), igrp(2,ib) k = kgrp(j) ratio = mass(k) / weighb deg(1,k) = deg(1,k) - dedx*ratio deg(2,k) = deg(2,k) - dedy*ratio deg(3,k) = deg(3,k) - dedz*ratio end do c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 do c c get energy and derivatives for chirality restraint terms c do i = 1, nchir ia = ichir(1,i) ib = ichir(2,i) ic = ichir(3,i) id = ichir(4,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) if (proceed) then xad = x(ia) - x(id) yad = y(ia) - y(id) zad = z(ia) - z(id) xbd = x(ib) - x(id) ybd = y(ib) - y(id) zbd = z(ib) - z(id) xcd = x(ic) - x(id) ycd = y(ic) - y(id) zcd = z(ic) - z(id) c1 = ybd*zcd - zbd*ycd c2 = ycd*zad - zcd*yad c3 = yad*zbd - zad*ybd vol = xad*c1 + xbd*c2 + xcd*c3 force = chir(1,i) cf1 = chir(2,i) cf2 = chir(3,i) target = vol if (vol .lt. min(cf1,cf2)) target = min(cf1,cf2) if (vol .gt. max(cf1,cf2)) target = max(cf1,cf2) dt = vol - target dt2 = dt * dt e = force * dt2 deddt = 2.0d0 * force * dt c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp deddt = deddt * fgrp end if c c compute derivative components for this interaction c dedxia = deddt * (ybd*zcd - zbd*ycd) dedyia = deddt * (zbd*xcd - xbd*zcd) dedzia = deddt * (xbd*ycd - ybd*xcd) dedxib = deddt * (zad*ycd - yad*zcd) dedyib = deddt * (xad*zcd - zad*xcd) dedzib = deddt * (yad*xcd - xad*ycd) dedxic = deddt * (yad*zbd - zad*ybd) dedyic = deddt * (zad*xbd - xad*zbd) dedzic = deddt * (xad*ybd - yad*xbd) dedxid = -dedxia - dedxib - dedxic dedyid = -dedyia - dedyib - dedyic dedzid = -dedzia - dedzib - dedzic c c increment the overall energy term and derivatives c eg = eg + e deg(1,ia) = deg(1,ia) + dedxia deg(2,ia) = deg(2,ia) + dedyia deg(3,ia) = deg(3,ia) + dedzia deg(1,ib) = deg(1,ib) + dedxib deg(2,ib) = deg(2,ib) + dedyib deg(3,ib) = deg(3,ib) + dedzib deg(1,ic) = deg(1,ic) + dedxic deg(2,ic) = deg(2,ic) + dedyic deg(3,ic) = deg(3,ic) + dedzic deg(1,id) = deg(1,id) + dedxid deg(2,id) = deg(2,id) + dedyid deg(3,id) = deg(3,id) + dedzid c c increment the internal virial tensor components c vxx = xad*dedxia + xbd*dedxib + xcd*dedxic vyx = yad*dedxia + ybd*dedxib + ycd*dedxic vzx = zad*dedxia + zbd*dedxib + zcd*dedxic vyy = yad*dedyia + ybd*dedyib + ycd*dedyic vzy = zad*dedyia + zbd*dedyib + zcd*dedyic vzz = zad*dedzia + zbd*dedzib + zcd*dedzic 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 get energy and derivatives for a Gaussian basin restraint c if (use_basin) then rflat2 = rflat * rflat do i = 1, n-1 xi = x(i) yi = y(i) zi = z(i) do k = i+1, n proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (use(i) .or. use(k)) if (proceed) then xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) r2 = xr*xr + yr*yr + zr*zr r2 = max(0.0d0,r2-rflat2) term = -width * r2 e = 0.0d0 if (term .gt. -50.0d0) e = depth * exp(term) de = -2.0d0 * width * e e = e - depth c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c compute chain rule terms needed for derivatives c dedx = de * xr dedy = de * yr dedz = de * zr c c increment the overall energy term and derivatives c eg = eg + e deg(1,i) = deg(1,i) + dedx deg(2,i) = deg(2,i) + dedy deg(3,i) = deg(3,i) + dedz deg(1,k) = deg(1,k) - dedx deg(2,k) = deg(2,k) - dedy deg(3,k) = deg(3,k) - dedz c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 end if c c get energy and derivatives for a spherical droplet restraint c if (use_wall) then buffer = 2.5d0 a = 2048.0d0 b = 64.0d0 do i = 1, n proceed = .true. if (use_group) call groups (proceed,fgrp,i,0,0,0,0,0) if (proceed) proceed = (use(i)) if (proceed) then xi = x(i) yi = y(i) zi = z(i) ri = sqrt(xi**2 + yi**2 + zi**2) r = rwall + buffer - ri r2 = r * r r6 = r2 * r2 * r2 r12 = r6 * r6 e = a/r12 - b/r6 if (ri .eq. 0.0d0) ri = 1.0d0 de = (12.0d0*a/r12 - 6.0d0*b/r6) / (r*ri) c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c compute chain rule terms needed for derivatives c dedx = de * xi dedy = de * yi dedz = de * zi c c increment the overall energy term and derivatives c eg = eg + e deg(1,i) = deg(1,i) + dedx deg(2,i) = deg(2,i) + dedy deg(3,i) = deg(3,i) + dedz c c increment the internal virial tensor components c xr = r * xi/ri yr = r * yi/ri zr = r * zi/ri vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if c c reinstate the replica mechanism if it is being used c if (use_replica) then xcell = xorig ycell = yorig zcell = zorig xcell2 = xorig2 ycell2 = yorig2 zcell2 = zorig2 end if return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine egeom2 -- atom-by-atom restraint Hessian ## c ## ## c ############################################################# c c c "egeom2" calculates second derivatives of restraints c on positions, distances, angles and torsions as well c as Gaussian basin and spherical droplet restraints c c note that the Hessian is discontinuous when an upper and c lower bound range is used instead of a single distance c c subroutine egeom2 (i) use atomid use atoms use bound use boxes use cell use deriv use group use hessn use math use molcul use restrn implicit none integer i,j,k,m integer ia,ib,ic,id integer kpos,kdist,kang integer ktors,kchir real*8 eps,fgrp real*8 xr,yr,zr real*8 target,force real*8 dot,angle real*8 cosine,sine real*8 dt,dt2,deddt real*8 term,terma,termc real*8 termx,termy,termz real*8 de,d2eddt2 real*8 d2e(3,3) real*8 dedphi,d2edphi2 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xab,yab,zab real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 xca,yca,zca real*8 xdb,ydb,zdb real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 xrab,yrab,zrab real*8 xrcb,yrcb,zrcb real*8 xabp,yabp,zabp real*8 xcbp,ycbp,zcbp real*8 rab2,rcb2 real*8 xpo,ypo,zpo real*8 xp,yp,zp,rp,rp2 real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru,rcb real*8 df1,df2,af1,af2 real*8 tf1,tf2,t1,t2 real*8 xa,ya,za real*8 xb,yb,zb real*8 xk,yk,zk real*8 gf1,gf2 real*8 weigh,ratio real*8 weigha,weighb real*8 mola,molb,molk real*8 cf1,cf2,vol real*8 c1,c2,c3 real*8 ddtdxia,ddtdyia,ddtdzia real*8 ddtdxib,ddtdyib,ddtdzib real*8 ddtdxic,ddtdyic,ddtdzic real*8 dphidxt,dphidyt,dphidzt real*8 dphidxu,dphidyu,dphidzu real*8 dphidxia,dphidyia,dphidzia real*8 dphidxib,dphidyib,dphidzib real*8 dphidxic,dphidyic,dphidzic real*8 dphidxid,dphidyid,dphidzid real*8 xycb2,xzcb2,yzcb2 real*8 rcbxt,rcbyt,rcbzt,rcbt2 real*8 rcbxu,rcbyu,rcbzu,rcbu2 real*8 dphidxibt,dphidyibt,dphidzibt real*8 dphidxibu,dphidyibu,dphidzibu real*8 dphidxict,dphidyict,dphidzict real*8 dphidxicu,dphidyicu,dphidzicu real*8 dxiaxia,dyiayia,dziazia real*8 dxibxib,dyibyib,dzibzib real*8 dxicxic,dyicyic,dziczic real*8 dxidxid,dyidyid,dzidzid real*8 dxiayia,dxiazia,dyiazia real*8 dxibyib,dxibzib,dyibzib real*8 dxicyic,dxiczic,dyiczic real*8 dxidyid,dxidzid,dyidzid real*8 dxiaxib,dxiayib,dxiazib real*8 dyiaxib,dyiayib,dyiazib real*8 dziaxib,dziayib,dziazib real*8 dxiaxic,dxiayic,dxiazic real*8 dyiaxic,dyiayic,dyiazic real*8 dziaxic,dziayic,dziazic real*8 dxiaxid,dxiayid,dxiazid real*8 dyiaxid,dyiayid,dyiazid real*8 dziaxid,dziayid,dziazid real*8 dxibxia,dxibyia,dxibzia real*8 dyibxia,dyibyia,dyibzia real*8 dzibxia,dzibyia,dzibzia real*8 dxibxic,dxibyic,dxibzic real*8 dyibxic,dyibyic,dyibzic real*8 dzibxic,dzibyic,dzibzic real*8 dxibxid,dxibyid,dxibzid real*8 dyibxid,dyibyid,dyibzid real*8 dzibxid,dzibyid,dzibzid real*8 dxicxid,dxicyid,dxiczid real*8 dyicxid,dyicyid,dyiczid real*8 dzicxid,dzicyid,dziczid real*8 ddtdxid,ddtdyid,ddtdzid real*8 dedr,d2edr2,expterm real*8 xi,yi,zi,ri,ri2 real*8 r,r2,r6,r12 real*8 rflat2 real*8 a,b,buffer real*8 xorig,xorig2 real*8 yorig,yorig2 real*8 zorig,zorig2 logical proceed,intermol,linear c c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c disable replica mechanism when computing restraint terms c if (use_replica) then xorig = xcell yorig = ycell zorig = zcell xorig2 = xcell2 yorig2 = ycell2 zorig2 = zcell2 xcell = xbox ycell = ybox zcell = zbox xcell2 = xbox2 ycell2 = ybox2 zcell2 = zbox2 end if c c compute the Hessian elements for position restraints c do kpos = 1, npfix ia = ipfix(kpos) proceed = (i .eq. ia) if (proceed .and. use_group) & call groups (proceed,fgrp,ia,0,0,0,0,0) if (proceed) then xr = 0.0d0 yr = 0.0d0 zr = 0.0d0 if (kpfix(1,i) .ne. 0) xr = x(ia) - xpfix(kpos) if (kpfix(2,i) .ne. 0) yr = y(ia) - ypfix(kpos) if (kpfix(3,i) .ne. 0) zr = z(ia) - zpfix(kpos) if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr r = sqrt(r2) force = pfix(1,kpos) dt = max(0.0d0,r-pfix(2,kpos)) dt2 = dt * dt deddt = 2.0d0 * force c c scale the interaction based on its group membership c if (use_group) deddt = deddt * fgrp c c set the chain rule terms for the Hessian elements c r = max(r,eps) r2 = r * r de = deddt * dt/r term = (deddt-de) / r2 termx = term * xr termy = term * yr termz = term * zr d2e(1,1) = termx*xr + de d2e(1,2) = termx*yr d2e(1,3) = termx*zr d2e(2,1) = d2e(1,2) d2e(2,2) = termy*yr + de d2e(2,3) = termy*zr d2e(3,1) = d2e(1,3) d2e(3,2) = d2e(2,3) d2e(3,3) = termz*zr + de c c increment diagonal and non-diagonal Hessian elements c do j = 1, 3 hessx(j,ia) = hessx(j,ia) + d2e(1,j) hessy(j,ia) = hessy(j,ia) + d2e(2,j) hessz(j,ia) = hessz(j,ia) + d2e(3,j) end do end if end do c c compute the Hessian elements for distance restraints c do kdist = 1, ndfix ia = idfix(1,kdist) ib = idfix(2,kdist) proceed = (i.eq.ia .or. i.eq.ib) if (proceed .and. use_group) & call groups (proceed,fgrp,ia,ib,0,0,0,0) if (proceed) then if (i .eq. ib) then ib = ia ia = i end if xr = x(ia) - x(ib) yr = y(ia) - y(ib) zr = z(ia) - z(ib) intermol = (molcule(ia) .ne. molcule(ib)) if (use_bounds .and. intermol) call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr r = sqrt(r2) force = dfix(1,kdist) df1 = dfix(2,kdist) df2 = dfix(3,kdist) target = r if (r .lt. df1) target = df1 if (r .gt. df2) target = df2 dt = r - target deddt = 2.0d0 * force c c scale the interaction based on its group membership c if (use_group) deddt = deddt * fgrp c c set the chain rule terms for the Hessian elements c r = max(r,eps) r2 = r * r de = deddt * dt/r term = (deddt-de) / r2 termx = term * xr termy = term * yr termz = term * zr d2e(1,1) = termx*xr + de d2e(1,2) = termx*yr d2e(1,3) = termx*zr d2e(2,1) = d2e(1,2) d2e(2,2) = termy*yr + de d2e(2,3) = termy*zr d2e(3,1) = d2e(1,3) d2e(3,2) = d2e(2,3) d2e(3,3) = termz*zr + de c c increment diagonal and non-diagonal Hessian elements c do j = 1, 3 hessx(j,ia) = hessx(j,ia) + d2e(1,j) hessy(j,ia) = hessy(j,ia) + d2e(2,j) hessz(j,ia) = hessz(j,ia) + d2e(3,j) hessx(j,ib) = hessx(j,ib) - d2e(1,j) hessy(j,ib) = hessy(j,ib) - d2e(2,j) hessz(j,ib) = hessz(j,ib) - d2e(3,j) end do end if end do c c compute the Hessian elements for angle restraints c do kang = 1, nafix ia = iafix(1,kang) ib = iafix(2,kang) ic = iafix(3,kang) proceed = (i.eq.ia .or. i.eq.ib .or. i.eq.ic) if (proceed .and. use_group) & call groups (proceed,fgrp,ia,ib,ic,0,0,0) if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) xp = ycb*zab - zcb*yab yp = zcb*xab - xcb*zab zp = xcb*yab - ycb*xab rp = sqrt(max(xp*xp+yp*yp+zp*zp,eps)) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) force = afix(1,kang) af1 = afix(2,kang) af2 = afix(3,kang) target = angle if (angle .lt. af1) target = af1 if (angle .gt. af2) target = af2 dt = angle - target dt = dt / radian dt2 = dt * dt deddt = 2.0d0 * force * dt d2eddt2 = 2.0d0 * force c c scale the interaction based on its group membership c if (use_group) then deddt = deddt * fgrp d2eddt2 = d2eddt2 * fgrp end if c c construct an orthogonal direction for linear angles c linear = .false. if (rp .lt. eps) then linear = .true. if (xab.ne.0.0d0 .and. yab.ne.0.0d0) then xp = -yab yp = xab zp = 0.0d0 else if (xab.eq.0.0d0 .and. yab.eq.0.0d0) then xp = 1.0d0 yp = 0.0d0 zp = 0.0d0 else if (xab.ne.0.0d0 .and. yab.eq.0.0d0) then xp = 0.0d0 yp = 1.0d0 zp = 0.0d0 else if (xab.eq.0.0d0 .and. yab.ne.0.0d0) then xp = 1.0d0 yp = 0.0d0 zp = 0.0d0 end if rp = sqrt(xp*xp + yp*yp + zp*zp) end if c c first derivatives of bond angle with respect to coordinates c 10 continue terma = -1.0d0 / (rab2*rp) termc = 1.0d0 / (rcb2*rp) ddtdxia = terma * (yab*zp-zab*yp) ddtdyia = terma * (zab*xp-xab*zp) ddtdzia = terma * (xab*yp-yab*xp) ddtdxic = termc * (ycb*zp-zcb*yp) ddtdyic = termc * (zcb*xp-xcb*zp) ddtdzic = termc * (xcb*yp-ycb*xp) ddtdxib = -ddtdxia - ddtdxic ddtdyib = -ddtdyia - ddtdyic ddtdzib = -ddtdzia - ddtdzic c c abbreviations used in defining chain rule terms c xrab = 2.0d0 * xab / rab2 yrab = 2.0d0 * yab / rab2 zrab = 2.0d0 * zab / rab2 xrcb = 2.0d0 * xcb / rcb2 yrcb = 2.0d0 * ycb / rcb2 zrcb = 2.0d0 * zcb / rcb2 rp2 = 1.0d0 / (rp*rp) xabp = (yab*zp-zab*yp) * rp2 yabp = (zab*xp-xab*zp) * rp2 zabp = (xab*yp-yab*xp) * rp2 xcbp = (ycb*zp-zcb*yp) * rp2 ycbp = (zcb*xp-xcb*zp) * rp2 zcbp = (xcb*yp-ycb*xp) * rp2 c c chain rule terms for second derivative components c dxiaxia = terma*(xab*xcb-dot) + ddtdxia*(xcbp-xrab) dxiayia = terma*(zp+yab*xcb) + ddtdxia*(ycbp-yrab) dxiazia = terma*(zab*xcb-yp) + ddtdxia*(zcbp-zrab) dyiayia = terma*(yab*ycb-dot) + ddtdyia*(ycbp-yrab) dyiazia = terma*(xp+zab*ycb) + ddtdyia*(zcbp-zrab) dziazia = terma*(zab*zcb-dot) + ddtdzia*(zcbp-zrab) dxicxic = termc*(dot-xab*xcb) - ddtdxic*(xabp+xrcb) dxicyic = termc*(zp-ycb*xab) - ddtdxic*(yabp+yrcb) dxiczic = -termc*(yp+zcb*xab) - ddtdxic*(zabp+zrcb) dyicyic = termc*(dot-yab*ycb) - ddtdyic*(yabp+yrcb) dyiczic = termc*(xp-zcb*yab) - ddtdyic*(zabp+zrcb) dziczic = termc*(dot-zab*zcb) - ddtdzic*(zabp+zrcb) dxiaxic = terma*(yab*yab+zab*zab) - ddtdxia*xabp dxiayic = -terma*xab*yab - ddtdxia*yabp dxiazic = -terma*xab*zab - ddtdxia*zabp dyiaxic = -terma*xab*yab - ddtdyia*xabp dyiayic = terma*(xab*xab+zab*zab) - ddtdyia*yabp dyiazic = -terma*yab*zab - ddtdyia*zabp dziaxic = -terma*xab*zab - ddtdzia*xabp dziayic = -terma*yab*zab - ddtdzia*yabp dziazic = terma*(xab*xab+yab*yab) - ddtdzia*zabp c c get some second derivative chain rule terms by difference c dxibxia = -dxiaxia - dxiaxic dxibyia = -dxiayia - dyiaxic dxibzia = -dxiazia - dziaxic dyibxia = -dxiayia - dxiayic dyibyia = -dyiayia - dyiayic dyibzia = -dyiazia - dziayic dzibxia = -dxiazia - dxiazic dzibyia = -dyiazia - dyiazic dzibzia = -dziazia - dziazic dxibxic = -dxicxic - dxiaxic dxibyic = -dxicyic - dxiayic dxibzic = -dxiczic - dxiazic dyibxic = -dxicyic - dyiaxic dyibyic = -dyicyic - dyiayic dyibzic = -dyiczic - dyiazic dzibxic = -dxiczic - dziaxic dzibyic = -dyiczic - dziayic dzibzic = -dziczic - dziazic dxibxib = -dxibxia - dxibxic dxibyib = -dxibyia - dxibyic dxibzib = -dxibzia - dxibzic dyibyib = -dyibyia - dyibyic dyibzib = -dyibzia - dyibzic dzibzib = -dzibzia - dzibzic c c increment diagonal and off-diagonal Hessian elements c if (ia .eq. i) then hessx(1,ia) = hessx(1,ia) + deddt*dxiaxia & + d2eddt2*ddtdxia*ddtdxia hessx(2,ia) = hessx(2,ia) + deddt*dxiayia & + d2eddt2*ddtdxia*ddtdyia hessx(3,ia) = hessx(3,ia) + deddt*dxiazia & + d2eddt2*ddtdxia*ddtdzia hessy(1,ia) = hessy(1,ia) + deddt*dxiayia & + d2eddt2*ddtdyia*ddtdxia hessy(2,ia) = hessy(2,ia) + deddt*dyiayia & + d2eddt2*ddtdyia*ddtdyia hessy(3,ia) = hessy(3,ia) + deddt*dyiazia & + d2eddt2*ddtdyia*ddtdzia hessz(1,ia) = hessz(1,ia) + deddt*dxiazia & + d2eddt2*ddtdzia*ddtdxia hessz(2,ia) = hessz(2,ia) + deddt*dyiazia & + d2eddt2*ddtdzia*ddtdyia hessz(3,ia) = hessz(3,ia) + deddt*dziazia & + d2eddt2*ddtdzia*ddtdzia hessx(1,ib) = hessx(1,ib) + deddt*dxibxia & + d2eddt2*ddtdxia*ddtdxib hessx(2,ib) = hessx(2,ib) + deddt*dyibxia & + d2eddt2*ddtdxia*ddtdyib hessx(3,ib) = hessx(3,ib) + deddt*dzibxia & + d2eddt2*ddtdxia*ddtdzib hessy(1,ib) = hessy(1,ib) + deddt*dxibyia & + d2eddt2*ddtdyia*ddtdxib hessy(2,ib) = hessy(2,ib) + deddt*dyibyia & + d2eddt2*ddtdyia*ddtdyib hessy(3,ib) = hessy(3,ib) + deddt*dzibyia & + d2eddt2*ddtdyia*ddtdzib hessz(1,ib) = hessz(1,ib) + deddt*dxibzia & + d2eddt2*ddtdzia*ddtdxib hessz(2,ib) = hessz(2,ib) + deddt*dyibzia & + d2eddt2*ddtdzia*ddtdyib hessz(3,ib) = hessz(3,ib) + deddt*dzibzia & + d2eddt2*ddtdzia*ddtdzib hessx(1,ic) = hessx(1,ic) + deddt*dxiaxic & + d2eddt2*ddtdxia*ddtdxic hessx(2,ic) = hessx(2,ic) + deddt*dxiayic & + d2eddt2*ddtdxia*ddtdyic hessx(3,ic) = hessx(3,ic) + deddt*dxiazic & + d2eddt2*ddtdxia*ddtdzic hessy(1,ic) = hessy(1,ic) + deddt*dyiaxic & + d2eddt2*ddtdyia*ddtdxic hessy(2,ic) = hessy(2,ic) + deddt*dyiayic & + d2eddt2*ddtdyia*ddtdyic hessy(3,ic) = hessy(3,ic) + deddt*dyiazic & + d2eddt2*ddtdyia*ddtdzic hessz(1,ic) = hessz(1,ic) + deddt*dziaxic & + d2eddt2*ddtdzia*ddtdxic hessz(2,ic) = hessz(2,ic) + deddt*dziayic & + d2eddt2*ddtdzia*ddtdyic hessz(3,ic) = hessz(3,ic) + deddt*dziazic & + d2eddt2*ddtdzia*ddtdzic else if (ib .eq. i) then hessx(1,ib) = hessx(1,ib) + deddt*dxibxib & + d2eddt2*ddtdxib*ddtdxib hessx(2,ib) = hessx(2,ib) + deddt*dxibyib & + d2eddt2*ddtdxib*ddtdyib hessx(3,ib) = hessx(3,ib) + deddt*dxibzib & + d2eddt2*ddtdxib*ddtdzib hessy(1,ib) = hessy(1,ib) + deddt*dxibyib & + d2eddt2*ddtdyib*ddtdxib hessy(2,ib) = hessy(2,ib) + deddt*dyibyib & + d2eddt2*ddtdyib*ddtdyib hessy(3,ib) = hessy(3,ib) + deddt*dyibzib & + d2eddt2*ddtdyib*ddtdzib hessz(1,ib) = hessz(1,ib) + deddt*dxibzib & + d2eddt2*ddtdzib*ddtdxib hessz(2,ib) = hessz(2,ib) + deddt*dyibzib & + d2eddt2*ddtdzib*ddtdyib hessz(3,ib) = hessz(3,ib) + deddt*dzibzib & + d2eddt2*ddtdzib*ddtdzib hessx(1,ia) = hessx(1,ia) + deddt*dxibxia & + d2eddt2*ddtdxib*ddtdxia hessx(2,ia) = hessx(2,ia) + deddt*dxibyia & + d2eddt2*ddtdxib*ddtdyia hessx(3,ia) = hessx(3,ia) + deddt*dxibzia & + d2eddt2*ddtdxib*ddtdzia hessy(1,ia) = hessy(1,ia) + deddt*dyibxia & + d2eddt2*ddtdyib*ddtdxia hessy(2,ia) = hessy(2,ia) + deddt*dyibyia & + d2eddt2*ddtdyib*ddtdyia hessy(3,ia) = hessy(3,ia) + deddt*dyibzia & + d2eddt2*ddtdyib*ddtdzia hessz(1,ia) = hessz(1,ia) + deddt*dzibxia & + d2eddt2*ddtdzib*ddtdxia hessz(2,ia) = hessz(2,ia) + deddt*dzibyia & + d2eddt2*ddtdzib*ddtdyia hessz(3,ia) = hessz(3,ia) + deddt*dzibzia & + d2eddt2*ddtdzib*ddtdzia hessx(1,ic) = hessx(1,ic) + deddt*dxibxic & + d2eddt2*ddtdxib*ddtdxic hessx(2,ic) = hessx(2,ic) + deddt*dxibyic & + d2eddt2*ddtdxib*ddtdyic hessx(3,ic) = hessx(3,ic) + deddt*dxibzic & + d2eddt2*ddtdxib*ddtdzic hessy(1,ic) = hessy(1,ic) + deddt*dyibxic & + d2eddt2*ddtdyib*ddtdxic hessy(2,ic) = hessy(2,ic) + deddt*dyibyic & + d2eddt2*ddtdyib*ddtdyic hessy(3,ic) = hessy(3,ic) + deddt*dyibzic & + d2eddt2*ddtdyib*ddtdzic hessz(1,ic) = hessz(1,ic) + deddt*dzibxic & + d2eddt2*ddtdzib*ddtdxic hessz(2,ic) = hessz(2,ic) + deddt*dzibyic & + d2eddt2*ddtdzib*ddtdyic hessz(3,ic) = hessz(3,ic) + deddt*dzibzic & + d2eddt2*ddtdzib*ddtdzic else if (ic .eq. i) then hessx(1,ic) = hessx(1,ic) + deddt*dxicxic & + d2eddt2*ddtdxic*ddtdxic hessx(2,ic) = hessx(2,ic) + deddt*dxicyic & + d2eddt2*ddtdxic*ddtdyic hessx(3,ic) = hessx(3,ic) + deddt*dxiczic & + d2eddt2*ddtdxic*ddtdzic hessy(1,ic) = hessy(1,ic) + deddt*dxicyic & + d2eddt2*ddtdyic*ddtdxic hessy(2,ic) = hessy(2,ic) + deddt*dyicyic & + d2eddt2*ddtdyic*ddtdyic hessy(3,ic) = hessy(3,ic) + deddt*dyiczic & + d2eddt2*ddtdyic*ddtdzic hessz(1,ic) = hessz(1,ic) + deddt*dxiczic & + d2eddt2*ddtdzic*ddtdxic hessz(2,ic) = hessz(2,ic) + deddt*dyiczic & + d2eddt2*ddtdzic*ddtdyic hessz(3,ic) = hessz(3,ic) + deddt*dziczic & + d2eddt2*ddtdzic*ddtdzic hessx(1,ib) = hessx(1,ib) + deddt*dxibxic & + d2eddt2*ddtdxic*ddtdxib hessx(2,ib) = hessx(2,ib) + deddt*dyibxic & + d2eddt2*ddtdxic*ddtdyib hessx(3,ib) = hessx(3,ib) + deddt*dzibxic & + d2eddt2*ddtdxic*ddtdzib hessy(1,ib) = hessy(1,ib) + deddt*dxibyic & + d2eddt2*ddtdyic*ddtdxib hessy(2,ib) = hessy(2,ib) + deddt*dyibyic & + d2eddt2*ddtdyic*ddtdyib hessy(3,ib) = hessy(3,ib) + deddt*dzibyic & + d2eddt2*ddtdyic*ddtdzib hessz(1,ib) = hessz(1,ib) + deddt*dxibzic & + d2eddt2*ddtdzic*ddtdxib hessz(2,ib) = hessz(2,ib) + deddt*dyibzic & + d2eddt2*ddtdzic*ddtdyib hessz(3,ib) = hessz(3,ib) + deddt*dzibzic & + d2eddt2*ddtdzic*ddtdzib hessx(1,ia) = hessx(1,ia) + deddt*dxiaxic & + d2eddt2*ddtdxic*ddtdxia hessx(2,ia) = hessx(2,ia) + deddt*dyiaxic & + d2eddt2*ddtdxic*ddtdyia hessx(3,ia) = hessx(3,ia) + deddt*dziaxic & + d2eddt2*ddtdxic*ddtdzia hessy(1,ia) = hessy(1,ia) + deddt*dxiayic & + d2eddt2*ddtdyic*ddtdxia hessy(2,ia) = hessy(2,ia) + deddt*dyiayic & + d2eddt2*ddtdyic*ddtdyia hessy(3,ia) = hessy(3,ia) + deddt*dziayic & + d2eddt2*ddtdyic*ddtdzia hessz(1,ia) = hessz(1,ia) + deddt*dxiazic & + d2eddt2*ddtdzic*ddtdxia hessz(2,ia) = hessz(2,ia) + deddt*dyiazic & + d2eddt2*ddtdzic*ddtdyia hessz(3,ia) = hessz(3,ia) + deddt*dziazic & + d2eddt2*ddtdzic*ddtdzia end if c c construct a second orthogonal direction for linear angles c if (linear) then linear = .false. xpo = xp ypo = yp zpo = zp xp = ypo*zab - zpo*yab yp = zpo*xab - xpo*zab zp = xpo*yab - ypo*xab rp = sqrt(xp*xp + yp*yp + zp*zp) goto 10 end if end if end do c c compute the Hessian elements for torsion restraints c do ktors = 1, ntfix ia = itfix(1,ktors) ib = itfix(2,ktors) ic = itfix(3,ktors) id = itfix(4,ktors) 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) if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xdc = xid - xic ydc = yid - yic zdc = zid - zic xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (sine .lt. 0.0d0) angle = -angle force = tfix(1,ktors) tf1 = tfix(2,ktors) tf2 = tfix(3,ktors) if (angle.gt.tf1 .and. angle.lt.tf2) then target = angle else if (angle.gt.tf1 .and. tf1.gt.tf2) then target = angle else if (angle.lt.tf2 .and. tf1.gt.tf2) then target = angle else t1 = angle - tf1 t2 = angle - tf2 if (t1 .gt. 180.0d0) then t1 = t1 - 360.0d0 else if (t1 .lt. -180.0d0) then t1 = t1 + 360.0d0 end if if (t2 .gt. 180.0d0) then t2 = t2 - 360.0d0 else if (t2 .lt. -180.0d0) then t2 = t2 + 360.0d0 end if if (abs(t1) .lt. abs(t2)) then target = tf1 else target = tf2 end if end if dt = angle - target if (dt .gt. 180.0d0) then dt = dt - 360.0d0 else if (dt .lt. -180.0d0) then dt = dt + 360.0d0 end if dt = dt / radian dedphi = 2.0d0 * force * dt d2edphi2 = 2.0d0 * force c c scale the interaction based on its group membership c if (use_group) then dedphi = dedphi * fgrp d2edphi2 = d2edphi2 * fgrp end if c c abbreviations for first derivative chain rule terms c xca = xic - xia yca = yic - yia zca = zic - zia xdb = xid - xib ydb = yid - yib zdb = zid - zib dphidxt = (yt*zcb - ycb*zt) / (rt2*rcb) dphidyt = (zt*xcb - zcb*xt) / (rt2*rcb) dphidzt = (xt*ycb - xcb*yt) / (rt2*rcb) dphidxu = -(yu*zcb - ycb*zu) / (ru2*rcb) dphidyu = -(zu*xcb - zcb*xu) / (ru2*rcb) dphidzu = -(xu*ycb - xcb*yu) / (ru2*rcb) c c abbreviations for second derivative chain rule terms c xycb2 = xcb*xcb + ycb*ycb xzcb2 = xcb*xcb + zcb*zcb yzcb2 = ycb*ycb + zcb*zcb rcbxt = -2.0d0 * rcb * dphidxt rcbyt = -2.0d0 * rcb * dphidyt rcbzt = -2.0d0 * rcb * dphidzt rcbt2 = rcb * rt2 rcbxu = 2.0d0 * rcb * dphidxu rcbyu = 2.0d0 * rcb * dphidyu rcbzu = 2.0d0 * rcb * dphidzu rcbu2 = rcb * ru2 dphidxibt = yca*dphidzt - zca*dphidyt dphidxibu = zdc*dphidyu - ydc*dphidzu dphidyibt = zca*dphidxt - xca*dphidzt dphidyibu = xdc*dphidzu - zdc*dphidxu dphidzibt = xca*dphidyt - yca*dphidxt dphidzibu = ydc*dphidxu - xdc*dphidyu dphidxict = zba*dphidyt - yba*dphidzt dphidxicu = ydb*dphidzu - zdb*dphidyu dphidyict = xba*dphidzt - zba*dphidxt dphidyicu = zdb*dphidxu - xdb*dphidzu dphidzict = yba*dphidxt - xba*dphidyt dphidzicu = xdb*dphidyu - ydb*dphidxu c c chain rule terms for first derivative components c dphidxia = zcb*dphidyt - ycb*dphidzt dphidyia = xcb*dphidzt - zcb*dphidxt dphidzia = ycb*dphidxt - xcb*dphidyt dphidxib = dphidxibt + dphidxibu dphidyib = dphidyibt + dphidyibu dphidzib = dphidzibt + dphidzibu dphidxic = dphidxict + dphidxicu dphidyic = dphidyict + dphidyicu dphidzic = dphidzict + dphidzicu dphidxid = zcb*dphidyu - ycb*dphidzu dphidyid = xcb*dphidzu - zcb*dphidxu dphidzid = ycb*dphidxu - xcb*dphidyu c c chain rule terms for second derivative components c dxiaxia = rcbxt*dphidxia dxiayia = rcbxt*dphidyia - zcb*rcb/rt2 dxiazia = rcbxt*dphidzia + ycb*rcb/rt2 dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2 dxiayic = rcbxt*dphidyict - dphidzt & - (xba*zcb*xcb+zba*yzcb2)/rcbt2 dxiazic = rcbxt*dphidzict + dphidyt & + (xba*ycb*xcb+yba*yzcb2)/rcbt2 dxiaxid = 0.0d0 dxiayid = 0.0d0 dxiazid = 0.0d0 dyiayia = rcbyt*dphidyia dyiazia = rcbyt*dphidzia - xcb*rcb/rt2 dyiaxib = rcbyt*dphidxibt - dphidzt & - (yca*zcb*ycb+zca*xzcb2)/rcbt2 dyiaxic = rcbyt*dphidxict + dphidzt & + (yba*zcb*ycb+zba*xzcb2)/rcbt2 dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2 dyiazic = rcbyt*dphidzict - dphidxt & - (yba*xcb*ycb+xba*xzcb2)/rcbt2 dyiaxid = 0.0d0 dyiayid = 0.0d0 dyiazid = 0.0d0 dziazia = rcbzt*dphidzia dziaxib = rcbzt*dphidxibt + dphidyt & + (zca*ycb*zcb+yca*xycb2)/rcbt2 dziayib = rcbzt*dphidyibt - dphidxt & - (zca*xcb*zcb+xca*xycb2)/rcbt2 dziaxic = rcbzt*dphidxict - dphidyt & - (zba*ycb*zcb+yba*xycb2)/rcbt2 dziayic = rcbzt*dphidyict + dphidxt & + (zba*xcb*zcb+xba*xycb2)/rcbt2 dziazic = rcbzt*dphidzict + zcb*zt/rcbt2 dziaxid = 0.0d0 dziayid = 0.0d0 dziazid = 0.0d0 dxibxic = -xcb*dphidxib/(rcb*rcb) & - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2 & - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2 dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu & - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2 & - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2 & + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2 & + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2 dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2 dxibyid = rcbyu*dphidxibu - dphidzu & - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2 dxibzid = rcbzu*dphidxibu + dphidyu & + (zdc*ycb*zcb+ydc*xycb2)/rcbu2 dyibzib = ycb*dphidzib/(rcb*rcb) & - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2 & - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2 & + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2 & + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2 dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu & + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2 & - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2 dyibyic = -ycb*dphidyib/(rcb*rcb) & - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2 & - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2 & - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2 & + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2 dyibxid = rcbxu*dphidyibu + dphidzu & + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2 dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2 dyibzid = rcbzu*dphidyibu - dphidxu & - (zdc*xcb*zcb+xdc*xycb2)/rcbu2 dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu & - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2 & + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2 dzibzic = -zcb*dphidzib/(rcb*rcb) & - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2 & - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2 & - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2 & + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2 dzibxid = rcbxu*dphidzibu - dphidyu & - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2 dzibyid = rcbyu*dphidzibu + dphidxu & + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2 dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2 dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2 dxicyid = rcbyu*dphidxicu + dphidzu & + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2 dxiczid = rcbzu*dphidxicu - dphidyu & - (zdb*ycb*zcb+ydb*xycb2)/rcbu2 dyicxid = rcbxu*dphidyicu - dphidzu & - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2 dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2 dyiczid = rcbzu*dphidyicu + dphidxu & + (zdb*xcb*zcb+xdb*xycb2)/rcbu2 dzicxid = rcbxu*dphidzicu + dphidyu & + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2 dzicyid = rcbyu*dphidzicu - dphidxu & - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2 dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2 dxidxid = rcbxu*dphidxid dxidyid = rcbxu*dphidyid + zcb*rcb/ru2 dxidzid = rcbxu*dphidzid - ycb*rcb/ru2 dyidyid = rcbyu*dphidyid dyidzid = rcbyu*dphidzid + xcb*rcb/ru2 dzidzid = rcbzu*dphidzid c c get some second derivative chain rule terms by difference c dxiaxib = -dxiaxia - dxiaxic - dxiaxid dxiayib = -dxiayia - dxiayic - dxiayid dxiazib = -dxiazia - dxiazic - dxiazid dyiayib = -dyiayia - dyiayic - dyiayid dyiazib = -dyiazia - dyiazic - dyiazid dziazib = -dziazia - dziazic - dziazid dxibxib = -dxiaxib - dxibxic - dxibxid dxibyib = -dyiaxib - dxibyic - dxibyid dxibzib = -dxiazib - dzibxic - dzibxid dxibzic = -dziaxib - dxibzib - dxibzid dyibyib = -dyiayib - dyibyic - dyibyid dyibzic = -dziayib - dyibzib - dyibzid dzibzib = -dziazib - dzibzic - dzibzid dzibyic = -dyiazib - dyibzib - dzibyid dxicxic = -dxiaxic - dxibxic - dxicxid dxicyic = -dyiaxic - dyibxic - dxicyid dxiczic = -dziaxic - dzibxic - dxiczid dyicyic = -dyiayic - dyibyic - dyicyid dyiczic = -dziayic - dzibyic - dyiczid dziczic = -dziazic - dzibzic - dziczid c c increment diagonal and off-diagonal Hessian elements c if (i .eq. ia) then hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia & + d2edphi2*dphidxia*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia & + d2edphi2*dphidxia*dphidyia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia & + d2edphi2*dphidxia*dphidzia hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia & + d2edphi2*dphidxia*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia & + d2edphi2*dphidyia*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia & + d2edphi2*dphidyia*dphidzia hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia & + d2edphi2*dphidxia*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia & + d2edphi2*dphidyia*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazia & + d2edphi2*dphidzia*dphidzia hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib & + d2edphi2*dphidxia*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib & + d2edphi2*dphidyia*dphidxib hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib & + d2edphi2*dphidzia*dphidxib hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib & + d2edphi2*dphidxia*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib & + d2edphi2*dphidyia*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dziayib & + d2edphi2*dphidzia*dphidyib hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib & + d2edphi2*dphidxia*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib & + d2edphi2*dphidyia*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dziazib & + d2edphi2*dphidzia*dphidzib hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic & + d2edphi2*dphidxia*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic & + d2edphi2*dphidyia*dphidxic hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic & + d2edphi2*dphidzia*dphidxic hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic & + d2edphi2*dphidxia*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic & + d2edphi2*dphidyia*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dziayic & + d2edphi2*dphidzia*dphidyic hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic & + d2edphi2*dphidxia*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic & + d2edphi2*dphidyia*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dziazic & + d2edphi2*dphidzia*dphidzic hessx(1,id) = hessx(1,id) + dedphi*dxiaxid & + d2edphi2*dphidxia*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dyiaxid & + d2edphi2*dphidyia*dphidxid hessz(1,id) = hessz(1,id) + dedphi*dziaxid & + d2edphi2*dphidzia*dphidxid hessx(2,id) = hessx(2,id) + dedphi*dxiayid & + d2edphi2*dphidxia*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyiayid & + d2edphi2*dphidyia*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dziayid & + d2edphi2*dphidzia*dphidyid hessx(3,id) = hessx(3,id) + dedphi*dxiazid & + d2edphi2*dphidxia*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyiazid & + d2edphi2*dphidyia*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dziazid & + d2edphi2*dphidzia*dphidzid else if (i .eq. ib) then hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib & + d2edphi2*dphidxib*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib & + d2edphi2*dphidxib*dphidyib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib & + d2edphi2*dphidxib*dphidzib hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib & + d2edphi2*dphidxib*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib & + d2edphi2*dphidyib*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib & + d2edphi2*dphidyib*dphidzib hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib & + d2edphi2*dphidxib*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib & + d2edphi2*dphidyib*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib & + d2edphi2*dphidzib*dphidzib hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib & + d2edphi2*dphidxib*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib & + d2edphi2*dphidyib*dphidxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib & + d2edphi2*dphidzib*dphidxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib & + d2edphi2*dphidxib*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib & + d2edphi2*dphidyib*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib & + d2edphi2*dphidzib*dphidyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib & + d2edphi2*dphidxib*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayib & + d2edphi2*dphidyib*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazib & + d2edphi2*dphidzib*dphidzia hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic & + d2edphi2*dphidxib*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic & + d2edphi2*dphidyib*dphidxic hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic & + d2edphi2*dphidzib*dphidxic hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic & + d2edphi2*dphidxib*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic & + d2edphi2*dphidyib*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic & + d2edphi2*dphidzib*dphidyic hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic & + d2edphi2*dphidxib*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic & + d2edphi2*dphidyib*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic & + d2edphi2*dphidzib*dphidzic hessx(1,id) = hessx(1,id) + dedphi*dxibxid & + d2edphi2*dphidxib*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dyibxid & + d2edphi2*dphidyib*dphidxid hessz(1,id) = hessz(1,id) + dedphi*dzibxid & + d2edphi2*dphidzib*dphidxid hessx(2,id) = hessx(2,id) + dedphi*dxibyid & + d2edphi2*dphidxib*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyibyid & + d2edphi2*dphidyib*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dzibyid & + d2edphi2*dphidzib*dphidyid hessx(3,id) = hessx(3,id) + dedphi*dxibzid & + d2edphi2*dphidxib*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyibzid & + d2edphi2*dphidyib*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dzibzid & + d2edphi2*dphidzib*dphidzid else if (i .eq. ic) then hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic & + d2edphi2*dphidxic*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic & + d2edphi2*dphidxic*dphidyic hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic & + d2edphi2*dphidxic*dphidzic hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic & + d2edphi2*dphidxic*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic & + d2edphi2*dphidyic*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic & + d2edphi2*dphidyic*dphidzic hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic & + d2edphi2*dphidxic*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic & + d2edphi2*dphidyic*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dziczic & + d2edphi2*dphidzic*dphidzic hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic & + d2edphi2*dphidxic*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic & + d2edphi2*dphidyic*dphidxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic & + d2edphi2*dphidzic*dphidxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic & + d2edphi2*dphidxic*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic & + d2edphi2*dphidyic*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic & + d2edphi2*dphidzic*dphidyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic & + d2edphi2*dphidxic*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayic & + d2edphi2*dphidyic*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazic & + d2edphi2*dphidzic*dphidzia hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic & + d2edphi2*dphidxic*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic & + d2edphi2*dphidyic*dphidxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic & + d2edphi2*dphidzic*dphidxib hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic & + d2edphi2*dphidxic*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic & + d2edphi2*dphidyic*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic & + d2edphi2*dphidzic*dphidyib hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic & + d2edphi2*dphidxic*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic & + d2edphi2*dphidyic*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic & + d2edphi2*dphidzic*dphidzib hessx(1,id) = hessx(1,id) + dedphi*dxicxid & + d2edphi2*dphidxic*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dyicxid & + d2edphi2*dphidyic*dphidxid hessz(1,id) = hessz(1,id) + dedphi*dzicxid & + d2edphi2*dphidzic*dphidxid hessx(2,id) = hessx(2,id) + dedphi*dxicyid & + d2edphi2*dphidxic*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyicyid & + d2edphi2*dphidyic*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dzicyid & + d2edphi2*dphidzic*dphidyid hessx(3,id) = hessx(3,id) + dedphi*dxiczid & + d2edphi2*dphidxic*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyiczid & + d2edphi2*dphidyic*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dziczid & + d2edphi2*dphidzic*dphidzid else if (i .eq. id) then hessx(1,id) = hessx(1,id) + dedphi*dxidxid & + d2edphi2*dphidxid*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dxidyid & + d2edphi2*dphidxid*dphidyid hessz(1,id) = hessz(1,id) + dedphi*dxidzid & + d2edphi2*dphidxid*dphidzid hessx(2,id) = hessx(2,id) + dedphi*dxidyid & + d2edphi2*dphidxid*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyidyid & + d2edphi2*dphidyid*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dyidzid & + d2edphi2*dphidyid*dphidzid hessx(3,id) = hessx(3,id) + dedphi*dxidzid & + d2edphi2*dphidxid*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyidzid & + d2edphi2*dphidyid*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dzidzid & + d2edphi2*dphidzid*dphidzid hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid & + d2edphi2*dphidxid*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid & + d2edphi2*dphidyid*dphidxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid & + d2edphi2*dphidzid*dphidxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid & + d2edphi2*dphidxid*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid & + d2edphi2*dphidyid*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid & + d2edphi2*dphidzid*dphidyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid & + d2edphi2*dphidxid*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayid & + d2edphi2*dphidyid*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazid & + d2edphi2*dphidzid*dphidzia hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid & + d2edphi2*dphidxid*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid & + d2edphi2*dphidyid*dphidxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid & + d2edphi2*dphidzid*dphidxib hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid & + d2edphi2*dphidxid*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid & + d2edphi2*dphidyid*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid & + d2edphi2*dphidzid*dphidyib hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid & + d2edphi2*dphidxid*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid & + d2edphi2*dphidyid*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid & + d2edphi2*dphidzid*dphidzib hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid & + d2edphi2*dphidxid*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid & + d2edphi2*dphidyid*dphidxic hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid & + d2edphi2*dphidzid*dphidxic hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid & + d2edphi2*dphidxid*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid & + d2edphi2*dphidyid*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid & + d2edphi2*dphidzid*dphidyic hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid & + d2edphi2*dphidxid*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid & + d2edphi2*dphidyid*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dziczid & + d2edphi2*dphidzid*dphidzic end if end if end do c c compute the Hessian elements for group distance restraints c do kdist = 1, ngfix ia = igfix(1,kdist) ib = igfix(2,kdist) proceed = (grplist(i).eq.ia .or. grplist(i).eq.ib) if (proceed) then if (grplist(i) .eq. ib) then ib = ia ia = grplist(i) end if xa = 0.0d0 ya = 0.0d0 za = 0.0d0 j = kgrp(igrp(1,ia)) xr = x(j) yr = y(j) zr = z(j) mola = molcule(j) do j = igrp(1,ia), igrp(2,ia) k = kgrp(j) weigh = mass(k) xk = x(k) - xr yk = y(k) - yr zk = z(k) - zr molk = molcule(k) intermol = (molk .ne. mola) if (use_bounds .and. intermol) call image (xk,yk,zk) xa = xa + xk*weigh ya = ya + yk*weigh za = za + zk*weigh end do weigha = max(1.0d0,grpmass(ia)) xa = xr + xa/weigha ya = yr + ya/weigha za = zr + za/weigha xb = 0.0d0 yb = 0.0d0 zb = 0.0d0 j = kgrp(igrp(1,ib)) xr = x(j) yr = y(j) zr = z(j) molb = molcule(j) do j = igrp(1,ib), igrp(2,ib) k = kgrp(j) weigh = mass(k) xk = x(k) - xr yk = y(k) - yr zk = z(k) - zr molk = molcule(k) intermol = (molk .ne. molb) if (use_bounds .and. intermol) call image (xk,yk,zk) xb = xb + xk*weigh yb = yb + yk*weigh zb = zb + zk*weigh end do weighb = max(1.0d0,grpmass(ib)) xb = xr + xb/weighb yb = yr + yb/weighb zb = zr + zb/weighb xr = xa - xb yr = ya - yb zr = za - zb intermol = (mola .ne. molb) if (use_bounds .and. intermol) call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr r = sqrt(r2) force = gfix(1,kdist) gf1 = gfix(2,kdist) gf2 = gfix(3,kdist) target = r if (r .lt. gf1) target = gf1 if (r .gt. gf2) target = gf2 dt = r - target deddt = 2.0d0 * force c c set the chain rule terms for the Hessian elements c r = max(r,eps) r2 = r * r de = deddt * dt/r term = (deddt-de) / r2 termx = term * xr termy = term * yr termz = term * zr d2e(1,1) = termx*xr + de d2e(1,2) = termx*yr d2e(1,3) = termx*zr d2e(2,1) = d2e(1,2) d2e(2,2) = termy*yr + de d2e(2,3) = termy*zr d2e(3,1) = d2e(1,3) d2e(3,2) = d2e(2,3) d2e(3,3) = termz*zr + de c c increment diagonal and non-diagonal Hessian elements c do k = igrp(1,ia), igrp(2,ia) m = kgrp(k) ratio = mass(i)*mass(m) / (weigha*weigha) do j = 1, 3 hessx(j,m) = hessx(j,m) + d2e(1,j)*ratio hessy(j,m) = hessy(j,m) + d2e(2,j)*ratio hessz(j,m) = hessz(j,m) + d2e(3,j)*ratio end do end do do k = igrp(1,ib), igrp(2,ib) m = kgrp(k) ratio = mass(i)*mass(m) / (weigha*weighb) do j = 1, 3 hessx(j,m) = hessx(j,m) - d2e(1,j)*ratio hessy(j,m) = hessy(j,m) - d2e(2,j)*ratio hessz(j,m) = hessz(j,m) - d2e(3,j)*ratio end do end do end if end do c c compute the Hessian elements for chirality restraints c do kchir = 1, nchir ia = ichir(1,kchir) ib = ichir(2,kchir) ic = ichir(3,kchir) id = ichir(4,kchir) 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) if (proceed) then xad = x(ia) - x(id) yad = y(ia) - y(id) zad = z(ia) - z(id) xbd = x(ib) - x(id) ybd = y(ib) - y(id) zbd = z(ib) - z(id) xcd = x(ic) - x(id) ycd = y(ic) - y(id) zcd = z(ic) - z(id) c1 = ybd*zcd - zbd*ycd c2 = ycd*zad - zcd*yad c3 = yad*zbd - zad*ybd vol = xad*c1 + xbd*c2 + xcd*c3 force = chir(1,kchir) cf1 = chir(2,kchir) cf2 = chir(3,kchir) target = vol if (vol .lt. min(cf1,cf2)) target = min(cf1,cf2) if (vol .gt. max(cf1,cf2)) target = max(cf1,cf2) dt = vol - target dt2 = dt * dt deddt = 2.0d0 * force * dt d2eddt2 = 2.0d0 * force c c scale the interaction based on its group membership c if (use_group) then deddt = deddt * fgrp d2eddt2 = d2eddt2 * fgrp end if c c chain rule terms for first derivative components c term = sqrt(d2eddt2) ddtdxia = term * (ybd*zcd - zbd*ycd) ddtdyia = term * (zbd*xcd - xbd*zcd) ddtdzia = term * (xbd*ycd - ybd*xcd) ddtdxib = term * (zad*ycd - yad*zcd) ddtdyib = term * (xad*zcd - zad*xcd) ddtdzib = term * (yad*xcd - xad*ycd) ddtdxic = term * (yad*zbd - zad*ybd) ddtdyic = term * (zad*xbd - xad*zbd) ddtdzic = term * (xad*ybd - yad*xbd) ddtdxid = -ddtdxia - ddtdxib - ddtdxic ddtdyid = -ddtdyia - ddtdyib - ddtdyic ddtdzid = -ddtdzia - ddtdzib - ddtdzic c c chain rule terms for second derivative components (*deddt) c dyiaxib = -deddt * zcd dziaxib = deddt * ycd dxiayib = deddt * zcd dziayib = -deddt * xcd dxiazib = -deddt * ycd dyiazib = deddt * xcd dyiaxic = deddt * zbd dziaxic = -deddt * ybd dxiayic = -deddt * zbd dziayic = deddt * xbd dxiazic = deddt * ybd dyiazic = -deddt * xbd dyibxic = -deddt * zad dzibxic = deddt * yad dxibyic = deddt * zad dzibyic = -deddt * xad dxibzic = -deddt * yad dyibzic = deddt * xad dyiaxid = -dyiaxib - dyiaxic dziaxid = -dziaxib - dziaxic dxiayid = -dxiayib - dxiayic dziayid = -dziayib - dziayic dxiazid = -dxiazib - dxiazic dyiazid = -dyiazib - dyiazic dyibxid = -dxiayib - dyibxic dzibxid = -dxiazib - dzibxic dxibyid = -dyiaxib - dxibyic dzibyid = -dyiazib - dzibyic dxibzid = -dziaxib - dxibzic dyibzid = -dziayib - dyibzic dyicxid = -dxiayic - dxibyic dzicxid = -dxiazic - dxibzic dxicyid = -dyiaxic - dyibxic dzicyid = -dyiazic - dyibzic dxiczid = -dziaxic - dzibxic dyiczid = -dziayic - dzibyic c c increment diagonal and off-diagonal Hessian elements c if (i .eq. ia) then hessx(1,ia) = hessx(1,ia) + ddtdxia*ddtdxia hessy(1,ia) = hessy(1,ia) + ddtdxia*ddtdyia hessz(1,ia) = hessz(1,ia) + ddtdxia*ddtdzia hessx(2,ia) = hessx(2,ia) + ddtdxia*ddtdyia hessy(2,ia) = hessy(2,ia) + ddtdyia*ddtdyia hessz(2,ia) = hessz(2,ia) + ddtdyia*ddtdzia hessx(3,ia) = hessx(3,ia) + ddtdxia*ddtdzia hessy(3,ia) = hessy(3,ia) + ddtdyia*ddtdzia hessz(3,ia) = hessz(3,ia) + ddtdzia*ddtdzia hessx(1,ib) = hessx(1,ib) + ddtdxia*ddtdxib hessy(1,ib) = hessy(1,ib) + ddtdyia*ddtdxib + dyiaxib hessz(1,ib) = hessz(1,ib) + ddtdzia*ddtdxib + dziaxib hessx(2,ib) = hessx(2,ib) + ddtdxia*ddtdyib + dxiayib hessy(2,ib) = hessy(2,ib) + ddtdyia*ddtdyib hessz(2,ib) = hessz(2,ib) + ddtdzia*ddtdyib + dziayib hessx(3,ib) = hessx(3,ib) + ddtdxia*ddtdzib + dxiazib hessy(3,ib) = hessy(3,ib) + ddtdyia*ddtdzib + dyiazib hessz(3,ib) = hessz(3,ib) + ddtdzia*ddtdzib hessx(1,ic) = hessx(1,ic) + ddtdxia*ddtdxic hessy(1,ic) = hessy(1,ic) + ddtdyia*ddtdxic + dyiaxic hessz(1,ic) = hessz(1,ic) + ddtdzia*ddtdxic + dziaxic hessx(2,ic) = hessx(2,ic) + ddtdxia*ddtdyic + dxiayic hessy(2,ic) = hessy(2,ic) + ddtdyia*ddtdyic hessz(2,ic) = hessz(2,ic) + ddtdzia*ddtdyic + dziayic hessx(3,ic) = hessx(3,ic) + ddtdxia*ddtdzic + dxiazic hessy(3,ic) = hessy(3,ic) + ddtdyia*ddtdzic + dyiazic hessz(3,ic) = hessz(3,ic) + ddtdzia*ddtdzic hessx(1,id) = hessx(1,id) + ddtdxia*ddtdxid hessy(1,id) = hessy(1,id) + ddtdyia*ddtdxid + dyiaxid hessz(1,id) = hessz(1,id) + ddtdzia*ddtdxid + dziaxid hessx(2,id) = hessx(2,id) + ddtdxia*ddtdyid + dxiayid hessy(2,id) = hessy(2,id) + ddtdyia*ddtdyid hessz(2,id) = hessz(2,id) + ddtdzia*ddtdyid + dziayid hessx(3,id) = hessx(3,id) + ddtdxia*ddtdzid + dxiazid hessy(3,id) = hessy(3,id) + ddtdyia*ddtdzid + dyiazid hessz(3,id) = hessz(3,id) + ddtdzia*ddtdzid else if (i .eq. ib) then hessx(1,ib) = hessx(1,ib) + ddtdxib*ddtdxib hessy(1,ib) = hessy(1,ib) + ddtdxib*ddtdyib hessz(1,ib) = hessz(1,ib) + ddtdxib*ddtdzib hessx(2,ib) = hessx(2,ib) + ddtdxib*ddtdyib hessy(2,ib) = hessy(2,ib) + ddtdyib*ddtdyib hessz(2,ib) = hessz(2,ib) + ddtdyib*ddtdzib hessx(3,ib) = hessx(3,ib) + ddtdxib*ddtdzib hessy(3,ib) = hessy(3,ib) + ddtdyib*ddtdzib hessz(3,ib) = hessz(3,ib) + ddtdzib*ddtdzib hessx(1,ia) = hessx(1,ia) + ddtdxib*ddtdxia hessy(1,ia) = hessy(1,ia) + ddtdyib*ddtdxia + dxiayib hessz(1,ia) = hessz(1,ia) + ddtdzib*ddtdxia + dxiazib hessx(2,ia) = hessx(2,ia) + ddtdxib*ddtdyia + dyiaxib hessy(2,ia) = hessy(2,ia) + ddtdyib*ddtdyia hessz(2,ia) = hessz(2,ia) + ddtdzib*ddtdyia + dyiazib hessx(3,ia) = hessx(3,ia) + ddtdxib*ddtdzia + dziaxib hessy(3,ia) = hessy(3,ia) + ddtdyib*ddtdzia + dziayib hessz(3,ia) = hessz(3,ia) + ddtdzib*ddtdzia hessx(1,ic) = hessx(1,ic) + ddtdxib*ddtdxic hessy(1,ic) = hessy(1,ic) + ddtdyib*ddtdxic + dyibxic hessz(1,ic) = hessz(1,ic) + ddtdzib*ddtdxic + dzibxic hessx(2,ic) = hessx(2,ic) + ddtdxib*ddtdyic + dxibyic hessy(2,ic) = hessy(2,ic) + ddtdyib*ddtdyic hessz(2,ic) = hessz(2,ic) + ddtdzib*ddtdyic + dzibyic hessx(3,ic) = hessx(3,ic) + ddtdxib*ddtdzic + dxibzic hessy(3,ic) = hessy(3,ic) + ddtdyib*ddtdzic + dyibzic hessz(3,ic) = hessz(3,ic) + ddtdzib*ddtdzic hessx(1,id) = hessx(1,id) + ddtdxib*ddtdxid hessy(1,id) = hessy(1,id) + ddtdyib*ddtdxid + dyibxid hessz(1,id) = hessz(1,id) + ddtdzib*ddtdxid + dzibxid hessx(2,id) = hessx(2,id) + ddtdxib*ddtdyid + dxibyid hessy(2,id) = hessy(2,id) + ddtdyib*ddtdyid hessz(2,id) = hessz(2,id) + ddtdzib*ddtdyid + dzibyid hessx(3,id) = hessx(3,id) + ddtdxib*ddtdzid + dxibzid hessy(3,id) = hessy(3,id) + ddtdyib*ddtdzid + dyibzid hessz(3,id) = hessz(3,id) + ddtdzib*ddtdzid else if (i .eq. ic) then hessx(1,ic) = hessx(1,ic) + ddtdxic*ddtdxic hessy(1,ic) = hessy(1,ic) + ddtdxic*ddtdyic hessz(1,ic) = hessz(1,ic) + ddtdxic*ddtdzic hessx(2,ic) = hessx(2,ic) + ddtdxic*ddtdyic hessy(2,ic) = hessy(2,ic) + ddtdyic*ddtdyic hessz(2,ic) = hessz(2,ic) + ddtdyic*ddtdzic hessx(3,ic) = hessx(3,ic) + ddtdxic*ddtdzic hessy(3,ic) = hessy(3,ic) + ddtdyic*ddtdzic hessz(3,ic) = hessz(3,ic) + ddtdzic*ddtdzic hessx(1,ia) = hessx(1,ia) + ddtdxic*ddtdxia hessy(1,ia) = hessy(1,ia) + ddtdyic*ddtdxia + dxiayic hessz(1,ia) = hessz(1,ia) + ddtdzic*ddtdxia + dxiazic hessx(2,ia) = hessx(2,ia) + ddtdxic*ddtdyia + dyiaxic hessy(2,ia) = hessy(2,ia) + ddtdyic*ddtdyia hessz(2,ia) = hessz(2,ia) + ddtdzic*ddtdyia + dyiazic hessx(3,ia) = hessx(3,ia) + ddtdxic*ddtdzia + dziaxic hessy(3,ia) = hessy(3,ia) + ddtdyic*ddtdzia + dziayic hessz(3,ia) = hessz(3,ia) + ddtdzic*ddtdzia hessx(1,ib) = hessx(1,ib) + ddtdxic*ddtdxib hessy(1,ib) = hessy(1,ib) + ddtdyic*ddtdxib + dxibyic hessz(1,ib) = hessz(1,ib) + ddtdzic*ddtdxib + dxibzic hessx(2,ib) = hessx(2,ib) + ddtdxic*ddtdyib + dyibxic hessy(2,ib) = hessy(2,ib) + ddtdyic*ddtdyib hessz(2,ib) = hessz(2,ib) + ddtdzic*ddtdyib + dyibzic hessx(3,ib) = hessx(3,ib) + ddtdxic*ddtdzib + dzibxic hessy(3,ib) = hessy(3,ib) + ddtdyic*ddtdzib + dzibyic hessz(3,ib) = hessz(3,ib) + ddtdzic*ddtdzib hessx(1,id) = hessx(1,id) + ddtdxic*ddtdxid hessy(1,id) = hessy(1,id) + ddtdyic*ddtdxid + dyicxid hessz(1,id) = hessz(1,id) + ddtdzic*ddtdxid + dzicxid hessx(2,id) = hessx(2,id) + ddtdxic*ddtdyid + dxicyid hessy(2,id) = hessy(2,id) + ddtdyic*ddtdyid hessz(2,id) = hessz(2,id) + ddtdzic*ddtdyid + dzicyid hessx(3,id) = hessx(3,id) + ddtdxic*ddtdzid + dxiczid hessy(3,id) = hessy(3,id) + ddtdyic*ddtdzid + dyiczid hessz(3,id) = hessz(3,id) + ddtdzic*ddtdzid else if (i .eq. id) then hessx(1,id) = hessx(1,id) + ddtdxid*ddtdxid hessy(1,id) = hessy(1,id) + ddtdxid*ddtdyid hessz(1,id) = hessz(1,id) + ddtdxid*ddtdzid hessx(2,id) = hessx(2,id) + ddtdxid*ddtdyid hessy(2,id) = hessy(2,id) + ddtdyid*ddtdyid hessz(2,id) = hessz(2,id) + ddtdyid*ddtdzid hessx(3,id) = hessx(3,id) + ddtdxid*ddtdzid hessy(3,id) = hessy(3,id) + ddtdyid*ddtdzid hessz(3,id) = hessz(3,id) + ddtdzid*ddtdzid hessx(1,ia) = hessx(1,ia) + ddtdxid*ddtdxia hessy(1,ia) = hessy(1,ia) + ddtdyid*ddtdxia + dxiayid hessz(1,ia) = hessz(1,ia) + ddtdzid*ddtdxia + dxiazid hessx(2,ia) = hessx(2,ia) + ddtdxid*ddtdyia + dyiaxid hessy(2,ia) = hessy(2,ia) + ddtdyid*ddtdyia hessz(2,ia) = hessz(2,ia) + ddtdzid*ddtdyia + dyiazid hessx(3,ia) = hessx(3,ia) + ddtdxid*ddtdzia + dziaxid hessy(3,ia) = hessy(3,ia) + ddtdyid*ddtdzia + dziayid hessz(3,ia) = hessz(3,ia) + ddtdzid*ddtdzia hessx(1,ib) = hessx(1,ib) + ddtdxid*ddtdxib hessy(1,ib) = hessy(1,ib) + ddtdyid*ddtdxib + dxibyid hessz(1,ib) = hessz(1,ib) + ddtdzid*ddtdxib + dxibzid hessx(2,ib) = hessx(2,ib) + ddtdxid*ddtdyib + dyibxid hessy(2,ib) = hessy(2,ib) + ddtdyid*ddtdyib hessz(2,ib) = hessz(2,ib) + ddtdzid*ddtdyib + dyibzid hessx(3,ib) = hessx(3,ib) + ddtdxid*ddtdzib + dzibxid hessy(3,ib) = hessy(3,ib) + ddtdyid*ddtdzib + dzibyid hessz(3,ib) = hessz(3,ib) + ddtdzid*ddtdzib hessx(1,ic) = hessx(1,ic) + ddtdxid*ddtdxic hessy(1,ic) = hessy(1,ic) + ddtdyid*ddtdxic + dxicyid hessz(1,ic) = hessz(1,ic) + ddtdzid*ddtdxic + dxiczid hessx(2,ic) = hessx(2,ic) + ddtdxid*ddtdyic + dyicxid hessy(2,ic) = hessy(2,ic) + ddtdyid*ddtdyic hessz(2,ic) = hessz(2,ic) + ddtdzid*ddtdyic + dyiczid hessx(3,ic) = hessx(3,ic) + ddtdxid*ddtdzic + dzicxid hessy(3,ic) = hessy(3,ic) + ddtdyid*ddtdzic + dzicyid hessz(3,ic) = hessz(3,ic) + ddtdzid*ddtdzic end if end if end do c c compute Hessian elements for a Gaussian basin restraint c if (use_basin) then rflat2 = rflat * rflat xi = x(i) yi = y(i) zi = z(i) do k = 1, n proceed = (k .ne. i) if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) then xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) r2 = xr*xr + yr*yr + zr*zr r2 = max(0.0d0,r2-rflat2) term = -width * r2 expterm = 0.0d0 if (term .gt. -50.0d0) & expterm = depth * width * exp(term) dedr = -2.0d0 * expterm d2edr2 = (-4.0d0*term-2.0d0) * expterm c c scale the interaction based on its group membership c if (use_group) then dedr = dedr * fgrp d2edr2 = d2edr2 * fgrp end if c c set the chain rule terms for the Hessian elements c if (r2 .eq. 0.0d0) then term = 0.0d0 else term = (d2edr2-dedr) / r2 end if termx = term * xr termy = term * yr termz = term * zr d2e(1,1) = termx*xr + dedr d2e(1,2) = termx*yr d2e(1,3) = termx*zr d2e(2,1) = d2e(1,2) d2e(2,2) = termy*yr + dedr d2e(2,3) = termy*zr d2e(3,1) = d2e(1,3) d2e(3,2) = d2e(2,3) d2e(3,3) = termz*zr + dedr c c increment diagonal and non-diagonal Hessian elements c do j = 1, 3 hessx(j,i) = hessx(j,i) + d2e(1,j) hessy(j,i) = hessy(j,i) + d2e(2,j) hessz(j,i) = hessz(j,i) + d2e(3,j) hessx(j,k) = hessx(j,k) - d2e(1,j) hessy(j,k) = hessy(j,k) - d2e(2,j) hessz(j,k) = hessz(j,k) - d2e(3,j) end do end if end do end if c c compute Hessian elements for a spherical droplet restraint c if (use_wall) then buffer = 2.5d0 a = 2048.0d0 b = 64.0d0 proceed = .true. if (use_group) call groups (proceed,fgrp,i,0,0,0,0,0) if (proceed) then xi = x(i) yi = y(i) zi = z(i) ri2 = xi**2 + yi**2 + zi**2 ri = sqrt(ri2) r = rwall + buffer - ri r2 = r * r r6 = r2 * r2 * r2 r12 = r6 * r6 if (ri .eq. 0.0d0) then ri = 1.0d0 ri2 = 1.0d0 end if dedr = (12.0d0*a/r12 - 6.0d0*b/r6) / (r*ri) d2edr2 = (156.0d0*a/r12 - 42.0d0*b/r6) / (r2*ri2) c c scale the interaction based on its group membership c if (use_group) then dedr = dedr * fgrp d2edr2 = d2edr2 * fgrp end if c c set the chain rule terms for the Hessian elements c d2edr2 = d2edr2 - dedr/ri2 termx = d2edr2 * xi termy = d2edr2 * yi termz = d2edr2 * zi d2e(1,1) = termx*xi + dedr d2e(1,2) = termx*yi d2e(1,3) = termx*zi d2e(2,1) = d2e(1,2) d2e(2,2) = termy*yi + dedr d2e(2,3) = termy*zi d2e(3,1) = d2e(1,3) d2e(3,2) = d2e(2,3) d2e(3,3) = termz*zi + dedr c c increment diagonal and non-diagonal Hessian elements c do j = 1, 3 hessx(j,i) = hessx(j,i) + d2e(1,j) hessy(j,i) = hessy(j,i) + d2e(2,j) hessz(j,i) = hessz(j,i) + d2e(3,j) end do end if end if c c reinstate the replica mechanism if it is being used c if (use_replica) then xcell = xorig ycell = yorig zcell = zorig xcell2 = xorig2 ycell2 = yorig2 zcell2 = zorig2 end if return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine egeom3 -- restraint energy terms & analysis ## c ## ## c ################################################################ c c c "egeom3" calculates the energy due to restraints on positions, c distances, angles and torsions as well as Gaussian basin and c droplet restraints; also partitions energy among the atoms c c subroutine egeom3 use action use analyz use atomid use atoms use bound use boxes use cell use energi use group use inform use inter use iounit use math use molcul use restrn use usage implicit none integer i,j,k integer ia,ib,ic,id real*8 e,eps,fgrp real*8 dt,dt2 real*8 xr,yr,zr real*8 r,r2,r6,r12 real*8 angle,target real*8 dot,force real*8 cosine,sine real*8 rab2,rcb2 real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2 real*8 rtru,rcb real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xab,yab,zab real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 df1,df2 real*8 af1,af2 real*8 tf1,tf2,t1,t2 real*8 xa,ya,za real*8 xb,yb,zb real*8 xk,yk,zk real*8 gf1,gf2 real*8 weigh,size real*8 weigha,weighb real*8 mola,molb,molk real*8 cf1,cf2,vol real*8 c1,c2,c3 real*8 xi,yi,zi,ri real*8 rflat2 real*8 a,b,buffer,term real*8 xorig,xorig2 real*8 yorig,yorig2 real*8 zorig,zorig2 logical proceed,intermol logical header,huge c c c zero out the restraint energy and partitioning terms c neg = 0 eg = 0.0d0 do i = 1, n aeg(i) = 0.0d0 end do c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c disable replica mechanism when computing restraint terms c if (use_replica) then xorig = xcell yorig = ycell zorig = zcell xorig2 = xcell2 yorig2 = ycell2 zorig2 = zcell2 xcell = xbox ycell = ybox zcell = zbox xcell2 = xbox2 ycell2 = ybox2 zcell2 = zbox2 end if c c compute the energy for position restraint terms c header = .true. do i = 1, npfix ia = ipfix(i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,0,0,0,0,0) if (proceed) proceed = (use(ia)) if (proceed) then xr = 0.0d0 yr = 0.0d0 zr = 0.0d0 if (kpfix(1,i) .ne. 0) xr = x(ia) - xpfix(i) if (kpfix(2,i) .ne. 0) yr = y(ia) - ypfix(i) if (kpfix(3,i) .ne. 0) zr = z(ia) - zpfix(i) if (use_bounds) call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) force = pfix(1,i) dt = max(0.0d0,r-pfix(2,i)) dt2 = dt * dt e = force * dt2 if (use_group) e = e * fgrp neg = neg + 1 eg = eg + e aeg(ia) = aeg(ia) + e huge = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,10) 10 format (/,' Individual Atomic Position Restraint', & ' Terms :', & //,' Type',9x,'Atom Name',13x,'Target', & ' Position',7x,'Distance',6x,'Energy',/) end if dt = sqrt(dt2) if (kpfix(2,i).eq.0 .and. kpfix(3,i).eq.0) then write (iout,20) ia,name(ia),xpfix(i),dt,e 20 format (' Position',2x,i7,'-',a3,4x,f10.4, & 5x,'----',6x,'----',1x,f10.4,f12.4) else if (kpfix(1,i).eq.0 .and. kpfix(3,i).eq.0) then write (iout,30) ia,name(ia),ypfix(i),dt,e 30 format (' Position',2x,i7,'-',a3,9x,'----',1x, & f10.4,5x,'----',1x,f10.4,f12.4) else if (kpfix(1,i).eq.0 .and. kpfix(2,i).eq.0) then write (iout,40) ia,name(ia),zpfix(i),dt,e 40 format (' Position',2x,i7,'-',a3,9x,'----', & 6x,'----',1x,2f10.4,f12.4) else write (iout,50) ia,name(ia),xpfix(i),ypfix(i), & zpfix(i),dt,e 50 format (' Position',2x,i7,'-',a3,4x,4f10.4,f12.4) end if end if end if end do c c compute the energy for distance restraint terms c header = .true. do i = 1, ndfix ia = idfix(1,i) ib = idfix(2,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,0,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib)) if (proceed) then xr = x(ia) - x(ib) yr = y(ia) - y(ib) zr = z(ia) - z(ib) intermol = (molcule(ia) .ne. molcule(ib)) if (use_bounds .and. intermol) call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) force = dfix(1,i) df1 = dfix(2,i) df2 = dfix(3,i) target = r if (r .lt. df1) target = df1 if (r .gt. df2) target = df2 dt = r - target dt2 = dt * dt e = force * dt2 if (use_group) e = e * fgrp neg = neg + 1 eg = eg + e aeg(ia) = aeg(ia) + 0.5d0*e aeg(ib) = aeg(ib) + 0.5d0*e if (intermol) then einter = einter + e end if huge = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,60) 60 format (/,' Individual Interatomic Distance', & ' Restraint Terms :', & //,' Type',14x,'Atom Names',16x,'Ideal Range', & 4x,'Actual',6x,'Energy',/) end if write (iout,70) ia,name(ia),ib,name(ib),df1,df2,r,e 70 format (' Distance',2x,2(i7,'-',a3), & 7x,2f8.2,f10.4,f12.4) end if end if end do c c compute the energy for angle restraint terms c header = .true. do i = 1, nafix ia = iafix(1,i) ib = iafix(2,i) ic = iafix(3,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,0,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. use(ic)) if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xab = xia - xib yab = yia - yib zab = zia - zib xcb = xic - xib ycb = yic - yib zcb = zic - zib rab2 = max(xab*xab+yab*yab+zab*zab,eps) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,eps) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) force = afix(1,i) af1 = afix(2,i) af2 = afix(3,i) target = angle if (angle .lt. af1) target = af1 if (angle .gt. af2) target = af2 dt = angle - target dt = dt / radian dt2 = dt * dt e = force * dt2 if (use_group) e = e * fgrp neg = neg + 1 eg = eg + e aeg(ib) = aeg(ib) + e if (molcule(ia).ne.molcule(ib) .or. & molcule(ia).ne.molcule(ic)) then einter = einter + e end if huge = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,80) 80 format (/,' Individual Interatomic Angle', & ' Restraint Terms :', & //,' Type',14x,'Atom Numbers',14x,'Ideal', & ' Range',4x,'Actual',6x,'Energy',/) end if write (iout,90) ia,ib,ic,af1,af2,angle,e 90 format (' Angle',8x,3i6,8x,2f8.2,f10.4,f12.4) end if end if end do c c compute the energy for torsional restraint terms c header = .true. do i = 1, ntfix ia = itfix(1,i) ib = itfix(2,i) ic = itfix(3,i) id = itfix(4,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xdc = xid - xic ydc = yid - yic zdc = zid - zic xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (sine .lt. 0.0d0) angle = -angle force = tfix(1,i) tf1 = tfix(2,i) tf2 = tfix(3,i) if (angle.gt.tf1 .and. angle.lt.tf2) then target = angle else if (angle.gt.tf1 .and. tf1.gt.tf2) then target = angle else if (angle.lt.tf2 .and. tf1.gt.tf2) then target = angle else t1 = angle - tf1 t2 = angle - tf2 if (t1 .gt. 180.0d0) then t1 = t1 - 360.0d0 else if (t1 .lt. -180.0d0) then t1 = t1 + 360.0d0 end if if (t2 .gt. 180.0d0) then t2 = t2 - 360.0d0 else if (t2 .lt. -180.0d0) then t2 = t2 + 360.0d0 end if if (abs(t1) .lt. abs(t2)) then target = tf1 else target = tf2 end if end if dt = angle - target if (dt .gt. 180.0d0) then dt = dt - 360.0d0 else if (dt .lt. -180.0d0) then dt = dt + 360.0d0 end if dt = dt / radian dt2 = dt * dt e = force * dt2 if (use_group) e = e * fgrp neg = neg + 1 eg = eg + e aeg(ib) = aeg(ib) + 0.5d0*e aeg(ic) = aeg(ic) + 0.5d0*e if (molcule(ia).ne.molcule(ib) .or. & molcule(ia).ne.molcule(ic) .or. & molcule(ia).ne.molcule(id)) then einter = einter + e end if huge = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,100) 100 format (/,' Individual Torsional Angle Restraint', & ' Terms :', & //,' Type',14x,'Atom Numbers',14x,'Ideal', & ' Range',4x,'Actual',6x,'Energy',/) end if write (iout,110) ia,ib,ic,id,tf1,tf2,angle,e 110 format (' Torsion',4x,4i6,4x,2f8.2,f10.4,f12.4) end if end if end do c c compute the energy for group distance restraint terms c header = .true. do i = 1, ngfix ia = igfix(1,i) ib = igfix(2,i) xa = 0.0d0 ya = 0.0d0 za = 0.0d0 j = kgrp(igrp(1,ia)) xr = x(j) yr = y(j) zr = z(j) mola = molcule(j) do j = igrp(1,ia), igrp(2,ia) k = kgrp(j) weigh = mass(k) xk = x(k) - xr yk = y(k) - yr zk = z(k) - zr molk = molcule(k) intermol = (molk .ne. mola) if (use_bounds .and. intermol) call image (xk,yk,zk) xa = xa + xk*weigh ya = ya + yk*weigh za = za + zk*weigh end do weigha = max(1.0d0,grpmass(ia)) xa = xr + xa/weigha ya = yr + ya/weigha za = zr + za/weigha xb = 0.0d0 yb = 0.0d0 zb = 0.0d0 j = kgrp(igrp(1,ib)) xr = x(j) yr = y(j) zr = z(j) molb = molcule(j) do j = igrp(1,ib), igrp(2,ib) k = kgrp(j) weigh = mass(k) xk = x(k) - xr yk = y(k) - yr zk = z(k) - zr molk = molcule(k) intermol = (molk .ne. molb) if (use_bounds .and. intermol) call image (xk,yk,zk) xb = xb + xk*weigh yb = yb + yk*weigh zb = zb + zk*weigh end do weighb = max(1.0d0,grpmass(ib)) xb = xr + xb/weighb yb = yr + yb/weighb zb = zr + zb/weighb xr = xa - xb yr = ya - yb zr = za - zb intermol = (mola .ne. molb) if (use_bounds .and. intermol) call image (xr,yr,zr) r = sqrt(xr*xr + yr*yr + zr*zr) force = gfix(1,i) gf1 = gfix(2,i) gf2 = gfix(3,i) target = r if (r .lt. gf1) target = gf1 if (r .gt. gf2) target = gf2 dt = r - target dt2 = dt * dt e = force * dt2 neg = neg + 1 eg = eg + e size = dble(igrp(2,ia) - igrp(1,ia) + 1) do j = igrp(1,ia), igrp(2,ia) k = kgrp(j) aeg(k) = aeg(k) + 0.5d0*e/size end do size = dble(igrp(2,ib) - igrp(1,ib) + 1) do j = igrp(1,ib), igrp(2,ib) k = kgrp(j) aeg(k) = aeg(k) + 0.5d0*e/size end do if (intermol) then einter = einter + e end if huge = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,120) 120 format (/,' Individual Intergroup Distance', & ' Restraint Terms :', & //,' Type',13x,'Group Numbers',14x,'Ideal Range', & 4x,'Actual',6x,'Energy',/) end if write (iout,130) ia,ib,gf1,gf2,r,e 130 format (' Distance',7x,2i7,10x,2f8.2,f10.4,f12.4) end if end do c c compute the energy for chirality restraint terms c header = .true. do i = 1, nchir ia = ichir(1,i) ib = ichir(2,i) ic = ichir(3,i) id = ichir(4,i) proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) if (proceed) then xad = x(ia) - x(id) yad = y(ia) - y(id) zad = z(ia) - z(id) xbd = x(ib) - x(id) ybd = y(ib) - y(id) zbd = z(ib) - z(id) xcd = x(ic) - x(id) ycd = y(ic) - y(id) zcd = z(ic) - z(id) c1 = ybd*zcd - zbd*ycd c2 = ycd*zad - zcd*yad c3 = yad*zbd - zad*ybd vol = xad*c1 + xbd*c2 + xcd*c3 force = chir(1,i) cf1 = chir(2,i) cf2 = chir(3,i) target = vol if (vol .lt. min(cf1,cf2)) target = min(cf1,cf2) if (vol .gt. max(cf1,cf2)) target = max(cf1,cf2) dt = vol - target dt2 = dt * dt e = force * dt2 if (use_group) e = e * fgrp neg = neg + 1 eg = eg + e aeg(ia) = aeg(ia) + 0.25d0*e aeg(ib) = aeg(ib) + 0.25d0*e aeg(ic) = aeg(ic) + 0.25d0*e aeg(id) = aeg(id) + 0.25d0*e huge = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,140) 140 format (/,' Individual Chirality Restraint Terms :' &, //,' Type',14x,'Atom Numbers',14x,'Ideal', & ' Range',4x,'Actual',6x,'Energy',/) end if write (iout,150) ia,ib,ic,id,cf1,cf2,vol,e 150 format (' Chiral',5x,4i6,4x,2f8.2,f10.4,f12.4) end if end if end do c c compute the energy for a Gaussian basin restraint c if (use_basin) then header = .true. rflat2 = rflat * rflat do i = 1, n-1 xi = x(i) yi = y(i) zi = z(i) do k = i+1, n proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (use(i) .or. use(k)) if (proceed) then xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) r2 = xr*xr + yr*yr + zr*zr r2 = max(0.0d0,r2-rflat2) term = -width * r2 e = 0.0d0 if (term .gt. -50.0d0) e = depth * exp(term) e = e - depth if (use_group) e = e * fgrp neg = neg + 1 eg = eg + e aeg(i) = aeg(i) + 0.5d0*e aeg(k) = aeg(k) + 0.5d0*e huge = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,160) 160 format (/,' Individual Gaussian Basin', & ' Restraint Terms :', & //,' Type',14x,'Atom Names',22x,'Ideal', & 4x,'Actual',6x,'Energy',/) end if r = sqrt(r2) write (iout,170) i,name(i),k,name(k),0.0d0,r,e 170 format (' Distance',2x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end do end do end if c c compute the energy for a spherical droplet restraint c if (use_wall) then header = .true. buffer = 2.5d0 a = 2048.0d0 b = 64.0d0 do i = 1, n proceed = .true. if (use_group) call groups (proceed,fgrp,i,0,0,0,0,0) if (proceed) proceed = (use(i)) if (proceed) then xi = x(i) yi = y(i) zi = z(i) ri = sqrt(xi**2 + yi**2 + zi**2) r = rwall + buffer - ri r2 = r * r r6 = r2 * r2 * r2 r12 = r6 * r6 e = a/r12 - b/r6 if (use_group) e = e * fgrp neg = neg + 1 eg = eg + e aeg(i) = aeg(i) + e huge = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,180) 180 format (/,' Individual Spherical Boundary', & ' Restraint Terms :', & //,' Type',14x,'Atom Name',30x,'Distance', & 6x,'Energy',/) end if write (iout,190) i,name(i),ri,e 190 format (' Wall',11x,i7,'-',a3,29x,f10.4,f12.4) end if end if end do end if c c reinstate the replica mechanism if it is being used c if (use_replica) then xcell = xorig ycell = yorig zcell = zorig xcell2 = xorig2 ycell2 = yorig2 zcell2 = zorig2 end if return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine ehal -- buffered 14-7 van der Waals energy ## c ## ## c ############################################################### c c c "ehal" calculates the buffered 14-7 van der Waals energy c c subroutine ehal use energi use limits use vdwpot implicit none real*8 elrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_lights) then call ehal0b else if (use_vlist) then call ehal0c else call ehal0a end if c c apply the long range van der Waals correction if used c if (use_vcorr) then mode = 'VDW' call evcorr (mode,elrc) ev = ev + elrc end if return end c c c ################################################################ c ## ## c ## subroutine ehal0a -- buffered 14-7 vdw via double loop ## c ## ## c ################################################################ c c c "ehal0a" calculates the buffered 14-7 van der Waals energy c using a pairwise double loop c c subroutine ehal0a use atomid use atoms use bound use cell use couple use energi use group use mutant use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,rv,rv7 real*8 eps,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rho,tau,taper real*8 scal,t1,t2 real*8 rik,rik2,rik3 real*8 rik4,rik5,rik7 real*8, allocatable :: vscale(:) logical proceed,usei logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7) t2 = (1.0d0+ghal) / (scal+rho**7+ghal) e = eps * t1 * (t2-2.0d0) else rv7 = rv**7 rik7 = rik**7 rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) e = eps * rv7 * tau**7 & * ((ghal+1.0d0)*rv7/rho-2.0d0) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,j) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7) t2 = (1.0d0+ghal) / (scal+rho**7+ghal) e = eps * t1 * (t2-2.0d0) else rv7 = rv**7 rik7 = rik**7 rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) e = eps * rv7 * tau**7 & * ((ghal+1.0d0)*rv7/rho-2.0d0) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy component; c interaction of an atom with its own image counts half c if (i .eq. k) e = 0.5d0 * e ev = ev + e end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################## c ## ## c ## subroutine ehal0b -- buffered 14-7 vdw energy via lights ## c ## ## c ################################################################## c c c "ehal0b" calculates the buffered 14-7 van der Waals energy c using the method of lights c c subroutine ehal0b use atomid use atoms use bound use boxes use cell use couple use energi use group use light use mutant use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer, allocatable :: iv14(:) real*8 e,rv,rv7 real*8 eps,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rho,tau,taper real*8 scal,t1,t2 real*8 rik,rik2,rik3 real*8 rik4,rik5,rik7 real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) mutk = mut(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7) t2 = (1.0d0+ghal) / (scal+rho**7+ghal) e = eps * t1 * (t2-2.0d0) else rv7 = rv**7 rik7 = rik**7 rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) e = eps * rv7 * tau**7 & * ((ghal+1.0d0)*rv7/rho-2.0d0) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ################################################################ c ## ## c ## subroutine ehal0c -- buffered 14-7 vdw energy via list ## c ## ## c ################################################################ c c c "ehal0c" calculates the buffered 14-7 van der Waals energy c using a pairwise neighbor list c c subroutine ehal0c use atomid use atoms use bound use couple use energi use group use mutant use neigh use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,eps,rdn real*8 fgrp,rv,rv7 real*8 xi,yi,zi real*8 xr,yr,zr real*8 rho,tau,taper real*8 scal,t1,t2 real*8 rik,rik2,rik3 real*8 rik4,rik5,rik7 real*8, allocatable :: vscale(:) logical proceed,usei logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired, !$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13, !$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group, !$OMP& off2,radmin,epsilon,radmin4,epsilon4,ghal,dhal,vcouple, !$OMP& vlambda,mut,scexp,scalpha,cut2,c0,c1,c2,c3,c4,c5) !$OMP& firstprivate(vscale,iv14) shared(ev) !$OMP DO reduction(+:ev) schedule(guided) c c find the van der Waals energy via neighbor list search c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7) t2 = (1.0d0+ghal) / (scal+rho**7+ghal) e = eps * t1 * (t2-2.0d0) else rv7 = rv**7 rik7 = rik**7 rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) e = eps * rv7 * tau**7 & * ((ghal+1.0d0)*rv7/rho-2.0d0) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine ehal1 -- buffered 14-7 energy & derivatives ## c ## ## c ################################################################ c c c "ehal1" calculates the buffered 14-7 van der Waals energy and c its first derivatives with respect to Cartesian coordinates c c subroutine ehal1 use energi use limits use vdwpot use virial implicit none real*8 elrc,vlrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_lights) then call ehal1b else if (use_vlist) then call ehal1c else call ehal1a end if c c apply the long range van der Waals correction if used c if (use_vcorr) then mode = 'VDW' call evcorr1 (mode,elrc,vlrc) ev = ev + elrc vir(1,1) = vir(1,1) + vlrc vir(2,2) = vir(2,2) + vlrc vir(3,3) = vir(3,3) + vlrc end if return end c c c ################################################################# c ## ## c ## subroutine ehal1a -- double loop buffer 14-7 vdw derivs ## c ## ## c ################################################################# c c c "ehal1a" calculates the buffered 14-7 van der Waals energy and c its first derivatives with respect to Cartesian coordinates c using a pairwise double loop c c subroutine ehal1a use atomid use atoms use bound use cell use couple use deriv use energi use group use mutant use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,de,eps,rdn real*8 fgrp,rv,rv7 real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 rho,rho6,rho7 real*8 tau,tau7,scal real*8 s1,s2,t1,t2 real*8 dt1drho,dt2drho real*8 dtau,gtau real*8 taper,dtaper real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 rik6,rik7 real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: vscale(:) logical proceed,usei logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find van der Waals energy and derivatives via double loop c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv rho6 = rho**6 rho7 = rho6 * rho eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 s1 = 1.0d0 / (scal+(rho+dhal)**7) s2 = 1.0d0 / (scal+rho7+ghal) t1 = (1.0d0+dhal)**7 * s1 t2 = (1.0d0+ghal) * s2 dt1drho = -7.0d0*(rho+dhal)**6 * t1 * s1 dt2drho = -7.0d0*rho6 * t2 * s2 e = eps * t1 * (t2-2.0d0) de = eps * (dt1drho*(t2-2.0d0)+t1*dt2drho) / rv else rv7 = rv**7 rik6 = rik2**3 rik7 = rik6 * rik rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) tau7 = tau**7 dtau = tau / (dhal+1.0d0) gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2 e = eps*tau7*rv7*((ghal+1.0d0)*rv7/rho-2.0d0) de = -7.0d0 * (dtau*e+gtau) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) iv = ired(i) it = jvdw(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,j) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv rho6 = rho**6 rho7 = rho6 * rho eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 s1 = 1.0d0 / (scal+(rho+dhal)**7) s2 = 1.0d0 / (scal+rho7+ghal) t1 = (1.0d0+dhal)**7 * s1 t2 = (1.0d0+ghal) * s2 dt1drho = -7.0d0*(rho+dhal)**6 * t1 * s1 dt2drho = -7.0d0*rho6 * t2 * s2 e = eps * t1 * (t2-2.0d0) de = eps * (dt1drho*(t2-2.0d0)+t1*dt2drho) / rv else rv7 = rv**7 rik6 = rik2**3 rik7 = rik6 * rik rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) tau7 = tau**7 dtau = tau / (dhal+1.0d0) gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2 e = eps*tau7*rv7*((ghal+1.0d0)*rv7/rho-2.0d0) de = -7.0d0 * (dtau*e+gtau) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c if (i .eq. k) e = 0.5d0 * e ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (i .ne. k) then if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################## c ## ## c ## subroutine ehal1b -- buffered 14-7 vdw derivs via lights ## c ## ## c ################################################################## c c c "ehal1b" calculates the buffered 14-7 van der Waals energy and c its first derivatives with respect to Cartesian coordinates c using the method of lights c c subroutine ehal1b use atomid use atoms use bound use boxes use cell use couple use deriv use energi use group use light use mutant use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer, allocatable :: iv14(:) real*8 e,de,eps,rdn real*8 fgrp,rv,rv7 real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 rho,rho6,rho7 real*8 tau,tau7,scal real*8 s1,s2,t1,t2 real*8 dt1drho,dt2drho real*8 dtau,gtau real*8 taper,dtaper real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 rik6,rik7 real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) mutk = mut(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv rho6 = rho**6 rho7 = rho6 * rho eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 s1 = 1.0d0 / (scal+(rho+dhal)**7) s2 = 1.0d0 / (scal+rho7+ghal) t1 = (1.0d0+dhal)**7 * s1 t2 = (1.0d0+ghal) * s2 dt1drho = -7.0d0*(rho+dhal)**6 * t1 * s1 dt2drho = -7.0d0*rho6 * t2 * s2 e = eps * t1 * (t2-2.0d0) de = eps * (dt1drho*(t2-2.0d0)+t1*dt2drho) / rv else rv7 = rv**7 rik6 = rik2**3 rik7 = rik6 * rik rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) tau7 = tau**7 dtau = tau / (dhal+1.0d0) gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2 e = eps*tau7*rv7*((ghal+1.0d0)*rv7/rho-2.0d0) de = -7.0d0 * (dtau*e+gtau) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ################################################################ c ## ## c ## subroutine ehal1c -- buffered 14-7 vdw derivs via list ## c ## ## c ################################################################ c c c "ehal1c" calculates the buffered 14-7 van der Waals energy and c its first derivatives with respect to Cartesian coordinates c using a pairwise neighbor list c c subroutine ehal1c use atomid use atoms use bound use couple use deriv use energi use group use mutant use neigh use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,de,eps,rdn real*8 fgrp,rv,rv7 real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 rho,rho6,rho7 real*8 tau,tau7,scal real*8 s1,s2,t1,t2 real*8 dt1drho,dt2drho real*8 dtau,gtau real*8 taper,dtaper real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 rik6,rik7 real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: vscale(:) logical proceed,usei logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired, !$OMP& kred,xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15, !$OMP& i12,i13,i14,i15,v2scale,v3scale,v4scale,v5scale, !$OMP& use_group,off2,radmin,epsilon,radmin4,epsilon4,ghal, !$OMP& dhal,cut2,vcouple,vlambda,mut,scexp,scalpha,c0,c1, !$OMP& c2,c3,c4,c5) !$OMP& firstprivate(vscale,iv14) shared(ev,dev,vir) !$OMP DO reduction(+:ev,dev,vir) schedule(guided) c c find van der Waals energy and derivatives via neighbor list c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv rho6 = rho**6 rho7 = rho6 * rho eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 s1 = 1.0d0 / (scal+(rho+dhal)**7) s2 = 1.0d0 / (scal+rho7+ghal) t1 = (1.0d0+dhal)**7 * s1 t2 = (1.0d0+ghal) * s2 dt1drho = -7.0d0*(rho+dhal)**6 * t1 * s1 dt2drho = -7.0d0*rho6 * t2 * s2 e = eps * t1 * (t2-2.0d0) de = eps * (dt1drho*(t2-2.0d0)+t1*dt2drho) / rv else rv7 = rv**7 rik6 = rik2**3 rik7 = rik6 * rik rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) tau7 = tau**7 dtau = tau / (dhal+1.0d0) gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2 e = eps*tau7*rv7*((ghal+1.0d0)*rv7/rho-2.0d0) de = -7.0d0 * (dtau*e+gtau) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine ehal2 -- atom-by-atom buffered 14-7 Hessian ## c ## ## c ################################################################ c c c "ehal2" calculates the buffered 14-7 van der Waals second c derivatives for a single atom at a time c c subroutine ehal2 (iatom) use atomid use atoms use bound use cell use couple use group use hessn use shunt use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer iatom,jcell integer nlist,list(5) integer, allocatable :: iv14(:) real*8 e,de,d2e real*8 fgrp,eps real*8 rdn,rv,rv7 real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 redi2,rediv2,rediiv real*8 redik,redivk real*8 redikv,redivkv real*8 rho,tau,tau7 real*8 dtau,gtau real*8 taper,dtaper,d2taper real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 rik6,rik7 real*8 d2edx,d2edy,d2edz real*8 term(3,3) real*8, allocatable :: vscale(:) logical proceed character*6 mode c c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c check to see if the atom of interest is a vdw site c nlist = 0 do k = 1, nvdw if (ivdw(k) .eq. iatom) then nlist = nlist + 1 list(nlist) = iatom goto 10 end if end do return 10 continue c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c determine the atoms involved via reduction factors c nlist = 1 list(nlist) = iatom do k = 1, n12(iatom) i = i12(k,iatom) if (ired(i) .eq. iatom) then nlist = nlist + 1 list(nlist) = i end if end do c c find van der Waals Hessian elements for involved atoms c do ii = 1, nlist i = list(ii) it = jvdw(i) iv = ired(i) redi = kred(i) if (i .ne. iv) then rediv = 1.0d0 - redi redi2 = redi * redi rediv2 = rediv * rediv rediiv = redi * rediv end if xi = xred(i) yi = yred(i) zi = zred(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (k .ne. i) c c compute the Hessian elements for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) rv7 = rv**7 rik6 = rik2**3 rik7 = rik6 * rik rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) tau7 = tau**7 dtau = tau / (dhal+1.0d0) gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2 e = eps*tau7*rv7*((ghal+1.0d0)*rv7/rho-2.0d0) de = -7.0d0 * (dtau*e+gtau) d2e = 56.0d0*dtau*dtau*e - 42.0d0*gtau/rik & + 98.0d0*gtau*(dtau+rik6/rho) c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik3 * rik2 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2 & + 6.0d0*c3*rik + 2.0d0*c2 d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper de = e*dtaper + de*taper 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 get chain rule terms for van der Waals Hessian elements c de = de / rik d2e = (d2e-de) / rik2 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 if (i .eq. iatom) then if (i.eq.iv .and. k.eq.kv) then 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 else if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redi hessy(j,k) = hessy(j,k) - term(2,j)*redi hessz(j,k) = hessz(j,k) - term(3,j)*redi hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv end do else if (i .eq. iv) then redk = kred(k) redkv = 1.0d0 - redk 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)*redk hessy(j,k) = hessy(j,k) - term(2,j)*redk hessz(j,k) = hessz(j,k) - term(3,j)*redk hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv end do else redk = kred(k) redkv = 1.0d0 - redk redik = redi * redk redikv = redi * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redik hessy(j,k) = hessy(j,k) - term(2,j)*redik hessz(j,k) = hessz(j,k) - term(3,j)*redik hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv end do end if else if (iv .eq. iatom) then if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*rediv hessy(j,k) = hessy(j,k) - term(2,j)*rediv hessz(j,k) = hessz(j,k) - term(3,j)*rediv hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 end do else redk = kred(k) redkv = 1.0d0 - redk redivk = rediv * redk redivkv = rediv * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*redivk hessy(j,k) = hessy(j,k) - term(2,j)*redivk hessz(j,k) = hessz(j,k) - term(3,j)*redivk hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv end do end if end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nlist i = list(ii) it = jvdw(i) iv = ired(i) redi = kred(i) if (i .ne. iv) then rediv = 1.0d0 - redi redi2 = redi * redi rediv2 = rediv * rediv rediiv = redi * rediv end if xi = xred(i) yi = yred(i) zi = zred(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) c c compute the Hessian elements for this interaction c if (proceed) then do jcell = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,jcell) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if rv7 = rv**7 rik6 = rik2**3 rik7 = rik6 * rik rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) tau7 = tau**7 dtau = tau / (dhal+1.0d0) gtau = eps*tau7*rik6*(ghal+1.0d0)*(rv7/rho)**2 e = eps*rv7*tau7*((ghal+1.0d0)*rv7/rho-2.0d0) de = -7.0d0 * (dtau*e+gtau) d2e = 56.0d0*dtau*dtau*e - 42.0d0*gtau/rik & + 98.0d0*gtau*(dtau+rik6/rho) c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik3 * rik2 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2 & + 6.0d0*c3*rik + 2.0d0*c2 d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper de = e*dtaper + de*taper 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 get chain rule terms for van der Waals Hessian elements c de = de / rik d2e = (d2e-de) / rik2 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 if (i .eq. iatom) then if (i.eq.iv .and. k.eq.kv) then 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 else if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redi hessy(j,k) = hessy(j,k) - term(2,j)*redi hessz(j,k) = hessz(j,k) - term(3,j)*redi hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediiv end do else if (i .eq. iv) then redk = kred(k) redkv = 1.0d0 - redk 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)*redk hessy(j,k) = hessy(j,k) - term(2,j)*redk hessz(j,k) = hessz(j,k) - term(3,j)*redk hessx(j,kv) = hessx(j,kv) & - term(1,j)*redkv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redkv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redkv end do else redk = kred(k) redkv = 1.0d0 - redk redik = redi * redk redikv = redi * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redik hessy(j,k) = hessy(j,k) - term(2,j)*redik hessz(j,k) = hessz(j,k) - term(3,j)*redik hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediiv hessx(j,kv) = hessx(j,kv) & - term(1,j)*redikv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redikv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redikv end do end if else if (iv .eq. iatom) then if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*rediv hessy(j,k) = hessy(j,k) - term(2,j)*rediv hessz(j,k) = hessz(j,k) - term(3,j)*rediv hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediv2 end do else redk = kred(k) redkv = 1.0d0 - redk redivk = rediv * redk redivkv = rediv * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*redivk hessy(j,k) = hessy(j,k) - term(2,j)*redivk hessz(j,k) = hessz(j,k) - term(3,j)*redivk hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediv2 hessx(j,kv) = hessx(j,kv) & - term(1,j)*redivkv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redivkv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redivkv end do end if end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine ehal3 -- buffered 14-7 vdw energy & analysis ## c ## ## c ################################################################# c c c "ehal3" calculates the buffered 14-7 van der Waals energy c and partitions the energy among the atoms c c subroutine ehal3 use analyz use atoms use energi use inform use iounit use limits use vdwpot implicit none integer i real*8 elrc,aelrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_lights) then call ehal3b else if (use_vlist) then call ehal3c else call ehal3a end if c c apply the long range van der Waals correction if used c if (use_vcorr) then mode = 'VDW' call evcorr (mode,elrc) ev = ev + elrc aelrc = elrc / dble(n) do i = 1, n aev(i) = aev(i) + aelrc end do if (verbose .and. elrc.ne.0.0d0) then if (digits .ge. 8) then write (iout,10) elrc 10 format (/,' Long-Range van der Waals :',6x,f16.8) else if (digits .ge. 6) then write (iout,20) elrc 20 format (/,' Long-Range van der Waals :',6x,f16.6) else write (iout,30) elrc 30 format (/,' Long-Range van der Waals :',6x,f16.4) end if end if end if return end c c c ################################################################# c ## ## c ## subroutine ehal3a -- double loop buffered 14-7 analysis ## c ## ## c ################################################################# c c c "ehal3a" calculates the buffered 14-7 van der Waals energy c and partitions the energy among the atoms using a pairwise c double loop c c subroutine ehal3a use action use analyz use atomid use atoms use bound use cell use couple use energi use group use inform use inter use iounit use molcul use mutant use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,rv,rv7 real*8 eps,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rho,tau,taper real*8 scal,t1,t2 real*8 rik,rik2,rik3 real*8 rik4,rik5,rik7 real*8, allocatable :: vscale(:) logical proceed,usei logical muti,mutk,mutik logical header,huge character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7) t2 = (1.0d0+ghal) / (scal+rho**7+ghal) e = eps * t1 * (t2-2.0d0) else rv7 = rv**7 rik7 = rik**7 rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) e = eps * rv7 * tau**7 & * ((ghal+1.0d0)*rv7/rho-2.0d0) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & rv,sqrt(rik2),e 30 format (' VDW-Hal',3x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,j) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7) t2 = (1.0d0+ghal) / (scal+rho**7+ghal) e = eps * t1 * (t2-2.0d0) else rv7 = rv**7 rik7 = rik**7 rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) e = eps * rv7 * tau**7 & * ((ghal+1.0d0)*rv7/rho-2.0d0) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy component c if (e .ne. 0.0d0) then nev = nev + 1 if (i .eq. k) then ev = ev + 0.5d0*e aev(i) = aev(i) + 0.5d0*e else ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if write (iout,50) i,name(i),k,name(k), & rv,sqrt(rik2),e 50 format (' VDW-Hal',3x,2(i7,'-',a3),1x, & '(XTAL)',6x,2f10.4,f12.4) end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################ c ## ## c ## subroutine ehal3b -- buffered 14-7 analysis via lights ## c ## ## c ################################################################ c c c "ehal3b" calculates the buffered 14-7 van der Waals energy c and also partitions the energy among the atoms using the c method of lights c c subroutine ehal3b use action use analyz use atomid use atoms use bound use boxes use cell use couple use energi use group use inform use inter use iounit use light use molcul use mutant use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer ikmin,ikmax integer, allocatable :: iv14(:) real*8 e,rv,rv7 real*8 eps,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rho,tau,taper real*8 scal,t1,t2 real*8 rik,rik2,rik3 real*8 rik4,rik5,rik7 real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat logical muti,mutk,mutik logical header,huge character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 20 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 60 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 60 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 60 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 60 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) mutk = mut(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7) t2 = (1.0d0+ghal) / (scal+rho**7+ghal) e = eps * t1 * (t2-2.0d0) else rv7 = rv**7 rik7 = rik**7 rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) e = eps * rv7 * tau**7 & * ((ghal+1.0d0)*rv7/rho-2.0d0) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if c c increment the total intermolecular energy c if (.not.prime .or. 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,30) 30 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if ikmin = min(i,k) ikmax = max(i,k) if (prime) then write (iout,40) ikmin,name(ikmin),ikmax, & name(ikmax),rv,sqrt(rik2),e 40 format (' VDW-Hal',3x,2(i7,'-',a3), & 13x,2f10.4,f12.4) else write (iout,50) ikmax,name(ikmin),ikmax, & name(ikmax),rv,sqrt(rik2),e 50 format (' VDW-Hal',3x,2(i7,'-',a3),1x, & '(XTAL)',6x,2f10.4,f12.4) end if end if end if end if 60 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 20 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################## c ## ## c ## subroutine ehal3c -- buffered 14-7 analysis via list ## c ## ## c ############################################################## c c c "ehal3c" calculates the buffered 14-7 van der Waals energy c and also partitions the energy among the atoms using a c pairwise neighbor list c c subroutine ehal3c use action use analyz use atomid use atoms use bound use couple use energi use group use inform use inter use iounit use molcul use mutant use neigh use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,eps,rdn real*8 fgrp,rv,rv7 real*8 xi,yi,zi real*8 xr,yr,zr real*8 rho,tau,taper real*8 scal,t1,t2 real*8 rik,rik2,rik3 real*8 rik4,rik5,rik7 real*8, allocatable :: vscale(:) logical proceed,usei logical muti,mutk,mutik logical header,huge character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw, !$OMP& ired,xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15, !$OMP& i12,i13,i14,i15,v2scale,v3scale,v4scale,v5scale, !$OMP& use_group,off2,radmin,epsilon,radmin4,epsilon4,ghal, !$OMP& dhal,vcouple,vlambda,mut,scexp,scalpha,cut2,c0,c1, !$OMP& c2,c3,c4,c5,molcule,name,verbose,debug,header,iout) !$OMP& firstprivate(vscale,iv14) shared(ev,nev,aev,einter) !$OMP DO reduction(+:ev,nev,aev,einter) schedule(guided) c c find the van der Waals energy via neighbor list search c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rik = sqrt(rik2) rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then rho = rik / rv eps = eps * vlambda**scexp scal = scalpha * (1.0d0-vlambda)**2 t1 = (1.0d0+dhal)**7 / (scal+(rho+dhal)**7) t2 = (1.0d0+ghal) / (scal+rho**7+ghal) e = eps * t1 * (t2-2.0d0) else rv7 = rv**7 rik7 = rik**7 rho = rik7 + ghal*rv7 tau = (dhal+1.0d0) / (rik + dhal*rv) e = eps * rv7 * tau**7 & * ((ghal+1.0d0)*rv7/rho-2.0d0) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & rv,sqrt(rik2),e 30 format (' VDW-Hal',3x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ######################################################## c ## ## c ## subroutine eimprop -- improper dihedral energy ## c ## ## c ######################################################## c c c "eimprop" calculates the improper dihedral potential energy c c subroutine eimprop use atoms use bound use energi use group use improp use math use torpot use usage implicit none integer i,ia,ib,ic,id real*8 e,eps,dt,fgrp real*8 ideal,force real*8 cosine,sine real*8 rcb,angle real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc logical proceed c c c zero out improper dihedral energy c eid = 0.0d0 if (niprop .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(niprop,iiprop,use, !$OMP& x,y,z,kprop,vprop,idihunit,eps,use_group,use_polymer) !$OMP& shared(eid) !$OMP DO reduction(+:eid) schedule(guided) c c calculate the improper dihedral angle energy term c do i = 1, niprop ia = iiprop(1,i) ib = iiprop(2,i) ic = iiprop(3,i) id = iiprop(4,i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) c c compute the value of the improper dihedral angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (sine .lt. 0.0d0) angle = -angle c c set the improper dihedral parameters for this angle c ideal = vprop(i) force = kprop(i) if (abs(angle+ideal) .lt. abs(angle-ideal)) & ideal = -ideal dt = angle - ideal do while (dt .gt. 180.0d0) dt = dt - 360.0d0 end do do while (dt .lt. -180.0d0) dt = dt + 360.0d0 end do c c calculate the improper dihedral energy c e = idihunit * force * dt**2 c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total improper dihedral energy c eid = eid + e end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine eimprop1 -- impr. dihedral energy & gradient ## c ## ## c ################################################################# c c c "eimprop1" calculates improper dihedral energy and its c first derivatives with respect to Cartesian coordinates c c subroutine eimprop1 use atoms use bound use deriv use energi use group use improp use math use torpot use usage use virial implicit none integer i,ia,ib,ic,id real*8 e,eps,fgrp real*8 dt,term real*8 dedphi real*8 ideal,force real*8 cosine,sine real*8 rcb,angle real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 xca,yca,zca real*8 xdb,ydb,zdb real*8 dedxt,dedyt,dedzt real*8 dedxu,dedyu,dedzu real*8 dedxia,dedyia,dedzia real*8 dedxib,dedyib,dedzib real*8 dedxic,dedyic,dedzic real*8 dedxid,dedyid,dedzid real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy logical proceed c c c zero out energy and first derivative components c eid = 0.0d0 do i = 1, n deid(1,i) = 0.0d0 deid(2,i) = 0.0d0 deid(3,i) = 0.0d0 end do if (niprop .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(niprop,iiprop,use, !$OMP& x,y,z,kprop,vprop,idihunit,eps,use_group,use_polymer) !$OMP& shared(eid,deid,vir) !$OMP DO reduction(+:eid,deid,vir) schedule(guided) c c calculate the improper dihedral angle energy term c do i = 1, niprop ia = iiprop(1,i) ib = iiprop(2,i) ic = iiprop(3,i) id = iiprop(4,i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) c c compute the value of the improper dihedral angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (sine .lt. 0.0d0) angle = -angle c c set the improper dihedral parameters for this angle c ideal = vprop(i) force = kprop(i) if (abs(angle+ideal) .lt. abs(angle-ideal)) & ideal = -ideal dt = angle - ideal do while (dt .gt. 180.0d0) dt = dt - 360.0d0 end do do while (dt .lt. -180.0d0) dt = dt + 360.0d0 end do c c calculate improper energy and master chain rule term c term = idihunit * force * dt e = term * dt dedphi = 2.0d0 * radian * term c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp dedphi = dedphi * fgrp end if c c chain rule terms for first derivative components c xca = xic - xia yca = yic - yia zca = zic - zia xdb = xid - xib ydb = yid - yib zdb = zid - zib if (use_polymer) then call image (xca,yca,zca) call image (xdb,ydb,zdb) end if dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb) dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb) dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb) dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb) dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb) dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb) c c compute first derivative components for this angle c dedxia = zcb*dedyt - ycb*dedzt dedyia = xcb*dedzt - zcb*dedxt dedzia = ycb*dedxt - xcb*dedyt dedxib = yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu dedyib = zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu dedzib = xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu dedxic = zba*dedyt - yba*dedzt + ydb*dedzu - zdb*dedyu dedyic = xba*dedzt - zba*dedxt + zdb*dedxu - xdb*dedzu dedzic = yba*dedxt - xba*dedyt + xdb*dedyu - ydb*dedxu dedxid = zcb*dedyu - ycb*dedzu dedyid = xcb*dedzu - zcb*dedxu dedzid = ycb*dedxu - xcb*dedyu c c calculate improper dihedral energy and derivatives c eid = eid + e deid(1,ia) = deid(1,ia) + dedxia deid(2,ia) = deid(2,ia) + dedyia deid(3,ia) = deid(3,ia) + dedzia deid(1,ib) = deid(1,ib) + dedxib deid(2,ib) = deid(2,ib) + dedyib deid(3,ib) = deid(3,ib) + dedzib deid(1,ic) = deid(1,ic) + dedxic deid(2,ic) = deid(2,ic) + dedyic deid(3,ic) = deid(3,ic) + dedzic deid(1,id) = deid(1,id) + dedxid deid(2,id) = deid(2,id) + dedyid deid(3,id) = deid(3,id) + dedzid c c increment the internal virial tensor components c vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine eimprop2 -- atomwise imp. dihedral Hessian ## c ## ## c ############################################################### c c c "eimprop2" calculates second derivatives of the improper c dihedral angle energy for a single atom c c subroutine eimprop2 (i) use atoms use bound use group use hessn use improp use math use torpot implicit none integer i,kiprop integer ia,ib,ic,id real*8 eps,fgrp real*8 ideal,force real*8 angle,dt,term real*8 dedphi,d2edphi2 real*8 sine,cosine real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 xca,yca,zca real*8 xdb,ydb,zdb real*8 xt,yt,zt,xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru,rcb real*8 dphidxt,dphidyt,dphidzt real*8 dphidxu,dphidyu,dphidzu real*8 dphidxia,dphidyia,dphidzia real*8 dphidxib,dphidyib,dphidzib real*8 dphidxic,dphidyic,dphidzic real*8 dphidxid,dphidyid,dphidzid real*8 xycb2,xzcb2,yzcb2 real*8 rcbxt,rcbyt,rcbzt,rcbt2 real*8 rcbxu,rcbyu,rcbzu,rcbu2 real*8 dphidxibt,dphidyibt,dphidzibt real*8 dphidxibu,dphidyibu,dphidzibu real*8 dphidxict,dphidyict,dphidzict real*8 dphidxicu,dphidyicu,dphidzicu real*8 dxiaxia,dyiayia,dziazia real*8 dxibxib,dyibyib,dzibzib real*8 dxicxic,dyicyic,dziczic real*8 dxidxid,dyidyid,dzidzid real*8 dxiayia,dxiazia,dyiazia real*8 dxibyib,dxibzib,dyibzib real*8 dxicyic,dxiczic,dyiczic real*8 dxidyid,dxidzid,dyidzid real*8 dxiaxib,dxiayib,dxiazib real*8 dyiaxib,dyiayib,dyiazib real*8 dziaxib,dziayib,dziazib real*8 dxiaxic,dxiayic,dxiazic real*8 dyiaxic,dyiayic,dyiazic real*8 dziaxic,dziayic,dziazic real*8 dxiaxid,dxiayid,dxiazid real*8 dyiaxid,dyiayid,dyiazid real*8 dziaxid,dziayid,dziazid real*8 dxibxic,dxibyic,dxibzic real*8 dyibxic,dyibyic,dyibzic real*8 dzibxic,dzibyic,dzibzic real*8 dxibxid,dxibyid,dxibzid real*8 dyibxid,dyibyid,dyibzid real*8 dzibxid,dzibyid,dzibzid real*8 dxicxid,dxicyid,dxiczid real*8 dyicxid,dyicyid,dyiczid real*8 dzicxid,dzicyid,dziczid logical proceed c c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c compute Hessian elements for the improper dihedral angles c do kiprop = 1, niprop ia = iiprop(1,kiprop) ib = iiprop(2,kiprop) ic = iiprop(3,kiprop) id = iiprop(4,kiprop) c c decide whether to compute the current interaction c 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) c c compute the value of the improper dihedral angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (sine .lt. 0.0d0) angle = -angle c c set the improper dihedral parameters for this angle c ideal = vprop(kiprop) force = kprop(kiprop) if (abs(angle+ideal) .lt. abs(angle-ideal)) & ideal = -ideal dt = angle - ideal do while (dt .gt. 180.0d0) dt = dt - 360.0d0 end do do while (dt .lt. -180.0d0) dt = dt + 360.0d0 end do c c calculate the improper torsion master chain rule terms c term = 2.0d0 * radian * idihunit * force dedphi = term * dt d2edphi2 = radian * term c c scale the interaction based on its group membership c if (use_group) then dedphi = dedphi * fgrp d2edphi2 = d2edphi2 * fgrp end if c c abbreviations for first derivative chain rule terms c xca = xic - xia yca = yic - yia zca = zic - zia xdb = xid - xib ydb = yid - yib zdb = zid - zib if (use_polymer) then call image (xca,yca,zca) call image (xdb,ydb,zdb) end if dphidxt = (yt*zcb - ycb*zt) / (rt2*rcb) dphidyt = (zt*xcb - zcb*xt) / (rt2*rcb) dphidzt = (xt*ycb - xcb*yt) / (rt2*rcb) dphidxu = -(yu*zcb - ycb*zu) / (ru2*rcb) dphidyu = -(zu*xcb - zcb*xu) / (ru2*rcb) dphidzu = -(xu*ycb - xcb*yu) / (ru2*rcb) c c abbreviations for second derivative chain rule terms c xycb2 = xcb*xcb + ycb*ycb xzcb2 = xcb*xcb + zcb*zcb yzcb2 = ycb*ycb + zcb*zcb rcbxt = -2.0d0 * rcb * dphidxt rcbyt = -2.0d0 * rcb * dphidyt rcbzt = -2.0d0 * rcb * dphidzt rcbt2 = rcb * rt2 rcbxu = 2.0d0 * rcb * dphidxu rcbyu = 2.0d0 * rcb * dphidyu rcbzu = 2.0d0 * rcb * dphidzu rcbu2 = rcb * ru2 dphidxibt = yca*dphidzt - zca*dphidyt dphidxibu = zdc*dphidyu - ydc*dphidzu dphidyibt = zca*dphidxt - xca*dphidzt dphidyibu = xdc*dphidzu - zdc*dphidxu dphidzibt = xca*dphidyt - yca*dphidxt dphidzibu = ydc*dphidxu - xdc*dphidyu dphidxict = zba*dphidyt - yba*dphidzt dphidxicu = ydb*dphidzu - zdb*dphidyu dphidyict = xba*dphidzt - zba*dphidxt dphidyicu = zdb*dphidxu - xdb*dphidzu dphidzict = yba*dphidxt - xba*dphidyt dphidzicu = xdb*dphidyu - ydb*dphidxu c c chain rule terms for first derivative components c dphidxia = zcb*dphidyt - ycb*dphidzt dphidyia = xcb*dphidzt - zcb*dphidxt dphidzia = ycb*dphidxt - xcb*dphidyt dphidxib = dphidxibt + dphidxibu dphidyib = dphidyibt + dphidyibu dphidzib = dphidzibt + dphidzibu dphidxic = dphidxict + dphidxicu dphidyic = dphidyict + dphidyicu dphidzic = dphidzict + dphidzicu dphidxid = zcb*dphidyu - ycb*dphidzu dphidyid = xcb*dphidzu - zcb*dphidxu dphidzid = ycb*dphidxu - xcb*dphidyu c c chain rule terms for second derivative components c dxiaxia = rcbxt*dphidxia dxiayia = rcbxt*dphidyia - zcb*rcb/rt2 dxiazia = rcbxt*dphidzia + ycb*rcb/rt2 dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2 dxiayic = rcbxt*dphidyict - dphidzt & - (xba*zcb*xcb+zba*yzcb2)/rcbt2 dxiazic = rcbxt*dphidzict + dphidyt & + (xba*ycb*xcb+yba*yzcb2)/rcbt2 dxiaxid = 0.0d0 dxiayid = 0.0d0 dxiazid = 0.0d0 dyiayia = rcbyt*dphidyia dyiazia = rcbyt*dphidzia - xcb*rcb/rt2 dyiaxib = rcbyt*dphidxibt - dphidzt & - (yca*zcb*ycb+zca*xzcb2)/rcbt2 dyiaxic = rcbyt*dphidxict + dphidzt & + (yba*zcb*ycb+zba*xzcb2)/rcbt2 dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2 dyiazic = rcbyt*dphidzict - dphidxt & - (yba*xcb*ycb+xba*xzcb2)/rcbt2 dyiaxid = 0.0d0 dyiayid = 0.0d0 dyiazid = 0.0d0 dziazia = rcbzt*dphidzia dziaxib = rcbzt*dphidxibt + dphidyt & + (zca*ycb*zcb+yca*xycb2)/rcbt2 dziayib = rcbzt*dphidyibt - dphidxt & - (zca*xcb*zcb+xca*xycb2)/rcbt2 dziaxic = rcbzt*dphidxict - dphidyt & - (zba*ycb*zcb+yba*xycb2)/rcbt2 dziayic = rcbzt*dphidyict + dphidxt & + (zba*xcb*zcb+xba*xycb2)/rcbt2 dziazic = rcbzt*dphidzict + zcb*zt/rcbt2 dziaxid = 0.0d0 dziayid = 0.0d0 dziazid = 0.0d0 dxibxic = -xcb*dphidxib/(rcb*rcb) & - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2 & - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2 dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu & - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2 & - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2 & + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2 & + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2 dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2 dxibyid = rcbyu*dphidxibu - dphidzu & - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2 dxibzid = rcbzu*dphidxibu + dphidyu & + (zdc*ycb*zcb+ydc*xycb2)/rcbu2 dyibzib = ycb*dphidzib/(rcb*rcb) & - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2 & - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2 & + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2 & + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2 dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu & + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2 & - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2 dyibyic = -ycb*dphidyib/(rcb*rcb) & - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2 & - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2 & - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2 & + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2 dyibxid = rcbxu*dphidyibu + dphidzu & + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2 dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2 dyibzid = rcbzu*dphidyibu - dphidxu & - (zdc*xcb*zcb+xdc*xycb2)/rcbu2 dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu & - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2 & + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2 dzibzic = -zcb*dphidzib/(rcb*rcb) & - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2 & - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2 & - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2 & + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2 dzibxid = rcbxu*dphidzibu - dphidyu & - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2 dzibyid = rcbyu*dphidzibu + dphidxu & + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2 dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2 dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2 dxicyid = rcbyu*dphidxicu + dphidzu & + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2 dxiczid = rcbzu*dphidxicu - dphidyu & - (zdb*ycb*zcb+ydb*xycb2)/rcbu2 dyicxid = rcbxu*dphidyicu - dphidzu & - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2 dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2 dyiczid = rcbzu*dphidyicu + dphidxu & + (zdb*xcb*zcb+xdb*xycb2)/rcbu2 dzicxid = rcbxu*dphidzicu + dphidyu & + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2 dzicyid = rcbyu*dphidzicu - dphidxu & - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2 dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2 dxidxid = rcbxu*dphidxid dxidyid = rcbxu*dphidyid + zcb*rcb/ru2 dxidzid = rcbxu*dphidzid - ycb*rcb/ru2 dyidyid = rcbyu*dphidyid dyidzid = rcbyu*dphidzid + xcb*rcb/ru2 dzidzid = rcbzu*dphidzid c c get some second derivative chain rule terms by difference c dxiaxib = -dxiaxia - dxiaxic - dxiaxid dxiayib = -dxiayia - dxiayic - dxiayid dxiazib = -dxiazia - dxiazic - dxiazid dyiayib = -dyiayia - dyiayic - dyiayid dyiazib = -dyiazia - dyiazic - dyiazid dziazib = -dziazia - dziazic - dziazid dxibxib = -dxiaxib - dxibxic - dxibxid dxibyib = -dyiaxib - dxibyic - dxibyid dxibzib = -dxiazib - dzibxic - dzibxid dxibzic = -dziaxib - dxibzib - dxibzid dyibyib = -dyiayib - dyibyic - dyibyid dyibzic = -dziayib - dyibzib - dyibzid dzibzib = -dziazib - dzibzic - dzibzid dzibyic = -dyiazib - dyibzib - dzibyid dxicxic = -dxiaxic - dxibxic - dxicxid dxicyic = -dyiaxic - dyibxic - dxicyid dxiczic = -dziaxic - dzibxic - dxiczid dyicyic = -dyiayic - dyibyic - dyicyid dyiczic = -dziayic - dzibyic - dyiczid dziczic = -dziazic - dzibzic - dziczid c c increment diagonal and off-diagonal Hessian elements c if (i .eq. ia) then hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia & + d2edphi2*dphidxia*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia & + d2edphi2*dphidxia*dphidyia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia & + d2edphi2*dphidxia*dphidzia hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia & + d2edphi2*dphidxia*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia & + d2edphi2*dphidyia*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia & + d2edphi2*dphidyia*dphidzia hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia & + d2edphi2*dphidxia*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia & + d2edphi2*dphidyia*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazia & + d2edphi2*dphidzia*dphidzia hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib & + d2edphi2*dphidxia*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib & + d2edphi2*dphidyia*dphidxib hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib & + d2edphi2*dphidzia*dphidxib hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib & + d2edphi2*dphidxia*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib & + d2edphi2*dphidyia*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dziayib & + d2edphi2*dphidzia*dphidyib hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib & + d2edphi2*dphidxia*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib & + d2edphi2*dphidyia*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dziazib & + d2edphi2*dphidzia*dphidzib hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic & + d2edphi2*dphidxia*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic & + d2edphi2*dphidyia*dphidxic hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic & + d2edphi2*dphidzia*dphidxic hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic & + d2edphi2*dphidxia*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic & + d2edphi2*dphidyia*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dziayic & + d2edphi2*dphidzia*dphidyic hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic & + d2edphi2*dphidxia*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic & + d2edphi2*dphidyia*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dziazic & + d2edphi2*dphidzia*dphidzic hessx(1,id) = hessx(1,id) + dedphi*dxiaxid & + d2edphi2*dphidxia*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dyiaxid & + d2edphi2*dphidyia*dphidxid hessz(1,id) = hessz(1,id) + dedphi*dziaxid & + d2edphi2*dphidzia*dphidxid hessx(2,id) = hessx(2,id) + dedphi*dxiayid & + d2edphi2*dphidxia*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyiayid & + d2edphi2*dphidyia*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dziayid & + d2edphi2*dphidzia*dphidyid hessx(3,id) = hessx(3,id) + dedphi*dxiazid & + d2edphi2*dphidxia*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyiazid & + d2edphi2*dphidyia*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dziazid & + d2edphi2*dphidzia*dphidzid else if (i .eq. ib) then hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib & + d2edphi2*dphidxib*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib & + d2edphi2*dphidxib*dphidyib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib & + d2edphi2*dphidxib*dphidzib hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib & + d2edphi2*dphidxib*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib & + d2edphi2*dphidyib*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib & + d2edphi2*dphidyib*dphidzib hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib & + d2edphi2*dphidxib*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib & + d2edphi2*dphidyib*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib & + d2edphi2*dphidzib*dphidzib hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib & + d2edphi2*dphidxib*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib & + d2edphi2*dphidyib*dphidxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib & + d2edphi2*dphidzib*dphidxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib & + d2edphi2*dphidxib*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib & + d2edphi2*dphidyib*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib & + d2edphi2*dphidzib*dphidyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib & + d2edphi2*dphidxib*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayib & + d2edphi2*dphidyib*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazib & + d2edphi2*dphidzib*dphidzia hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic & + d2edphi2*dphidxib*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic & + d2edphi2*dphidyib*dphidxic hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic & + d2edphi2*dphidzib*dphidxic hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic & + d2edphi2*dphidxib*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic & + d2edphi2*dphidyib*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic & + d2edphi2*dphidzib*dphidyic hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic & + d2edphi2*dphidxib*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic & + d2edphi2*dphidyib*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic & + d2edphi2*dphidzib*dphidzic hessx(1,id) = hessx(1,id) + dedphi*dxibxid & + d2edphi2*dphidxib*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dyibxid & + d2edphi2*dphidyib*dphidxid hessz(1,id) = hessz(1,id) + dedphi*dzibxid & + d2edphi2*dphidzib*dphidxid hessx(2,id) = hessx(2,id) + dedphi*dxibyid & + d2edphi2*dphidxib*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyibyid & + d2edphi2*dphidyib*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dzibyid & + d2edphi2*dphidzib*dphidyid hessx(3,id) = hessx(3,id) + dedphi*dxibzid & + d2edphi2*dphidxib*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyibzid & + d2edphi2*dphidyib*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dzibzid & + d2edphi2*dphidzib*dphidzid else if (i .eq. ic) then hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic & + d2edphi2*dphidxic*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic & + d2edphi2*dphidxic*dphidyic hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic & + d2edphi2*dphidxic*dphidzic hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic & + d2edphi2*dphidxic*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic & + d2edphi2*dphidyic*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic & + d2edphi2*dphidyic*dphidzic hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic & + d2edphi2*dphidxic*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic & + d2edphi2*dphidyic*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dziczic & + d2edphi2*dphidzic*dphidzic hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic & + d2edphi2*dphidxic*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic & + d2edphi2*dphidyic*dphidxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic & + d2edphi2*dphidzic*dphidxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic & + d2edphi2*dphidxic*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic & + d2edphi2*dphidyic*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic & + d2edphi2*dphidzic*dphidyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic & + d2edphi2*dphidxic*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayic & + d2edphi2*dphidyic*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazic & + d2edphi2*dphidzic*dphidzia hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic & + d2edphi2*dphidxic*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic & + d2edphi2*dphidyic*dphidxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic & + d2edphi2*dphidzic*dphidxib hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic & + d2edphi2*dphidxic*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic & + d2edphi2*dphidyic*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic & + d2edphi2*dphidzic*dphidyib hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic & + d2edphi2*dphidxic*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic & + d2edphi2*dphidyic*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic & + d2edphi2*dphidzic*dphidzib hessx(1,id) = hessx(1,id) + dedphi*dxicxid & + d2edphi2*dphidxic*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dyicxid & + d2edphi2*dphidyic*dphidxid hessz(1,id) = hessz(1,id) + dedphi*dzicxid & + d2edphi2*dphidzic*dphidxid hessx(2,id) = hessx(2,id) + dedphi*dxicyid & + d2edphi2*dphidxic*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyicyid & + d2edphi2*dphidyic*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dzicyid & + d2edphi2*dphidzic*dphidyid hessx(3,id) = hessx(3,id) + dedphi*dxiczid & + d2edphi2*dphidxic*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyiczid & + d2edphi2*dphidyic*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dziczid & + d2edphi2*dphidzic*dphidzid else if (i .eq. id) then hessx(1,id) = hessx(1,id) + dedphi*dxidxid & + d2edphi2*dphidxid*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dxidyid & + d2edphi2*dphidxid*dphidyid hessz(1,id) = hessz(1,id) + dedphi*dxidzid & + d2edphi2*dphidxid*dphidzid hessx(2,id) = hessx(2,id) + dedphi*dxidyid & + d2edphi2*dphidxid*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyidyid & + d2edphi2*dphidyid*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dyidzid & + d2edphi2*dphidyid*dphidzid hessx(3,id) = hessx(3,id) + dedphi*dxidzid & + d2edphi2*dphidxid*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyidzid & + d2edphi2*dphidyid*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dzidzid & + d2edphi2*dphidzid*dphidzid hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid & + d2edphi2*dphidxid*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid & + d2edphi2*dphidyid*dphidxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid & + d2edphi2*dphidzid*dphidxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid & + d2edphi2*dphidxid*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid & + d2edphi2*dphidyid*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid & + d2edphi2*dphidzid*dphidyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid & + d2edphi2*dphidxid*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayid & + d2edphi2*dphidyid*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazid & + d2edphi2*dphidzid*dphidzia hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid & + d2edphi2*dphidxid*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid & + d2edphi2*dphidyid*dphidxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid & + d2edphi2*dphidzid*dphidxib hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid & + d2edphi2*dphidxid*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid & + d2edphi2*dphidyid*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid & + d2edphi2*dphidzid*dphidyib hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid & + d2edphi2*dphidxid*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid & + d2edphi2*dphidyid*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid & + d2edphi2*dphidzid*dphidzib hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid & + d2edphi2*dphidxid*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid & + d2edphi2*dphidyid*dphidxic hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid & + d2edphi2*dphidzid*dphidxic hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid & + d2edphi2*dphidxid*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid & + d2edphi2*dphidyid*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid & + d2edphi2*dphidzid*dphidyic hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid & + d2edphi2*dphidxid*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid & + d2edphi2*dphidyid*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dziczid & + d2edphi2*dphidzid*dphidzic end if end if end do return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine eimprop3 -- imp. dihedral energy & analysis ## c ## ## c ################################################################ c c c "eimprop3" calculates the improper dihedral potential c energy; also partitions the energy terms among the atoms c c subroutine eimprop3 use action use analyz use atomid use atoms use bound use energi use group use improp use inform use iounit use math use torpot use usage implicit none integer i,ia,ib,ic,id real*8 e,eps,dt,fgrp real*8 ideal,force real*8 cosine,sine real*8 rcb,angle real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc logical proceed logical header,huge c c c zero out improper dihedral energy and partitioning terms c neid = 0 eid = 0.0d0 do i = 1, n aeid(i) = 0.0d0 end do if (niprop .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c print header information if debug output was requested c header = .true. if (debug .and. niprop.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Improper Dihedral Interactions :', & //,' Type',25x,'Atom Names',21x,'Angle', & 6x,'Energy',/) end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(niprop,iiprop,use, !$OMP& x,y,z,kprop,vprop,idihunit,eps,use_group,use_polymer, !$OMP& name,verbose,debug,header,iout) !$OMP& shared(eid,neid,aeid) !$OMP DO reduction(+:eid,neid,aeid) schedule(guided) c c calculate the improper dihedral angle energy term c do i = 1, niprop ia = iiprop(1,i) ib = iiprop(2,i) ic = iiprop(3,i) id = iiprop(4,i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) c c compute the value of the improper dihedral angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (sine .lt. 0.0d0) angle = -angle c c set the improper dihedral parameters for this angle c ideal = vprop(i) force = kprop(i) if (abs(angle+ideal) .lt. abs(angle-ideal)) & ideal = -ideal dt = angle - ideal do while (dt .gt. 180.0d0) dt = dt - 360.0d0 end do do while (dt .lt. -180.0d0) dt = dt + 360.0d0 end do c c calculate the improper dihedral energy c e = idihunit * force * dt**2 c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total improper dihedral energy c neid = neid + 1 eid = eid + e aeid(ib) = aeid(ib) + 0.5d0*e aeid(ic) = aeid(ic) + 0.5d0*e c c print a message if the energy of this interaction is large c huge = (e .gt. 5.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Improper Dihedral', & ' Interactions :', & //,' Type',25x,'Atom Names',21x,'Angle', & 6x,'Energy',/) end if write (iout,30) ia,name(ia),ib,name(ib),ic, & name(ic),id,name(id),angle,e 30 format (' Improper',2x,4(i7,'-',a3),f11.4,f12.4) end if end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ####################################################### c ## ## c ## subroutine eimptor -- improper torsion energy ## c ## ## c ####################################################### c c c "eimptor" calculates the improper torsion potential energy c c subroutine eimptor use atoms use bound use energi use group use imptor use torpot use usage implicit none integer i,ia,ib,ic,id real*8 e,eps real*8 rcb,fgrp real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru real*8 v1,v2,v3 real*8 c1,c2,c3 real*8 s1,s2,s3 real*8 sine,cosine real*8 sine2,cosine2 real*8 sine3,cosine3 real*8 phi1,phi2,phi3 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc logical proceed c c c zero out improper torsional energy c eit = 0.0d0 if (nitors .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nitors,iitors,use,x,y,z, !$OMP& itors1,itors2,itors3,itorunit,eps,use_group,use_polymer) !$OMP& shared(eit) !$OMP DO reduction(+:eit) schedule(guided) c c calculate the improper torsional angle energy term c do i = 1, nitors ia = iitors(1,i) ib = iitors(2,i) ic = iitors(3,i) id = iitors(4,i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) c c compute the value of the torsional angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) c c set the improper torsional parameters for this angle c v1 = itors1(1,i) c1 = itors1(3,i) s1 = itors1(4,i) v2 = itors2(1,i) c2 = itors2(3,i) s2 = itors2(4,i) v3 = itors3(1,i) c3 = itors3(3,i) s3 = itors3(4,i) c c compute the multiple angle trigonometry and the phase terms c cosine2 = cosine*cosine - sine*sine sine2 = 2.0d0 * cosine * sine cosine3 = cosine*cosine2 - sine*sine2 sine3 = cosine*sine2 + sine*cosine2 phi1 = 1.0d0 + (cosine*c1 + sine*s1) phi2 = 1.0d0 + (cosine2*c2 + sine2*s2) phi3 = 1.0d0 + (cosine3*c3 + sine3*s3) c c calculate the improper torsional energy for this angle c e = itorunit * (v1*phi1 + v2*phi2 + v3*phi3) c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total torsional angle energy c eit = eit + e end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine eimptor1 -- impr. torsion energy & gradient ## c ## ## c ################################################################ c c c "eimptor1" calculates improper torsion energy and its c first derivatives with respect to Cartesian coordinates c c subroutine eimptor1 use atoms use bound use deriv use energi use group use imptor use torpot use usage use virial implicit none integer i,ia,ib,ic,id real*8 e,eps,rcb real*8 dedphi,fgrp real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru real*8 v1,v2,v3 real*8 c1,c2,c3 real*8 s1,s2,s3 real*8 sine,cosine real*8 sine2,cosine2 real*8 sine3,cosine3 real*8 phi1,phi2,phi3 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 xca,yca,zca real*8 xdb,ydb,zdb real*8 dphi1,dphi2,dphi3 real*8 dedxt,dedyt,dedzt real*8 dedxu,dedyu,dedzu real*8 dedxia,dedyia,dedzia real*8 dedxib,dedyib,dedzib real*8 dedxic,dedyic,dedzic real*8 dedxid,dedyid,dedzid real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy logical proceed c c c zero out energy and first derivative components c eit = 0.0d0 do i = 1, n deit(1,i) = 0.0d0 deit(2,i) = 0.0d0 deit(3,i) = 0.0d0 end do if (nitors .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nitors,iitors,use,x,y,z, !$OMP& itors1,itors2,itors3,itorunit,eps,use_group,use_polymer) !$OMP& shared(eit,deit,vir) !$OMP DO reduction(+:eit,deit,vir) schedule(guided) c c calculate the improper torsional angle energy term c do i = 1, nitors ia = iitors(1,i) ib = iitors(2,i) ic = iitors(3,i) id = iitors(4,i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) c c compute the value of the torsional angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) c c set the improper torsional parameters for this angle c v1 = itors1(1,i) c1 = itors1(3,i) s1 = itors1(4,i) v2 = itors2(1,i) c2 = itors2(3,i) s2 = itors2(4,i) v3 = itors3(1,i) c3 = itors3(3,i) s3 = itors3(4,i) c c compute the multiple angle trigonometry and the phase terms c cosine2 = cosine*cosine - sine*sine sine2 = 2.0d0 * cosine * sine cosine3 = cosine*cosine2 - sine*sine2 sine3 = cosine*sine2 + sine*cosine2 phi1 = 1.0d0 + (cosine*c1 + sine*s1) phi2 = 1.0d0 + (cosine2*c2 + sine2*s2) phi3 = 1.0d0 + (cosine3*c3 + sine3*s3) dphi1 = (cosine*s1 - sine*c1) dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2) dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3) c c calculate improper torsion energy and master chain rule term c e = itorunit * (v1*phi1+v2*phi2+v3*phi3) dedphi = itorunit * (v1*dphi1+v2*dphi2+v3*dphi3) c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp dedphi = dedphi * fgrp end if c c chain rule terms for first derivative components c xca = xic - xia yca = yic - yia zca = zic - zia xdb = xid - xib ydb = yid - yib zdb = zid - zib if (use_polymer) then call image (xca,yca,zca) call image (xdb,ydb,zdb) end if dedxt = dedphi * (yt*zcb - ycb*zt) / (rt2*rcb) dedyt = dedphi * (zt*xcb - zcb*xt) / (rt2*rcb) dedzt = dedphi * (xt*ycb - xcb*yt) / (rt2*rcb) dedxu = -dedphi * (yu*zcb - ycb*zu) / (ru2*rcb) dedyu = -dedphi * (zu*xcb - zcb*xu) / (ru2*rcb) dedzu = -dedphi * (xu*ycb - xcb*yu) / (ru2*rcb) c c compute first derivative components for this angle c dedxia = zcb*dedyt - ycb*dedzt dedyia = xcb*dedzt - zcb*dedxt dedzia = ycb*dedxt - xcb*dedyt dedxib = yca*dedzt - zca*dedyt + zdc*dedyu - ydc*dedzu dedyib = zca*dedxt - xca*dedzt + xdc*dedzu - zdc*dedxu dedzib = xca*dedyt - yca*dedxt + ydc*dedxu - xdc*dedyu dedxic = zba*dedyt - yba*dedzt + ydb*dedzu - zdb*dedyu dedyic = xba*dedzt - zba*dedxt + zdb*dedxu - xdb*dedzu dedzic = yba*dedxt - xba*dedyt + xdb*dedyu - ydb*dedxu dedxid = zcb*dedyu - ycb*dedzu dedyid = xcb*dedzu - zcb*dedxu dedzid = ycb*dedxu - xcb*dedyu c c increment the improper torsion energy and gradient c eit = eit + e deit(1,ia) = deit(1,ia) + dedxia deit(2,ia) = deit(2,ia) + dedyia deit(3,ia) = deit(3,ia) + dedzia deit(1,ib) = deit(1,ib) + dedxib deit(2,ib) = deit(2,ib) + dedyib deit(3,ib) = deit(3,ib) + dedzib deit(1,ic) = deit(1,ic) + dedxic deit(2,ic) = deit(2,ic) + dedyic deit(3,ic) = deit(3,ic) + dedzic deit(1,id) = deit(1,id) + dedxid deit(2,id) = deit(2,id) + dedyid deit(3,id) = deit(3,id) + dedzid c c increment the internal virial tensor components c vxx = xcb*(dedxic+dedxid) - xba*dedxia + xdc*dedxid vyx = ycb*(dedxic+dedxid) - yba*dedxia + ydc*dedxid vzx = zcb*(dedxic+dedxid) - zba*dedxia + zdc*dedxid vyy = ycb*(dedyic+dedyid) - yba*dedyia + ydc*dedyid vzy = zcb*(dedyic+dedyid) - zba*dedyia + zdc*dedyid vzz = zcb*(dedzic+dedzid) - zba*dedzia + zdc*dedzid 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 OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine eimptor2 -- atomwise impr. torsion Hessian ## c ## ## c ############################################################### c c c "eimptor2" calculates second derivatives of the improper c torsion energy for a single atom c c subroutine eimptor2 (i) use atoms use bound use group use hessn use imptor use torpot implicit none integer i,kitors integer ia,ib,ic,id real*8 eps,rcb,fgrp real*8 dedphi,d2edphi2 real*8 v1,v2,v3 real*8 c1,c2,c3 real*8 s1,s2,s3 real*8 sine,cosine real*8 sine2,cosine2 real*8 sine3,cosine3 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 xca,yca,zca real*8 xdb,ydb,zdb real*8 xt,yt,zt,xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru real*8 dphi1,dphi2,dphi3 real*8 d2phi1,d2phi2,d2phi3 real*8 dphidxt,dphidyt,dphidzt real*8 dphidxu,dphidyu,dphidzu real*8 dphidxia,dphidyia,dphidzia real*8 dphidxib,dphidyib,dphidzib real*8 dphidxic,dphidyic,dphidzic real*8 dphidxid,dphidyid,dphidzid real*8 xycb2,xzcb2,yzcb2 real*8 rcbxt,rcbyt,rcbzt,rcbt2 real*8 rcbxu,rcbyu,rcbzu,rcbu2 real*8 dphidxibt,dphidyibt,dphidzibt real*8 dphidxibu,dphidyibu,dphidzibu real*8 dphidxict,dphidyict,dphidzict real*8 dphidxicu,dphidyicu,dphidzicu real*8 dxiaxia,dyiayia,dziazia real*8 dxibxib,dyibyib,dzibzib real*8 dxicxic,dyicyic,dziczic real*8 dxidxid,dyidyid,dzidzid real*8 dxiayia,dxiazia,dyiazia real*8 dxibyib,dxibzib,dyibzib real*8 dxicyic,dxiczic,dyiczic real*8 dxidyid,dxidzid,dyidzid real*8 dxiaxib,dxiayib,dxiazib real*8 dyiaxib,dyiayib,dyiazib real*8 dziaxib,dziayib,dziazib real*8 dxiaxic,dxiayic,dxiazic real*8 dyiaxic,dyiayic,dyiazic real*8 dziaxic,dziayic,dziazic real*8 dxiaxid,dxiayid,dxiazid real*8 dyiaxid,dyiayid,dyiazid real*8 dziaxid,dziayid,dziazid real*8 dxibxic,dxibyic,dxibzic real*8 dyibxic,dyibyic,dyibzic real*8 dzibxic,dzibyic,dzibzic real*8 dxibxid,dxibyid,dxibzid real*8 dyibxid,dyibyid,dyibzid real*8 dzibxid,dzibyid,dzibzid real*8 dxicxid,dxicyid,dxiczid real*8 dyicxid,dyicyid,dyiczid real*8 dzicxid,dzicyid,dziczid logical proceed c c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c compute Hessian elements for the improper torsional angles c do kitors = 1, nitors ia = iitors(1,kitors) ib = iitors(2,kitors) ic = iitors(3,kitors) id = iitors(4,kitors) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (i.eq.ia .or. i.eq.ib .or. & i.eq.ic .or. i.eq.id) c c compute the value of the torsional angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) c c set the improper torsional parameters for this angle c v1 = itors1(1,kitors) c1 = itors1(3,kitors) s1 = itors1(4,kitors) v2 = itors2(1,kitors) c2 = itors2(3,kitors) s2 = itors2(4,kitors) v3 = itors3(1,kitors) c3 = itors3(3,kitors) s3 = itors3(4,kitors) c c compute the multiple angle trigonometry and the phase terms c cosine2 = cosine*cosine - sine*sine sine2 = 2.0d0 * cosine * sine cosine3 = cosine*cosine2 - sine*sine2 sine3 = cosine*sine2 + sine*cosine2 dphi1 = (cosine*s1 - sine*c1) dphi2 = 2.0d0 * (cosine2*s2 - sine2*c2) dphi3 = 3.0d0 * (cosine3*s3 - sine3*c3) d2phi1 = -(cosine*c1 + sine*s1) d2phi2 = -4.0d0 * (cosine2*c2 + sine2*s2) d2phi3 = -9.0d0 * (cosine3*c3 + sine3*s3) c c calculate the improper torsion master chain rule terms c dedphi = itorunit * (v1*dphi1+v2*dphi2+v3*dphi3) d2edphi2 = itorunit * (v1*d2phi1+v2*d2phi2+v3*d2phi3) c c scale the interaction based on its group membership c if (use_group) then dedphi = dedphi * fgrp d2edphi2 = d2edphi2 * fgrp end if c c abbreviations for first derivative chain rule terms c xca = xic - xia yca = yic - yia zca = zic - zia xdb = xid - xib ydb = yid - yib zdb = zid - zib if (use_polymer) then call image (xca,yca,zca) call image (xdb,ydb,zdb) end if dphidxt = (yt*zcb - ycb*zt) / (rt2*rcb) dphidyt = (zt*xcb - zcb*xt) / (rt2*rcb) dphidzt = (xt*ycb - xcb*yt) / (rt2*rcb) dphidxu = -(yu*zcb - ycb*zu) / (ru2*rcb) dphidyu = -(zu*xcb - zcb*xu) / (ru2*rcb) dphidzu = -(xu*ycb - xcb*yu) / (ru2*rcb) c c abbreviations for second derivative chain rule terms c xycb2 = xcb*xcb + ycb*ycb xzcb2 = xcb*xcb + zcb*zcb yzcb2 = ycb*ycb + zcb*zcb rcbxt = -2.0d0 * rcb * dphidxt rcbyt = -2.0d0 * rcb * dphidyt rcbzt = -2.0d0 * rcb * dphidzt rcbt2 = rcb * rt2 rcbxu = 2.0d0 * rcb * dphidxu rcbyu = 2.0d0 * rcb * dphidyu rcbzu = 2.0d0 * rcb * dphidzu rcbu2 = rcb * ru2 dphidxibt = yca*dphidzt - zca*dphidyt dphidxibu = zdc*dphidyu - ydc*dphidzu dphidyibt = zca*dphidxt - xca*dphidzt dphidyibu = xdc*dphidzu - zdc*dphidxu dphidzibt = xca*dphidyt - yca*dphidxt dphidzibu = ydc*dphidxu - xdc*dphidyu dphidxict = zba*dphidyt - yba*dphidzt dphidxicu = ydb*dphidzu - zdb*dphidyu dphidyict = xba*dphidzt - zba*dphidxt dphidyicu = zdb*dphidxu - xdb*dphidzu dphidzict = yba*dphidxt - xba*dphidyt dphidzicu = xdb*dphidyu - ydb*dphidxu c c chain rule terms for first derivative components c dphidxia = zcb*dphidyt - ycb*dphidzt dphidyia = xcb*dphidzt - zcb*dphidxt dphidzia = ycb*dphidxt - xcb*dphidyt dphidxib = dphidxibt + dphidxibu dphidyib = dphidyibt + dphidyibu dphidzib = dphidzibt + dphidzibu dphidxic = dphidxict + dphidxicu dphidyic = dphidyict + dphidyicu dphidzic = dphidzict + dphidzicu dphidxid = zcb*dphidyu - ycb*dphidzu dphidyid = xcb*dphidzu - zcb*dphidxu dphidzid = ycb*dphidxu - xcb*dphidyu c c chain rule terms for second derivative components c dxiaxia = rcbxt*dphidxia dxiayia = rcbxt*dphidyia - zcb*rcb/rt2 dxiazia = rcbxt*dphidzia + ycb*rcb/rt2 dxiaxic = rcbxt*dphidxict + xcb*xt/rcbt2 dxiayic = rcbxt*dphidyict - dphidzt & - (xba*zcb*xcb+zba*yzcb2)/rcbt2 dxiazic = rcbxt*dphidzict + dphidyt & + (xba*ycb*xcb+yba*yzcb2)/rcbt2 dxiaxid = 0.0d0 dxiayid = 0.0d0 dxiazid = 0.0d0 dyiayia = rcbyt*dphidyia dyiazia = rcbyt*dphidzia - xcb*rcb/rt2 dyiaxib = rcbyt*dphidxibt - dphidzt & - (yca*zcb*ycb+zca*xzcb2)/rcbt2 dyiaxic = rcbyt*dphidxict + dphidzt & + (yba*zcb*ycb+zba*xzcb2)/rcbt2 dyiayic = rcbyt*dphidyict + ycb*yt/rcbt2 dyiazic = rcbyt*dphidzict - dphidxt & - (yba*xcb*ycb+xba*xzcb2)/rcbt2 dyiaxid = 0.0d0 dyiayid = 0.0d0 dyiazid = 0.0d0 dziazia = rcbzt*dphidzia dziaxib = rcbzt*dphidxibt + dphidyt & + (zca*ycb*zcb+yca*xycb2)/rcbt2 dziayib = rcbzt*dphidyibt - dphidxt & - (zca*xcb*zcb+xca*xycb2)/rcbt2 dziaxic = rcbzt*dphidxict - dphidyt & - (zba*ycb*zcb+yba*xycb2)/rcbt2 dziayic = rcbzt*dphidyict + dphidxt & + (zba*xcb*zcb+xba*xycb2)/rcbt2 dziazic = rcbzt*dphidzict + zcb*zt/rcbt2 dziaxid = 0.0d0 dziayid = 0.0d0 dziazid = 0.0d0 dxibxic = -xcb*dphidxib/(rcb*rcb) & - (yca*(zba*xcb+yt)-zca*(yba*xcb-zt))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidxibt/rt2 & - (zdc*(ydb*xcb+zu)-ydc*(zdb*xcb-yu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidxibu/ru2 dxibyic = -ycb*dphidxib/(rcb*rcb) + dphidzt + dphidzu & - (yca*(zba*ycb-xt)+zca*(xba*xcb+zcb*zba))/rcbt2 & - 2.0d0*(zt*xba-zba*xt)*dphidxibt/rt2 & + (zdc*(xdb*xcb+zcb*zdb)+ydc*(zdb*ycb+xu))/rcbu2 & + 2.0d0*(zu*xdb-zdb*xu)*dphidxibu/ru2 dxibxid = rcbxu*dphidxibu + xcb*xu/rcbu2 dxibyid = rcbyu*dphidxibu - dphidzu & - (ydc*zcb*ycb+zdc*xzcb2)/rcbu2 dxibzid = rcbzu*dphidxibu + dphidyu & + (zdc*ycb*zcb+ydc*xycb2)/rcbu2 dyibzib = ycb*dphidzib/(rcb*rcb) & - (xca*(xca*xcb+zcb*zca)+yca*(ycb*xca+zt))/rcbt2 & - 2.0d0*(xt*zca-xca*zt)*dphidzibt/rt2 & + (ydc*(xdc*ycb-zu)+xdc*(xdc*xcb+zcb*zdc))/rcbu2 & + 2.0d0*(xu*zdc-xdc*zu)*dphidzibu/ru2 dyibxic = -xcb*dphidyib/(rcb*rcb) - dphidzt - dphidzu & + (xca*(zba*xcb+yt)+zca*(zba*zcb+ycb*yba))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidyibt/rt2 & - (zdc*(zdb*zcb+ycb*ydb)+xdc*(zdb*xcb-yu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidyibu/ru2 dyibyic = -ycb*dphidyib/(rcb*rcb) & - (zca*(xba*ycb+zt)-xca*(zba*ycb-xt))/rcbt2 & - 2.0d0*(zt*xba-zba*xt)*dphidyibt/rt2 & - (xdc*(zdb*ycb+xu)-zdc*(xdb*ycb-zu))/rcbu2 & + 2.0d0*(zu*xdb-zdb*xu)*dphidyibu/ru2 dyibxid = rcbxu*dphidyibu + dphidzu & + (xdc*zcb*xcb+zdc*yzcb2)/rcbu2 dyibyid = rcbyu*dphidyibu + ycb*yu/rcbu2 dyibzid = rcbzu*dphidyibu - dphidxu & - (zdc*xcb*zcb+xdc*xycb2)/rcbu2 dzibxic = -xcb*dphidzib/(rcb*rcb) + dphidyt + dphidyu & - (xca*(yba*xcb-zt)+yca*(zba*zcb+ycb*yba))/rcbt2 & - 2.0d0*(yt*zba-yba*zt)*dphidzibt/rt2 & + (ydc*(zdb*zcb+ycb*ydb)+xdc*(ydb*xcb+zu))/rcbu2 & + 2.0d0*(yu*zdb-ydb*zu)*dphidzibu/ru2 dzibzic = -zcb*dphidzib/(rcb*rcb) & - (xca*(yba*zcb+xt)-yca*(xba*zcb-yt))/rcbt2 & - 2.0d0*(xt*yba-xba*yt)*dphidzibt/rt2 & - (ydc*(xdb*zcb+yu)-xdc*(ydb*zcb-xu))/rcbu2 & + 2.0d0*(xu*ydb-xdb*yu)*dphidzibu/ru2 dzibxid = rcbxu*dphidzibu - dphidyu & - (xdc*ycb*xcb+ydc*yzcb2)/rcbu2 dzibyid = rcbyu*dphidzibu + dphidxu & + (ydc*xcb*ycb+xdc*xzcb2)/rcbu2 dzibzid = rcbzu*dphidzibu + zcb*zu/rcbu2 dxicxid = rcbxu*dphidxicu - xcb*(zdb*ycb-ydb*zcb)/rcbu2 dxicyid = rcbyu*dphidxicu + dphidzu & + (ydb*zcb*ycb+zdb*xzcb2)/rcbu2 dxiczid = rcbzu*dphidxicu - dphidyu & - (zdb*ycb*zcb+ydb*xycb2)/rcbu2 dyicxid = rcbxu*dphidyicu - dphidzu & - (xdb*zcb*xcb+zdb*yzcb2)/rcbu2 dyicyid = rcbyu*dphidyicu - ycb*(xdb*zcb-zdb*xcb)/rcbu2 dyiczid = rcbzu*dphidyicu + dphidxu & + (zdb*xcb*zcb+xdb*xycb2)/rcbu2 dzicxid = rcbxu*dphidzicu + dphidyu & + (xdb*ycb*xcb+ydb*yzcb2)/rcbu2 dzicyid = rcbyu*dphidzicu - dphidxu & - (ydb*xcb*ycb+xdb*xzcb2)/rcbu2 dziczid = rcbzu*dphidzicu - zcb*(ydb*xcb-xdb*ycb)/rcbu2 dxidxid = rcbxu*dphidxid dxidyid = rcbxu*dphidyid + zcb*rcb/ru2 dxidzid = rcbxu*dphidzid - ycb*rcb/ru2 dyidyid = rcbyu*dphidyid dyidzid = rcbyu*dphidzid + xcb*rcb/ru2 dzidzid = rcbzu*dphidzid c c get some second derivative chain rule terms by difference c dxiaxib = -dxiaxia - dxiaxic - dxiaxid dxiayib = -dxiayia - dxiayic - dxiayid dxiazib = -dxiazia - dxiazic - dxiazid dyiayib = -dyiayia - dyiayic - dyiayid dyiazib = -dyiazia - dyiazic - dyiazid dziazib = -dziazia - dziazic - dziazid dxibxib = -dxiaxib - dxibxic - dxibxid dxibyib = -dyiaxib - dxibyic - dxibyid dxibzib = -dxiazib - dzibxic - dzibxid dxibzic = -dziaxib - dxibzib - dxibzid dyibyib = -dyiayib - dyibyic - dyibyid dyibzic = -dziayib - dyibzib - dyibzid dzibzib = -dziazib - dzibzic - dzibzid dzibyic = -dyiazib - dyibzib - dzibyid dxicxic = -dxiaxic - dxibxic - dxicxid dxicyic = -dyiaxic - dyibxic - dxicyid dxiczic = -dziaxic - dzibxic - dxiczid dyicyic = -dyiayic - dyibyic - dyicyid dyiczic = -dziayic - dzibyic - dyiczid dziczic = -dziazic - dzibzic - dziczid c c increment diagonal and off-diagonal Hessian elements c if (i .eq. ia) then hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxia & + d2edphi2*dphidxia*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayia & + d2edphi2*dphidxia*dphidyia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazia & + d2edphi2*dphidxia*dphidzia hessx(2,ia) = hessx(2,ia) + dedphi*dxiayia & + d2edphi2*dphidxia*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayia & + d2edphi2*dphidyia*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazia & + d2edphi2*dphidyia*dphidzia hessx(3,ia) = hessx(3,ia) + dedphi*dxiazia & + d2edphi2*dphidxia*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dyiazia & + d2edphi2*dphidyia*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazia & + d2edphi2*dphidzia*dphidzia hessx(1,ib) = hessx(1,ib) + dedphi*dxiaxib & + d2edphi2*dphidxia*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dyiaxib & + d2edphi2*dphidyia*dphidxib hessz(1,ib) = hessz(1,ib) + dedphi*dziaxib & + d2edphi2*dphidzia*dphidxib hessx(2,ib) = hessx(2,ib) + dedphi*dxiayib & + d2edphi2*dphidxia*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyiayib & + d2edphi2*dphidyia*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dziayib & + d2edphi2*dphidzia*dphidyib hessx(3,ib) = hessx(3,ib) + dedphi*dxiazib & + d2edphi2*dphidxia*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dyiazib & + d2edphi2*dphidyia*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dziazib & + d2edphi2*dphidzia*dphidzib hessx(1,ic) = hessx(1,ic) + dedphi*dxiaxic & + d2edphi2*dphidxia*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dyiaxic & + d2edphi2*dphidyia*dphidxic hessz(1,ic) = hessz(1,ic) + dedphi*dziaxic & + d2edphi2*dphidzia*dphidxic hessx(2,ic) = hessx(2,ic) + dedphi*dxiayic & + d2edphi2*dphidxia*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyiayic & + d2edphi2*dphidyia*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dziayic & + d2edphi2*dphidzia*dphidyic hessx(3,ic) = hessx(3,ic) + dedphi*dxiazic & + d2edphi2*dphidxia*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dyiazic & + d2edphi2*dphidyia*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dziazic & + d2edphi2*dphidzia*dphidzic hessx(1,id) = hessx(1,id) + dedphi*dxiaxid & + d2edphi2*dphidxia*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dyiaxid & + d2edphi2*dphidyia*dphidxid hessz(1,id) = hessz(1,id) + dedphi*dziaxid & + d2edphi2*dphidzia*dphidxid hessx(2,id) = hessx(2,id) + dedphi*dxiayid & + d2edphi2*dphidxia*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyiayid & + d2edphi2*dphidyia*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dziayid & + d2edphi2*dphidzia*dphidyid hessx(3,id) = hessx(3,id) + dedphi*dxiazid & + d2edphi2*dphidxia*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyiazid & + d2edphi2*dphidyia*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dziazid & + d2edphi2*dphidzia*dphidzid else if (i .eq. ib) then hessx(1,ib) = hessx(1,ib) + dedphi*dxibxib & + d2edphi2*dphidxib*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyib & + d2edphi2*dphidxib*dphidyib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzib & + d2edphi2*dphidxib*dphidzib hessx(2,ib) = hessx(2,ib) + dedphi*dxibyib & + d2edphi2*dphidxib*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyib & + d2edphi2*dphidyib*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzib & + d2edphi2*dphidyib*dphidzib hessx(3,ib) = hessx(3,ib) + dedphi*dxibzib & + d2edphi2*dphidxib*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dyibzib & + d2edphi2*dphidyib*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzib & + d2edphi2*dphidzib*dphidzib hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxib & + d2edphi2*dphidxib*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayib & + d2edphi2*dphidyib*dphidxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazib & + d2edphi2*dphidzib*dphidxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxib & + d2edphi2*dphidxib*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayib & + d2edphi2*dphidyib*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazib & + d2edphi2*dphidzib*dphidyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxib & + d2edphi2*dphidxib*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayib & + d2edphi2*dphidyib*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazib & + d2edphi2*dphidzib*dphidzia hessx(1,ic) = hessx(1,ic) + dedphi*dxibxic & + d2edphi2*dphidxib*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dyibxic & + d2edphi2*dphidyib*dphidxic hessz(1,ic) = hessz(1,ic) + dedphi*dzibxic & + d2edphi2*dphidzib*dphidxic hessx(2,ic) = hessx(2,ic) + dedphi*dxibyic & + d2edphi2*dphidxib*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyibyic & + d2edphi2*dphidyib*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dzibyic & + d2edphi2*dphidzib*dphidyic hessx(3,ic) = hessx(3,ic) + dedphi*dxibzic & + d2edphi2*dphidxib*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dyibzic & + d2edphi2*dphidyib*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dzibzic & + d2edphi2*dphidzib*dphidzic hessx(1,id) = hessx(1,id) + dedphi*dxibxid & + d2edphi2*dphidxib*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dyibxid & + d2edphi2*dphidyib*dphidxid hessz(1,id) = hessz(1,id) + dedphi*dzibxid & + d2edphi2*dphidzib*dphidxid hessx(2,id) = hessx(2,id) + dedphi*dxibyid & + d2edphi2*dphidxib*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyibyid & + d2edphi2*dphidyib*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dzibyid & + d2edphi2*dphidzib*dphidyid hessx(3,id) = hessx(3,id) + dedphi*dxibzid & + d2edphi2*dphidxib*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyibzid & + d2edphi2*dphidyib*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dzibzid & + d2edphi2*dphidzib*dphidzid else if (i .eq. ic) then hessx(1,ic) = hessx(1,ic) + dedphi*dxicxic & + d2edphi2*dphidxic*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dxicyic & + d2edphi2*dphidxic*dphidyic hessz(1,ic) = hessz(1,ic) + dedphi*dxiczic & + d2edphi2*dphidxic*dphidzic hessx(2,ic) = hessx(2,ic) + dedphi*dxicyic & + d2edphi2*dphidxic*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyicyic & + d2edphi2*dphidyic*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dyiczic & + d2edphi2*dphidyic*dphidzic hessx(3,ic) = hessx(3,ic) + dedphi*dxiczic & + d2edphi2*dphidxic*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dyiczic & + d2edphi2*dphidyic*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dziczic & + d2edphi2*dphidzic*dphidzic hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxic & + d2edphi2*dphidxic*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayic & + d2edphi2*dphidyic*dphidxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazic & + d2edphi2*dphidzic*dphidxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxic & + d2edphi2*dphidxic*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayic & + d2edphi2*dphidyic*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazic & + d2edphi2*dphidzic*dphidyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxic & + d2edphi2*dphidxic*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayic & + d2edphi2*dphidyic*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazic & + d2edphi2*dphidzic*dphidzia hessx(1,ib) = hessx(1,ib) + dedphi*dxibxic & + d2edphi2*dphidxic*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyic & + d2edphi2*dphidyic*dphidxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzic & + d2edphi2*dphidzic*dphidxib hessx(2,ib) = hessx(2,ib) + dedphi*dyibxic & + d2edphi2*dphidxic*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyic & + d2edphi2*dphidyic*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzic & + d2edphi2*dphidzic*dphidyib hessx(3,ib) = hessx(3,ib) + dedphi*dzibxic & + d2edphi2*dphidxic*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dzibyic & + d2edphi2*dphidyic*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzic & + d2edphi2*dphidzic*dphidzib hessx(1,id) = hessx(1,id) + dedphi*dxicxid & + d2edphi2*dphidxic*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dyicxid & + d2edphi2*dphidyic*dphidxid hessz(1,id) = hessz(1,id) + dedphi*dzicxid & + d2edphi2*dphidzic*dphidxid hessx(2,id) = hessx(2,id) + dedphi*dxicyid & + d2edphi2*dphidxic*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyicyid & + d2edphi2*dphidyic*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dzicyid & + d2edphi2*dphidzic*dphidyid hessx(3,id) = hessx(3,id) + dedphi*dxiczid & + d2edphi2*dphidxic*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyiczid & + d2edphi2*dphidyic*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dziczid & + d2edphi2*dphidzic*dphidzid else if (i .eq. id) then hessx(1,id) = hessx(1,id) + dedphi*dxidxid & + d2edphi2*dphidxid*dphidxid hessy(1,id) = hessy(1,id) + dedphi*dxidyid & + d2edphi2*dphidxid*dphidyid hessz(1,id) = hessz(1,id) + dedphi*dxidzid & + d2edphi2*dphidxid*dphidzid hessx(2,id) = hessx(2,id) + dedphi*dxidyid & + d2edphi2*dphidxid*dphidyid hessy(2,id) = hessy(2,id) + dedphi*dyidyid & + d2edphi2*dphidyid*dphidyid hessz(2,id) = hessz(2,id) + dedphi*dyidzid & + d2edphi2*dphidyid*dphidzid hessx(3,id) = hessx(3,id) + dedphi*dxidzid & + d2edphi2*dphidxid*dphidzid hessy(3,id) = hessy(3,id) + dedphi*dyidzid & + d2edphi2*dphidyid*dphidzid hessz(3,id) = hessz(3,id) + dedphi*dzidzid & + d2edphi2*dphidzid*dphidzid hessx(1,ia) = hessx(1,ia) + dedphi*dxiaxid & + d2edphi2*dphidxid*dphidxia hessy(1,ia) = hessy(1,ia) + dedphi*dxiayid & + d2edphi2*dphidyid*dphidxia hessz(1,ia) = hessz(1,ia) + dedphi*dxiazid & + d2edphi2*dphidzid*dphidxia hessx(2,ia) = hessx(2,ia) + dedphi*dyiaxid & + d2edphi2*dphidxid*dphidyia hessy(2,ia) = hessy(2,ia) + dedphi*dyiayid & + d2edphi2*dphidyid*dphidyia hessz(2,ia) = hessz(2,ia) + dedphi*dyiazid & + d2edphi2*dphidzid*dphidyia hessx(3,ia) = hessx(3,ia) + dedphi*dziaxid & + d2edphi2*dphidxid*dphidzia hessy(3,ia) = hessy(3,ia) + dedphi*dziayid & + d2edphi2*dphidyid*dphidzia hessz(3,ia) = hessz(3,ia) + dedphi*dziazid & + d2edphi2*dphidzid*dphidzia hessx(1,ib) = hessx(1,ib) + dedphi*dxibxid & + d2edphi2*dphidxid*dphidxib hessy(1,ib) = hessy(1,ib) + dedphi*dxibyid & + d2edphi2*dphidyid*dphidxib hessz(1,ib) = hessz(1,ib) + dedphi*dxibzid & + d2edphi2*dphidzid*dphidxib hessx(2,ib) = hessx(2,ib) + dedphi*dyibxid & + d2edphi2*dphidxid*dphidyib hessy(2,ib) = hessy(2,ib) + dedphi*dyibyid & + d2edphi2*dphidyid*dphidyib hessz(2,ib) = hessz(2,ib) + dedphi*dyibzid & + d2edphi2*dphidzid*dphidyib hessx(3,ib) = hessx(3,ib) + dedphi*dzibxid & + d2edphi2*dphidxid*dphidzib hessy(3,ib) = hessy(3,ib) + dedphi*dzibyid & + d2edphi2*dphidyid*dphidzib hessz(3,ib) = hessz(3,ib) + dedphi*dzibzid & + d2edphi2*dphidzid*dphidzib hessx(1,ic) = hessx(1,ic) + dedphi*dxicxid & + d2edphi2*dphidxid*dphidxic hessy(1,ic) = hessy(1,ic) + dedphi*dxicyid & + d2edphi2*dphidyid*dphidxic hessz(1,ic) = hessz(1,ic) + dedphi*dxiczid & + d2edphi2*dphidzid*dphidxic hessx(2,ic) = hessx(2,ic) + dedphi*dyicxid & + d2edphi2*dphidxid*dphidyic hessy(2,ic) = hessy(2,ic) + dedphi*dyicyid & + d2edphi2*dphidyid*dphidyic hessz(2,ic) = hessz(2,ic) + dedphi*dyiczid & + d2edphi2*dphidzid*dphidyic hessx(3,ic) = hessx(3,ic) + dedphi*dzicxid & + d2edphi2*dphidxid*dphidzic hessy(3,ic) = hessy(3,ic) + dedphi*dzicyid & + d2edphi2*dphidyid*dphidzic hessz(3,ic) = hessz(3,ic) + dedphi*dziczid & + d2edphi2*dphidzid*dphidzic end if end if end do return end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine eimptor3 -- impr. torsion energy & analysis ## c ## ## c ################################################################ c c c "eimptor3" calculates the improper torsion potential energy; c also partitions the energy terms among the atoms c c subroutine eimptor3 use action use analyz use atomid use atoms use bound use energi use group use imptor use inform use iounit use math use torpot use usage implicit none integer i,ia,ib,ic,id real*8 e,eps,rcb real*8 angle,fgrp real*8 xt,yt,zt real*8 xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru real*8 v1,v2,v3 real*8 c1,c2,c3 real*8 s1,s2,s3 real*8 sine,cosine real*8 sine2,cosine2 real*8 sine3,cosine3 real*8 phi1,phi2,phi3 real*8 xia,yia,zia real*8 xib,yib,zib real*8 xic,yic,zic real*8 xid,yid,zid real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc logical proceed logical header,huge c c c zero out the torsional energy and partitioning terms c neit = 0 eit = 0.0d0 do i = 1, n aeit(i) = 0.0d0 end do if (nitors .eq. 0) return c c set tolerance for minimum distance and angle values c eps = 0.0001d0 c c print header information if debug output was requested c header = .true. if (debug .and. nitors.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual Improper Torsion Interactions :', & //,' Type',25x,'Atom Names',21x,'Angle', & 6x,'Energy',/) end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nitors,iitors,use,x,y,z, !$OMP& itors1,itors2,itors3,itorunit,eps,use_group,use_polymer, !$OMP& name,verbose,debug,header,iout) !$OMP& shared(eit,neit,aeit) !$OMP DO reduction(+:eit,neit,aeit) schedule(guided) c c calculate the improper torsional angle energy term c do i = 1, nitors ia = iitors(1,i) ib = iitors(2,i) ic = iitors(3,i) id = iitors(4,i) c c decide whether to compute the current interaction c proceed = .true. if (use_group) call groups (proceed,fgrp,ia,ib,ic,id,0,0) if (proceed) proceed = (use(ia) .or. use(ib) .or. & use(ic) .or. use(id)) c c compute the value of the torsional angle c if (proceed) then xia = x(ia) yia = y(ia) zia = z(ia) xib = x(ib) yib = y(ib) zib = z(ib) xic = x(ic) yic = y(ic) zic = z(ic) xid = x(id) yid = y(id) zid = z(id) xba = xib - xia yba = yib - yia zba = zib - zia xcb = xic - xib ycb = yic - yib zcb = zic - zib xdc = xid - xic ydc = yid - yic zdc = zid - zic if (use_polymer) then call image (xba,yba,zba) call image (xcb,ycb,zcb) call image (xdc,ydc,zdc) end if rcb = sqrt(max(xcb*xcb+ycb*ycb+zcb*zcb,eps)) xt = yba*zcb - ycb*zba yt = zba*xcb - zcb*xba zt = xba*ycb - xcb*yba xu = ycb*zdc - ydc*zcb yu = zcb*xdc - zdc*xcb zu = xcb*ydc - xdc*ycb xtu = yt*zu - yu*zt ytu = zt*xu - zu*xt ztu = xt*yu - xu*yt rt2 = max(xt*xt+yt*yt+zt*zt,eps) ru2 = max(xu*xu+yu*yu+zu*zu,eps) rtru = sqrt(rt2 * ru2) cosine = (xt*xu + yt*yu + zt*zu) / rtru sine = (xcb*xtu + ycb*ytu + zcb*ztu) / (rcb*rtru) cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) if (sine .lt. 0.0d0) angle = -angle c c set the improper torsional parameters for this angle c v1 = itors1(1,i) c1 = itors1(3,i) s1 = itors1(4,i) v2 = itors2(1,i) c2 = itors2(3,i) s2 = itors2(4,i) v3 = itors3(1,i) c3 = itors3(3,i) s3 = itors3(4,i) c c compute the multiple angle trigonometry and the phase terms c cosine2 = cosine*cosine - sine*sine sine2 = 2.0d0 * cosine * sine cosine3 = cosine*cosine2 - sine*sine2 sine3 = cosine*sine2 + sine*cosine2 phi1 = 1.0d0 + (cosine*c1 + sine*s1) phi2 = 1.0d0 + (cosine2*c2 + sine2*s2) phi3 = 1.0d0 + (cosine3*c3 + sine3*s3) c c calculate the improper torsional energy for this angle c e = itorunit * (v1*phi1 + v2*phi2 + v3*phi3) c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the total torsional angle energy c neit = neit + 1 eit = eit + e aeit(ib) = aeit(ib) + 0.5d0*e aeit(ic) = aeit(ic) + 0.5d0*e c c print a message if the energy of this interaction is large c huge = (e .gt. 5.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual Improper Torsion', & ' Interactions :', & //,' Type',25x,'Atom Names',21x,'Angle', & 6x,'Energy',/) end if write (iout,30) ia,name(ia),ib,name(ib),ic, & name(ic),id,name(id),angle,e 30 format (' Improper',2x,4(i7,'-',a3),f11.4,f12.4) end if end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine elj -- Lennard-Jones van der Waals energy ## c ## ## c ############################################################## c c c "elj" calculates the Lennard-Jones 6-12 van der Waals energy c c subroutine elj use energi use limits use vdwpot use warp implicit none real*8 elrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_stophat) then call elj0e else if (use_smooth) then call elj0d else if (use_vlist) then call elj0c else if (use_lights) then call elj0b else call elj0a end if c c apply the long range van der Waals correction if used c if (use_vcorr) then mode = 'VDW' call evcorr (mode,elrc) ev = ev + elrc end if return end c c c ################################################################## c ## ## c ## subroutine elj0a -- double loop Lennard-Jones vdw energy ## c ## ## c ################################################################## c c c "elj0a" calculates the Lennard-Jones 6-12 van der Waals energy c using a pairwise double loop c c subroutine elj0a use atomid use atoms use bound use cell use couple use energi use group use mutant use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,p6,p12 real*8 eps,sc,term real*8 rv,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8, allocatable :: vscale(:) logical proceed,usei logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy component c ev = ev + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,j) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy component; c interaction of an atom with its own image counts half c if (i .eq. k) e = 0.5d0 * e ev = ev + e end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################# c ## ## c ## subroutine elj0b -- Lennard-Jones vdw energy via lights ## c ## ## c ################################################################# c c c "elj0b" calculates the Lennard-Jones 6-12 van der Waals energy c using the method of lights c c subroutine elj0b use atomid use atoms use bound use boxes use cell use couple use energi use group use light use mutant use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer, allocatable :: iv14(:) real*8 e,p6,p12 real*8 eps,sc,term real*8 rv,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) mutk = mut(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy component c ev = ev + e end if end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################### c ## ## c ## subroutine elj0c -- Lennard-Jones vdw energy via list ## c ## ## c ############################################################### c c c "elj0c" calculates the Lennard-Jones 6-12 van der Waals energy c using a pairwise neighbor list c c subroutine elj0c use atomid use atoms use bound use couple use energi use group use mutant use neigh use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,p6,p12 real*8 eps,sc,term real*8 rv,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8, allocatable :: vscale(:) logical proceed,usei logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired, !$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13, !$OMP& i14,i15,v2scale,v3scale,v4scale,v5scale,use_group,off2, !$OMP& radmin,epsilon,radmin4,epsilon4,vcouple,vlambda,mut, !$OMP& cut2,c0,c1,c2,c3,c4,c5) firstprivate(vscale,iv14) !$OMP& shared(ev) !$OMP DO reduction(+:ev) schedule(guided) c c find the van der Waals energy via neighbor list search c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################ c ## ## c ## subroutine elj0d -- Lennard-Jones energy for smoothing ## c ## ## c ################################################################ c c c "elj0d" calculates the Lennard-Jones 6-12 van der Waals energy c via a Gaussian approximation for potential energy smoothing c c subroutine elj0d use math use vdwpot implicit none c c c set coefficients for a two-Gaussian fit to Lennard-Jones c ngauss = 2 igauss(1,1) = 14487.1d0 igauss(2,1) = 9.05148d0 * twosix**2 igauss(1,2) = -5.55338d0 igauss(2,2) = 1.22536d0 * twosix**2 c c compute Gaussian approximation to Lennard-Jones potential c call egauss return end c c c ############################################################## c ## ## c ## subroutine elj0e -- Lennard-Jones energy for stophat ## c ## ## c ############################################################## c c c "elj0e" calculates the Lennard-Jones 6-12 van der Waals energy c for use with stophat potential energy smoothing c c subroutine elj0e use atomid use atoms use couple use energi use group use usage use vdw use vdwpot use warp implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,rik2,rdn,p6 real*8 eps,rv,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik3,rik4 real*8 rik5,rik6 real*8 width,width2 real*8 width3,width4 real*8 width5,width6 real*8, allocatable :: vscale(:) logical proceed,usei c c c zero out the van der Waals energy contribution c ev = 0.0d0 if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the extent of smoothing to be performed c width = deform * diffv width2 = width * width width3 = width2 * width width4 = width2 * width2 width5 = width2 * width3 width6 = width3 * width3 c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) rik2 = xr*xr + yr*yr + zr*zr eps = epsilon(kt,it) rv = radmin(kt,it) if (iv14(k) .eq. i) then eps = epsilon4(kt,it) rv = radmin4(kt,it) end if eps = eps * vscale(k) p6 = rv**6 rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 rik6 = rik3 * rik3 c c transform the potential function via smoothing c e = rik6 * (30.0d0*rik6 + 360.0d0*rik5*width & + 1800.0d0*rik4*width2 + 4800.0d0*rik3*width3 & + 7200.0d0*rik2*width4 + 5760.0d0*rik*width5 & + 1920.0d0*width6) e = -e + p6 * (15.0d0*rik6 + 90.0d0*rik5*width & + 288.0d0*rik4*width2 + 552.0d0*rik3*width3 & + 648.0d0*rik2*width4 + 432.0d0*rik*width5 & + 128.0d0*width6) e = e*eps*p6 / (15.0d0*(rik*(rik+2.0d0*width))**9) c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c ev = ev + e end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine elj1 -- Lennard-Jones energy & derivatives ## c ## ## c ############################################################### c c c "elj1" calculates the Lennard-Jones 6-12 van der Waals energy c and its first derivatives with respect to Cartesian coordinates c c subroutine elj1 use energi use limits use vdwpot use virial use warp implicit none real*8 elrc,vlrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_stophat) then call elj1e else if (use_smooth) then call elj1d else if (use_vlist) then call elj1c else if (use_lights) then call elj1b else call elj1a end if c c apply the long range van der Waals correction if used c if (use_vcorr) then mode = 'VDW' call evcorr1 (mode,elrc,vlrc) ev = ev + elrc vir(1,1) = vir(1,1) + vlrc vir(2,2) = vir(2,2) + vlrc vir(3,3) = vir(3,3) + vlrc end if return end c c c ################################################################## c ## ## c ## subroutine elj1a -- double loop Lennard-Jones vdw derivs ## c ## ## c ################################################################## c c c "elj1a" calculates the Lennard-Jones 6-12 van der Waals energy c and its first derivatives using a pairwise double loop c c subroutine elj1a use atomid use atoms use bound use cell use couple use deriv use energi use group use mutant use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,de,p6,p12 real*8 eps,sc real*8 term,dterm real*8 rv,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 taper,dtaper real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: vscale(:) logical proceed,usei logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find van der Waals energy and derivatives via double loop c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) rik = sqrt(rik2) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) dterm = -6.0d0 * p6 * term / rik de = dterm * (1.0d0+2.0d0*(1.0d0-sc)/sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) de = eps * (p12-p6) * (-12.0d0/rik) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,j) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if rik = sqrt(rik2) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) dterm = -6.0d0 * p6 * term / rik de = dterm * (1.0d0+2.0d0*(1.0d0-sc)/sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) de = eps * (p12-p6) * (-12.0d0/rik) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c if (i .eq. k) e = 0.5d0 * e ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (i .ne. k) then if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################# c ## ## c ## subroutine elj1b -- Lennard-Jones vdw derivs via lights ## c ## ## c ################################################################# c c c "elj1b" calculates the Lennard-Jones 6-12 van der Waals energy c and its first derivatives using the method of lights c c subroutine elj1b use atomid use atoms use bound use boxes use cell use couple use deriv use energi use group use light use mutant use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer, allocatable :: iv14(:) real*8 e,de,p6,p12 real*8 eps,sc real*8 term,dterm real*8 rv,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 taper,dtaper real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 20 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 20 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 20 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 20 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) mutk = mut(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if rik = sqrt(rik2) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) dterm = -6.0d0 * p6 * term / rik de = dterm * (1.0d0+2.0d0*(1.0d0-sc)/sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) de = eps * (p12-p6) * (-12.0d0/rik) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 10 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################### c ## ## c ## subroutine elj1c -- Lennard-Jones vdw derivs via list ## c ## ## c ############################################################### c c c "elj1c" calculates the Lennard-Jones 12-6 van der Waals energy c and its first derivatives using a pairwise neighbor list c c subroutine elj1c use atomid use atoms use bound use couple use deriv use energi use group use mutant use neigh use shunt use usage use vdw use vdwpot use virial implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,de,p6,p12 real*8 eps,sc real*8 term,dterm real*8 rv,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 taper,dtaper real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy real*8, allocatable :: vscale(:) logical proceed,usei logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired,kred, !$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,i14, !$OMP& i15,v2scale,v3scale,v4scale,v5scale,use_group,off2,radmin, !$OMP& epsilon,radmin4,epsilon4,vcouple,vlambda,mut,cut2,c0,c1, !$OMP& c2,c3,c4,c5) firstprivate(vscale,iv14) !$OMP& shared(ev,dev,vir) !$OMP DO reduction(+:ev,dev,vir) schedule(guided) c c find van der Waals energy and derivatives via neighbor list c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) rik = sqrt(rik2) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) dterm = -6.0d0 * p6 * term / rik de = dterm * (1.0d0+2.0d0*(1.0d0-sc)/sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) de = eps * (p12-p6) * (-12.0d0/rik) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 de = e*dtaper + de*taper e = e * taper end if c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if c c increment the internal virial tensor components c vxx = xr * dedx vyx = yr * dedx vzx = zr * dedx vyy = yr * dedy vzy = zr * dedy vzz = zr * dedz 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 if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################ c ## ## c ## subroutine elj1d -- Lennard-Jones derivs for smoothing ## c ## ## c ################################################################ c c c "elj1d" calculates the Lennard-Jones 6-12 van der Waals energy c and its first derivatives via a Gaussian approximation for c potential energy smoothing c c subroutine elj1d use math use vdwpot implicit none c c c set coefficients for a two-Gaussian fit to Lennard-Jones c ngauss = 2 igauss(1,1) = 14487.1d0 igauss(2,1) = 9.05148d0 * twosix**2 igauss(1,2) = -5.55338d0 igauss(2,2) = 1.22536d0 * twosix**2 c c compute Gaussian approximation to Lennard-Jones potential c call egauss1 return end c c c ############################################################## c ## ## c ## subroutine elj1e -- Lennard-Jones derivs for stophat ## c ## ## c ############################################################## c c c "elj1e" calculates the van der Waals interaction energy and its c first derivatives for use with stophat potential energy smoothing c c subroutine elj1e use atomid use atoms use couple use deriv use energi use group use usage use vdw use vdwpot use warp implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,de,rdn real*8 p6,denom real*8 eps,rv,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 dedx,dedy,dedz real*8 rik,rik2 real*8 rik3,rik4 real*8 rik5,rik6 real*8 rik7,rik8 real*8 width,width2 real*8 width3,width4 real*8 width5,width6 real*8 width7 real*8, allocatable :: vscale(:) logical proceed,usei c c c zero out the van der Waals energy and first derivatives c ev = 0.0d0 do i = 1, n dev(1,i) = 0.0d0 dev(2,i) = 0.0d0 dev(3,i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n vscale(i) = 1.0d0 iv14(i) = 0 end do c c set the extent of smoothing to be performed c width = deform * diffv width2 = width * width width3 = width2 * width width4 = width2 * width2 width5 = width2 * width3 width6 = width3 * width3 width7 = width3 * width4 c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find van der Waals energy and derivatives via double loop c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) redi = kred(i) rediv = 1.0d0 - redi xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) rik2 = xr*xr + yr*yr + zr*zr eps = epsilon(kt,it) rv = radmin(kt,it) if (iv14(k) .eq. i) then eps = epsilon4(kt,it) rv = radmin4(kt,it) end if eps = eps * vscale(k) p6 = rv**6 rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 rik6 = rik3 * rik3 rik7 = rik3 * rik4 rik8 = rik4 * rik4 denom = rik*(rik+2.0d0*width) denom = denom**9 c c transform the potential function via smoothing c e = rik5 * (30.0d0*rik7 + 360.0d0*rik6*width & + 1800.0d0*rik5*width2 + 4800.0d0*rik4*width3 & + 7200.0d0*rik3*width4 + 5760.0d0*rik2*width5 & + 1920.0d0*rik*width6) e = -e + p6 * (15.0d0*rik6 + 90.0d0*rik5*width & + 288.0d0*rik4*width2 + 552.0d0*rik3*width3 & + 648.0d0*rik2*width4 + 432.0d0*rik*width5 & + 128.0d0*width6) e = e*eps*p6 / (15.0d0*denom) de = rik5 * (5.0d0*rik8 + 65.0d0*rik7*width & + 360.0d0*rik6*width2 + 1100.0d0*rik5*width3 & + 2000.0d0*rik4*width4 + 2160.0d0*rik3*width5 & + 1280.0d0*rik2*width6 + 320.0d0*rik*width7) de = de - p6 * (5.0d0*rik7 + 35.0d0*rik6*width & + 132.0d0*rik5*width2 + 310.0d0*rik4*width3 & + 472.0d0*rik3*width4 + 456.0d0*rik2*width5 & + 256.0d0*rik*width6 + 64.0d0*width7) de = 12.0d0*de*eps*p6 & / (5.0d0*denom*rik*(rik+2.0d0*width)) c c scale the interaction based on its group membership c if (use_group) then e = e * fgrp de = de * fgrp end if c c find the chain rule terms for derivative components c de = de / rik dedx = de * xr dedy = de * yr dedz = de * zr c c increment the total van der Waals energy and derivatives c ev = ev + e if (i .eq. iv) then dev(1,i) = dev(1,i) + dedx dev(2,i) = dev(2,i) + dedy dev(3,i) = dev(3,i) + dedz else dev(1,i) = dev(1,i) + dedx*redi dev(2,i) = dev(2,i) + dedy*redi dev(3,i) = dev(3,i) + dedz*redi dev(1,iv) = dev(1,iv) + dedx*rediv dev(2,iv) = dev(2,iv) + dedy*rediv dev(3,iv) = dev(3,iv) + dedz*rediv end if if (k .eq. kv) then dev(1,k) = dev(1,k) - dedx dev(2,k) = dev(2,k) - dedy dev(3,k) = dev(3,k) - dedz else redk = kred(k) redkv = 1.0d0 - redk dev(1,k) = dev(1,k) - dedx*redk dev(2,k) = dev(2,k) - dedy*redk dev(3,k) = dev(3,k) - dedz*redk dev(1,kv) = dev(1,kv) - dedx*redkv dev(2,kv) = dev(2,kv) - dedy*redkv dev(3,kv) = dev(3,kv) - dedz*redkv end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine elj2 -- atom-by-atom Lennard-Jones Hessian ## c ## ## c ############################################################### c c c "elj2" calculates the Lennard-Jones 6-12 van der Waals second c derivatives for a single atom at a time c c subroutine elj2 (i) use warp implicit none integer i c c c choose the method for summing over pairwise interactions c if (use_stophat) then call elj2c (i) else if (use_smooth) then call elj2b (i) else call elj2a (i) end if return end c c c ############################################################### c ## ## c ## subroutine elj2a -- double loop Lennard-Jones Hessian ## c ## ## c ############################################################### c c c "elj2a" calculates the Lennard-Jones 6-12 van der Waals second c derivatives using a double loop over relevant atom pairs c c subroutine elj2a (iatom) use atomid use atoms use bound use cell use couple use group use hessn use shunt use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer iatom,jcell integer nlist,list(5) integer, allocatable :: iv14(:) real*8 e,de,d2e real*8 fgrp,p6,p12 real*8 eps,rv,rdn real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 redi2,rediv2 real*8 rediiv real*8 redik,redivk real*8 redikv,redivkv real*8 rik,rik2,rik3 real*8 rik4,rik5 real*8 taper,dtaper real*8 d2taper real*8 d2edx,d2edy,d2edz real*8 term(3,3) real*8, allocatable :: vscale(:) logical proceed character*6 mode c c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n vscale(i) = 1.0d0 iv14(i) = 0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c check to see if the atom of interest is a vdw site c nlist = 0 do k = 1, nvdw if (ivdw(k) .eq. iatom) then nlist = nlist + 1 list(nlist) = iatom goto 10 end if end do return 10 continue c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c determine the atoms involved via reduction factors c nlist = 1 list(nlist) = iatom do k = 1, n12(iatom) i = i12(k,iatom) if (ired(i) .eq. iatom) then nlist = nlist + 1 list(nlist) = i end if end do c c find van der Waals Hessian elements for involved atoms c do ii = 1, nlist i = list(ii) it = jvdw(i) iv = ired(i) redi = kred(i) if (i .ne. iv) then rediv = 1.0d0 - redi redi2 = redi * redi rediv2 = rediv * rediv rediiv = redi * rediv end if xi = xred(i) yi = yred(i) zi = zred(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (k .ne. i) c c compute the Hessian elements for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) rik = sqrt(rik2) p6 = rv**6 / rik2**3 p12 = p6 * p6 de = eps * (p12-p6) * (-12.0d0/rik) d2e = eps * (13.0d0*p12-7.0d0*p6) * (12.0d0/rik2) c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then e = eps * (p12-2.0d0*p6) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2 & + 6.0d0*c3*rik + 2.0d0*c2 d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper de = e*dtaper + de*taper 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 get chain rule terms for van der Waals Hessian elements c de = de / rik d2e = (d2e-de) / rik2 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 if (i .eq. iatom) then if (i.eq.iv .and. k.eq.kv) then 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 else if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redi hessy(j,k) = hessy(j,k) - term(2,j)*redi hessz(j,k) = hessz(j,k) - term(3,j)*redi hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv end do else if (i .eq. iv) then redk = kred(k) redkv = 1.0d0 - redk 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)*redk hessy(j,k) = hessy(j,k) - term(2,j)*redk hessz(j,k) = hessz(j,k) - term(3,j)*redk hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv end do else redk = kred(k) redkv = 1.0d0 - redk redik = redi * redk redikv = redi * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redik hessy(j,k) = hessy(j,k) - term(2,j)*redik hessz(j,k) = hessz(j,k) - term(3,j)*redik hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv end do end if else if (iv .eq. iatom) then if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*rediv hessy(j,k) = hessy(j,k) - term(2,j)*rediv hessz(j,k) = hessz(j,k) - term(3,j)*rediv hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 end do else redk = kred(k) redkv = 1.0d0 - redk redivk = rediv * redk redivkv = rediv * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*redivk hessy(j,k) = hessy(j,k) - term(2,j)*redivk hessz(j,k) = hessz(j,k) - term(3,j)*redivk hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv end do end if end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nlist i = list(ii) it = jvdw(i) iv = ired(i) redi = kred(i) if (i .ne. iv) then rediv = 1.0d0 - redi redi2 = redi * redi rediv2 = rediv * rediv rediiv = redi * rediv end if xi = xred(i) yi = yred(i) zi = zred(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) c c compute the Hessian elements for this interaction c if (proceed) then do jcell = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,jcell) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if rik = sqrt(rik2) p6 = rv**6 / rik2**3 p12 = p6 * p6 de = eps * (p12-p6) * (-12.0d0/rik) d2e = eps * (13.0d0*p12-7.0d0*p6) * (12.0d0/rik2) c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then e = eps * (p12-2.0d0*p6) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 dtaper = 5.0d0*c5*rik4 + 4.0d0*c4*rik3 & + 3.0d0*c3*rik2 + 2.0d0*c2*rik + c1 d2taper = 20.0d0*c5*rik3 + 12.0d0*c4*rik2 & + 6.0d0*c3*rik + 2.0d0*c2 d2e = e*d2taper + 2.0d0*de*dtaper + d2e*taper de = e*dtaper + de*taper 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 get chain rule terms for van der Waals Hessian elements c de = de / rik d2e = (d2e-de) / rik2 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 if (i .eq. iatom) then if (i.eq.iv .and. k.eq.kv) then 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 else if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redi hessy(j,k) = hessy(j,k) - term(2,j)*redi hessz(j,k) = hessz(j,k) - term(3,j)*redi hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediiv end do else if (i .eq. iv) then redk = kred(k) redkv = 1.0d0 - redk 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)*redk hessy(j,k) = hessy(j,k) - term(2,j)*redk hessz(j,k) = hessz(j,k) - term(3,j)*redk hessx(j,kv) = hessx(j,kv) & - term(1,j)*redkv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redkv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redkv end do else redk = kred(k) redkv = 1.0d0 - redk redik = redi * redk redikv = redi * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redik hessy(j,k) = hessy(j,k) - term(2,j)*redik hessz(j,k) = hessz(j,k) - term(3,j)*redik hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediiv hessx(j,kv) = hessx(j,kv) & - term(1,j)*redikv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redikv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redikv end do end if else if (iv .eq. iatom) then if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*rediv hessy(j,k) = hessy(j,k) - term(2,j)*rediv hessz(j,k) = hessz(j,k) - term(3,j)*rediv hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediv2 end do else redk = kred(k) redkv = 1.0d0 - redk redivk = rediv * redk redivkv = rediv * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*redivk hessy(j,k) = hessy(j,k) - term(2,j)*redivk hessz(j,k) = hessz(j,k) - term(3,j)*redivk hessx(j,iv) = hessx(j,iv) & + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) & + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) & + term(3,j)*rediv2 hessx(j,kv) = hessx(j,kv) & - term(1,j)*redivkv hessy(j,kv) = hessy(j,kv) & - term(2,j)*redivkv hessz(j,kv) = hessz(j,kv) & - term(3,j)*redivkv end do end if end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################# c ## ## c ## subroutine elj2b -- Lennard-Jones Hessian for smoothing ## c ## ## c ################################################################# c c c "elj2b" calculates the Lennard-Jones 6-12 van der Waals second c derivatives via a Gaussian approximation for use with potential c energy smoothing c c subroutine elj2b (i) use math use vdwpot implicit none integer i c c c set coefficients for a two-Gaussian fit to Lennard-Jones c ngauss = 2 igauss(1,1) = 14487.1d0 igauss(2,1) = 9.05148d0 * twosix**2 igauss(1,2) = -5.55338d0 igauss(2,2) = 1.22536d0 * twosix**2 c c compute Gaussian approximation to Lennard-Jones potential c call egauss2 (i) return end c c c ############################################################### c ## ## c ## subroutine elj2c -- Lennard-Jones Hessian for stophat ## c ## ## c ############################################################### c c c "elj2c" calculates the Lennard-Jones 6-12 van der Waals second c derivatives for use with stophat potential energy smoothing c c subroutine elj2c (iatom) use atomid use atoms use couple use group use hessn use vdw use vdwpot use warp implicit none integer i,j,k,iatom integer ii,it,iv integer kk,kt,kv integer nlist,list(5) integer, allocatable :: iv14(:) real*8 de,d2e real*8 fgrp,p6,denom real*8 eps,rv,rdn real*8 xi,yi,zi real*8 xr,yr,zr real*8 redi,rediv real*8 redk,redkv real*8 redi2,rediv2 real*8 rediiv real*8 redik,redivk real*8 redikv,redivkv real*8 rik,rik2 real*8 rik3,rik4 real*8 rik5,rik6 real*8 rik7,rik8 real*8 width,width2 real*8 width3,width4 real*8 width5,width6 real*8 width7,width8 real*8 d2edx,d2edy,d2edz real*8 term(3,3) real*8, allocatable :: vscale(:) logical proceed c c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n vscale(i) = 1.0d0 iv14(i) = 0 end do c c check to see if the atom of interest is a vdw site c nlist = 0 do k = 1, nvdw if (ivdw(k) .eq. iatom) then nlist = nlist + 1 list(nlist) = iatom goto 10 end if end do return 10 continue c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c determine the atoms involved via reduction factors c nlist = 1 list(nlist) = iatom do k = 1, n12(iatom) i = i12(k,iatom) if (ired(i) .eq. iatom) then nlist = nlist + 1 list(nlist) = i end if end do c c set the extent of smoothing to be performed c width = deform * diffv width2 = width * width width3 = width2 * width width4 = width2 * width2 width5 = width2 * width3 width6 = width3 * width3 width7 = width3 * width4 width8 = width4 * width4 c c find van der Waals Hessian elements for involved atoms c do ii = 1, nlist i = list(ii) it = jvdw(i) iv = ired(i) redi = kred(i) if (i .ne. iv) then rediv = 1.0d0 - redi redi2 = redi * redi rediv2 = rediv * rediv rediiv = redi * rediv end if xi = xred(i) yi = yred(i) zi = zred(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) proceed = .true. if (use_group) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) proceed = (k .ne. i) c c compute the Hessian elements for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) rik2 = xr*xr + yr*yr + zr*zr rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) p6 = rv**6 rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 rik6 = rik3 * rik3 rik7 = rik3 * rik4 rik8 = rik4 * rik4 denom = rik * (rik+2.0d0*width) denom = denom**10 c c transform the potential function via smoothing c de = rik5 * (5.0d0*rik8 + 65.0d0*rik7*width & + 360.0d0*rik6*width2 + 1100.0d0*rik5*width3 & + 2000.0d0*rik4*width4 + 2160.0d0*rik3*width5 & + 1280.0d0*rik2*width6 + 320.0d0*rik*width7) de = de - p6 * (5.0d0*rik7 + 35.0d0*rik6*width & + 132.0d0*rik5*width2 + 310.0d0*rik4*width3 & + 472.0d0*rik3*width4 + 456.0d0*rik2*width5 & + 256.0d0*rik*width6 + 64.0d0*width7) de = de*eps*p6*12.0d0 / (5.0d0*denom) d2e = rik6 * (35.0d0*rik8 + 490.0d0*rik7*width & + 2980.0d0*rik6*width2 + 10280.0d0*rik5*width3 & + 22000.0d0*rik4*width4 + 29920.0d0*rik3*width5 & + 25280.0d0*rik2*width6 + 12160.0d0*rik*width7 & + 2560.0d0*width8) d2e = d2e - p6 * (65.0d0*rik8 + 520.0d0*rik7*width & + 2260.0d0*rik6*width2 + 6280.0d0*rik5*width3 & + 11744.0d0*rik4*width4 + 14816.0d0*rik3*width5 & + 12160.0d0*rik2*width6 + 5888.0d0*rik*width7 & + 1280.0d0*width8) d2e = -12.0d0*p6*eps*d2e & / (5.0d0*denom*rik*(rik+2.0d0*width)) 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 get chain rule terms for van der Waals Hessian elements c de = de / rik d2e = (d2e-de) / rik2 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 if (i .eq. iatom) then if (i.eq.iv .and. k.eq.kv) then 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 else if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redi hessy(j,k) = hessy(j,k) - term(2,j)*redi hessz(j,k) = hessz(j,k) - term(3,j)*redi hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv end do else if (i .eq. iv) then redk = kred(k) redkv = 1.0d0 - redk 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)*redk hessy(j,k) = hessy(j,k) - term(2,j)*redk hessz(j,k) = hessz(j,k) - term(3,j)*redk hessx(j,kv) = hessx(j,kv) - term(1,j)*redkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redkv end do else redk = kred(k) redkv = 1.0d0 - redk redik = redi * redk redikv = redi * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*redi2 hessy(j,i) = hessy(j,i) + term(2,j)*redi2 hessz(j,i) = hessz(j,i) + term(3,j)*redi2 hessx(j,k) = hessx(j,k) - term(1,j)*redik hessy(j,k) = hessy(j,k) - term(2,j)*redik hessz(j,k) = hessz(j,k) - term(3,j)*redik hessx(j,iv) = hessx(j,iv) + term(1,j)*rediiv hessy(j,iv) = hessy(j,iv) + term(2,j)*rediiv hessz(j,iv) = hessz(j,iv) + term(3,j)*rediiv hessx(j,kv) = hessx(j,kv) - term(1,j)*redikv hessy(j,kv) = hessy(j,kv) - term(2,j)*redikv hessz(j,kv) = hessz(j,kv) - term(3,j)*redikv end do end if else if (iv .eq. iatom) then if (k .eq. kv) then do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*rediv hessy(j,k) = hessy(j,k) - term(2,j)*rediv hessz(j,k) = hessz(j,k) - term(3,j)*rediv hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 end do else redk = kred(k) redkv = 1.0d0 - redk redivk = rediv * redk redivkv = rediv * redkv do j = 1, 3 hessx(j,i) = hessx(j,i) + term(1,j)*rediiv hessy(j,i) = hessy(j,i) + term(2,j)*rediiv hessz(j,i) = hessz(j,i) + term(3,j)*rediiv hessx(j,k) = hessx(j,k) - term(1,j)*redivk hessy(j,k) = hessy(j,k) - term(2,j)*redivk hessz(j,k) = hessz(j,k) - term(3,j)*redivk hessx(j,iv) = hessx(j,iv) + term(1,j)*rediv2 hessy(j,iv) = hessy(j,iv) + term(2,j)*rediv2 hessz(j,iv) = hessz(j,iv) + term(3,j)*rediv2 hessx(j,kv) = hessx(j,kv) - term(1,j)*redivkv hessy(j,kv) = hessy(j,kv) - term(2,j)*redivkv hessz(j,kv) = hessz(j,kv) - term(3,j)*redivkv end do end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine elj3 -- Lennard-Jones vdw energy & analysis ## c ## ## c ################################################################ c c c "elj3" calculates the Lennard-Jones 6-12 van der Waals energy c and also partitions the energy among the atoms c c subroutine elj3 use analyz use atoms use energi use inform use iounit use limits use vdwpot use warp implicit none integer i real*8 elrc,aelrc character*6 mode c c c choose the method for summing over pairwise interactions c if (use_stophat) then call elj3e else if (use_smooth) then call elj3d else if (use_vlist) then call elj3c else if (use_lights) then call elj3b else call elj3a end if c c apply the long range van der Waals correction if used c if (use_vcorr) then mode = 'VDW' call evcorr (mode,elrc) ev = ev + elrc aelrc = elrc / dble(n) do i = 1, n aev(i) = aev(i) + aelrc end do if (verbose .and. elrc.ne.0.0d0) then if (digits .ge. 8) then write (iout,10) elrc 10 format (/,' Long-Range van der Waals :',6x,f16.8) else if (digits .ge. 6) then write (iout,20) elrc 20 format (/,' Long-Range van der Waals :',6x,f16.6) else write (iout,30) elrc 30 format (/,' Long-Range van der Waals :',6x,f16.4) end if end if end if return end c c c ################################################################ c ## ## c ## subroutine elj3a -- double loop Lennard-Jones analysis ## c ## ## c ################################################################ c c c "elj3a" calculates the Lennard-Jones 6-12 van der Waals c energy and also partitions the energy among the atoms using c a pairwise double loop c c subroutine elj3a use action use analyz use atomid use atoms use bound use cell use couple use energi use group use inform use inter use iounit use molcul use mutant use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,p6,p12 real*8 eps,sc,term real*8 rv,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8, allocatable :: vscale(:) logical proceed,usei logical header,huge logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & rv,sqrt(rik2),e 30 format (' VDW-LJ',4x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 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, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then do j = 2, ncell xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imager (xr,yr,zr,j) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (use_polymer) then if (rik2 .le. polycut2) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if end if c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 if (i .eq. k) then ev = ev + 0.5d0*e aev(i) = aev(i) + 0.5d0*e else ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,40) 40 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if write (iout,50) i,name(i),k,name(k), & rv,sqrt(rik2),e 50 format (' VDW-LJ',4x,2(i7,'-',a3),1x, & '(XTAL)',6x,2f10.4,f12.4) end if end if end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ############################################################### c ## ## c ## subroutine elj3b -- Lennard-Jones analysis via lights ## c ## ## c ############################################################### c c c "elj3b" calculates the Lennard-Jones 6-12 van der Waals c energy and also partitions the energy among the atoms using c the method of lights c c subroutine elj3b use action use analyz use atomid use atoms use bound use boxes use cell use couple use energi use group use inform use inter use iounit use light use molcul use mutant use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer kgy,kgz integer start,stop integer ikmin,ikmax integer, allocatable :: iv14(:) real*8 e,p6,p12 real*8 eps,sc,term real*8 rv,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8, allocatable :: vscale(:) real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical proceed,usei,prime logical unique,repeat logical header,huge logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) allocate (xsort(8*n)) allocate (ysort(8*n)) allocate (zsort(8*n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c apply any reduction factor to the atomic coordinates c do j = 1, nvdw i = ivdw(j) iv = ired(i) rdn = kred(i) xred(j) = rdn*(x(i)-x(iv)) + x(iv) yred(j) = rdn*(y(i)-y(iv)) + y(iv) zred(j) = rdn*(z(i)-z(iv)) + z(iv) end do c c transfer the interaction site coordinates to sorting arrays c do i = 1, nvdw xsort(i) = xred(i) ysort(i) = yred(i) zsort(i) = zred(i) end do c c use the method of lights to generate neighbors c unique = .true. call lights (off,nvdw,xsort,ysort,zsort,unique) c c loop over all atoms computing the interactions c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xsort(rgx(ii)) yi = ysort(rgy(ii)) zi = zsort(rgz(ii)) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c loop over method of lights neighbors of current atom c if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) + 1 stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 20 continue do j = start, stop kk = locx(j) kgy = rgy(kk) if (kby(ii) .le. key(ii)) then if (kgy.lt.kby(ii) .or. kgy.gt.key(ii)) goto 60 else if (kgy.lt.kby(ii) .and. kgy.gt.key(ii)) goto 60 end if kgz = rgz(kk) if (kbz(ii) .le. kez(ii)) then if (kgz.lt.kbz(ii) .or. kgz.gt.kez(ii)) goto 60 else if (kgz.lt.kbz(ii) .and. kgz.gt.kez(ii)) goto 60 end if k = ivdw(kk-((kk-1)/nvdw)*nvdw) kt = jvdw(k) kv = ired(k) mutk = mut(k) prime = (kk .le. nvdw) c c decide whether to compute the current interaction c 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) if (use_bounds) then if (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) if (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) if (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) if (monoclinic) then xr = xr + zr*beta_cos zr = zr * beta_sin else if (triclinic) then xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term end if end if rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (prime) then if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) end if c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if c c increment the total intermolecular energy c if (.not.prime .or. 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,30) 30 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if ikmin = min(i,k) ikmax = max(i,k) if (prime) then write (iout,40) ikmin,name(ikmin),ikmax, & name(ikmax),rv,sqrt(rik2),e 40 format (' VDW-LJ',4x,2(i7,'-',a3), & 13x,2f10.4,f12.4) else write (iout,50) ikmin,name(ikmin),ikmax, & name(ikmax),rv,sqrt(rik2),e 50 format (' VDW-LJ',4x,2(i7,'-',a3),1x, & '(XTAL)',6x,2f10.4,f12.4) end if end if end if end if 60 continue end do if (repeat) then repeat = .false. start = kbx(ii) + 1 stop = nlight goto 20 end if c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) deallocate (xsort) deallocate (ysort) deallocate (zsort) return end c c c ############################################################# c ## ## c ## subroutine elj3c -- Lennard-Jones analysis via list ## c ## ## c ############################################################# c c c "elj3c" calculates the Lennard-Jones van der Waals energy c and also partitions the energy among the atoms using a c pairwise neighbor list c c subroutine elj3c use action use analyz use atomid use atoms use bound use couple use energi use group use inform use inter use iounit use molcul use mutant use neigh use shunt use usage use vdw use vdwpot implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,p6,p12 real*8 eps,sc,term real*8 rv,rdn,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik2,rik3 real*8 rik4,rik5,taper real*8, allocatable :: vscale(:) logical proceed,usei logical header,huge logical muti,mutk,mutik character*6 mode c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c set the coefficients for the switching function c mode = 'VDW' call switch (mode) c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nvdw,ivdw,jvdw,ired, !$OMP& xred,yred,zred,use,nvlst,vlst,n12,n13,n14,n15,i12,i13,i14, !$OMP& i15,v2scale,v3scale,v4scale,v5scale,use_group,off2,radmin, !$OMP& epsilon,radmin4,epsilon4,vcouple,vlambda,mut,cut2,c0,c1, !$OMP& c2,c3,c4,c5,molcule,name,verbose,debug,header,iout) !$OMP& firstprivate(vscale,iv14) shared(ev,nev,aev,einter) !$OMP DO reduction(+:ev,nev,aev,einter) schedule(guided) c c find the van der Waals energy via neighbor list search c do ii = 1, nvdw i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) muti = mut(i) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = 1, nvlst(i) k = vlst(kk,i) kt = jvdw(k) kv = ired(k) mutk = mut(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call image (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr c c check for an interaction distance less than the cutoff c if (rik2 .le. off2) then rv = radmin(kt,it) eps = epsilon(kt,it) if (iv14(k) .eq. i) then rv = radmin4(kt,it) eps = epsilon4(kt,it) end if eps = eps * vscale(k) c c set use of lambda scaling for decoupling or annihilation c mutik = .false. if (muti .or. mutk) then if (vcouple .eq. 1) then mutik = .true. else if (.not.muti .or. .not.mutk) then mutik = .true. end if end if c c get interaction energy, via soft core lambda scaling as needed c if (mutik) then p6 = 2.0d0 * rik2**3 / rv**6 sc = p6 + 0.5d0*(1.0d0-vlambda) term = 4.0d0 * vlambda * eps / (sc*sc) e = term * (1.0d0-sc) else p6 = rv**6 / rik2**3 p12 = p6 * p6 e = eps * (p12 - 2.0d0*p6) end if c c use energy switching if near the cutoff distance c if (rik2 .gt. cut2) then rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 taper = c5*rik5 + c4*rik4 + c3*rik3 & + c2*rik2 + c1*rik + c0 e = e * taper end if c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) then nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(k) + 0.5d0*e end if 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 = (e .gt. 10.0d0) if ((debug.and.e.ne.0.0d0) & .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & rv,sqrt(rik2),e 30 format (' VDW-LJ',4x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################################## c ## ## c ## subroutine elj3d -- Lennard-Jones analysis for smoothing ## c ## ## c ################################################################## c c c "elj3d" calculates the Lennard-Jones 6-12 van der Waals energy c and also partitions the energy among the atoms via a Gaussian c approximation for potential energy smoothing c c subroutine elj3d use math use vdwpot implicit none c c c set coefficients for a two-Gaussian fit to Lennard-Jones c ngauss = 2 igauss(1,1) = 14487.1d0 igauss(2,1) = 9.05148d0 * twosix**2 igauss(1,2) = -5.55338d0 igauss(2,2) = 1.22536d0 * twosix**2 c c compute Gaussian approximation to Lennard-Jones potential c call egauss3 return end c c c ################################################################ c ## ## c ## subroutine elj3e -- Lennard-Jones analysis for stophat ## c ## ## c ################################################################ c c c "elj3e" calculates the Lennard-Jones 6-12 van der Waals energy c and also partitions the energy among the atoms for use with c stophat potential energy smoothing c c subroutine elj3e use action use analyz use atomid use atoms use couple use energi use group use inform use inter use iounit use molcul use usage use vdw use vdwpot use warp implicit none integer i,j,k integer ii,it,iv integer kk,kt,kv integer, allocatable :: iv14(:) real*8 e,rik2,rdn,p6 real*8 eps,rv,fgrp real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik,rik3,rik4 real*8 rik5,rik6 real*8 width,width2 real*8 width3,width4 real*8 width5,width6 real*8, allocatable :: vscale(:) logical proceed,usei logical header,huge c c c zero out the van der Waals energy and partitioning terms c nev = 0 ev = 0.0d0 do i = 1, n aev(i) = 0.0d0 end do if (nvdw .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (iv14(n)) allocate (vscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n iv14(i) = 0 vscale(i) = 1.0d0 end do c c print header information if debug output was requested c header = .true. if (debug .and. nvdw.ne.0) then header = .false. write (iout,10) 10 format (/,' Individual van der Waals Interactions :', & //,' Type',14x,'Atom Names',20x,'Minimum', & 4x,'Actual',6x,'Energy',/) end if c c set the extent of smoothing to be performed c width = deform * diffv width2 = width * width width3 = width2 * width width4 = width2 * width2 width5 = width2 * width3 width6 = width3 * width3 c c apply any reduction factor to the atomic coordinates c do k = 1, nvdw i = ivdw(k) iv = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(iv)) + x(iv) yred(i) = rdn*(y(i)-y(iv)) + y(iv) zred(i) = rdn*(z(i)-z(iv)) + z(iv) end do c c find the van der Waals energy via double loop search c do ii = 1, nvdw-1 i = ivdw(ii) it = jvdw(i) iv = ired(i) xi = xred(i) yi = yred(i) zi = zred(i) usei = (use(i) .or. use(iv)) c c set exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = v2scale end do do j = 1, n13(i) vscale(i13(j,i)) = v3scale end do do j = 1, n14(i) vscale(i14(j,i)) = v4scale iv14(i14(j,i)) = i end do do j = 1, n15(i) vscale(i15(j,i)) = v5scale end do c c decide whether to compute the current interaction c do kk = ii+1, nvdw k = ivdw(kk) kt = jvdw(k) kv = ired(k) 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)) c c compute the energy contribution for this interaction c if (proceed) then xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) rik2 = xr*xr + yr*yr + zr*zr eps = epsilon(kt,it) rv = radmin(kt,it) if (iv14(k) .eq. i) then eps = epsilon4(kt,it) rv = radmin4(kt,it) end if eps = eps * vscale(k) p6 = rv**6 rik = sqrt(rik2) rik3 = rik2 * rik rik4 = rik2 * rik2 rik5 = rik2 * rik3 rik6 = rik3 * rik3 c c transform the potential function via smoothing c e = rik6 * (30.0d0*rik6 + 360.0d0*rik5*width & + 1800.0d0*rik4*width2 + 4800.0d0*rik3*width3 & + 7200.0d0*rik2*width4 + 5760.0d0*rik*width5 & + 1920.0d0*width6) e = -e + p6 * (15.0d0*rik6 + 90.0d0*rik5*width & + 288.0d0*rik4*width2 + 552.0d0*rik3*width3 & + 648.0d0*rik2*width4 + 432.0d0*rik*width5 & + 128.0d0*width6) e = e*eps*p6 / (15.0d0*(rik*(rik+2.0d0*width))**9) c c scale the interaction based on its group membership c if (use_group) e = e * fgrp c c increment the overall van der Waals energy components c if (e .ne. 0.0d0) nev = nev + 1 ev = ev + e aev(i) = aev(i) + 0.5d0*e aev(k) = aev(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 = (e .gt. 10.0d0) if (debug .or. (verbose.and.huge)) then if (header) then header = .false. write (iout,20) 20 format (/,' Individual van der Waals', & ' Interactions :', & //,' Type',14x,'Atom Names', & 20x,'Minimum',4x,'Actual', & 6x,'Energy',/) end if write (iout,30) i,name(i),k,name(k), & rv,sqrt(rik2),e 30 format (' VDW-LJ',4x,2(i7,'-',a3), & 13x,2f10.4,f12.4) end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, n12(i) vscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) vscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) vscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) vscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (iv14) deallocate (vscale) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine embed -- structures via distance geometry ## c ## ## c ############################################################## c c c "embed" is a distance geometry routine patterned after the c ideas of Gordon Crippen, Irwin Kuntz and Tim Havel; it takes c as input a set of upper and lower bounds on the interpoint c distances, chirality restraints and torsional restraints, c and attempts to generate a set of coordinates that satisfy c the input bounds and restraints c c literature references: c c G. M. Crippen and T. F. Havel, "Distance Geometry and Molecular c Conformation", Research Studies Press, Letchworth U.K., 1988, c John Wiley and Sons, U.S. distributor c c T. F. Havel, "An Evaluation of Computational Strategies for c Use in the Determination of Protein Structure from Distance c Constraints obtained by Nuclear Magnetic Resonance", Progress c in Biophysics and Molecular Biology, 56, 43-78 (1991) c c subroutine embed use atoms use disgeo use files use inform use iounit use minima use refer implicit none integer maxeigen parameter (maxeigen=5) integer i,j,nvar,nstep integer lext,igeo,freeunit integer maxneg,nneg integer maxinner,ninner integer maxouter,nouter real*8 fctval,grdmin real*8 dt,wall,cpu real*8 temp_start real*8 temp_stop real*8 rg,rmsorig real*8 rmsflip,mass real*8 bounds,contact real*8 chiral,torsion real*8 local,locerr real*8 bnderr,vdwerr real*8 chirer,torser real*8 evl(maxeigen) real*8, allocatable :: v(:) real*8, allocatable :: a(:) real*8, allocatable :: evc(:,:) real*8, allocatable :: matrix(:,:) real*8, allocatable :: derivs(:,:) logical done,valid logical exist,info character*7 errtyp,ext character*240 title character*240 geofile c c c perform dynamic allocation of some local arrays c allocate (evc(n,maxeigen)) allocate (matrix(n,n)) c c initialize any chirality restraints, then smooth the c bounds via triangle and inverse triangle inequalities; c currently these functions are performed by "distgeom" c c call kchiral c if (verbose .and. n.le.130) then c title = 'Input Distance Bounds :' c call grafic (n,bnd,title) c end if c call geodesic c if (verbose .and. n.le.130)) then c title = 'Triangle Smoothed Bounds :' c call grafic (n,bnd,title) c end if c c generate a distance matrix between the upper and c lower bounds, then convert to a metric matrix c maxinner = 3 maxouter = 3 maxneg = 2 nouter = 0 valid = .false. do while (.not. valid) ninner = 0 done = .false. do while (.not. done) ninner = ninner + 1 call dstmat (matrix) call metric (matrix,nneg) if (nneg.le.maxneg .or. ninner.eq.maxinner) done = .true. compact = 0.0d0 end do if (verbose .and. nneg.gt.maxneg) then write (iout,10) nneg 10 format (/,' EMBED -- Warning, Using Metric Matrix', & ' with',i4,' Negative Distances') end if c c find the principle components of metric matrix, then c generate the trial Cartesian coordinates c nouter = nouter + 1 call eigen (evl,evc,matrix,valid) call coords (evl,evc) if (nouter.eq.maxouter .and. .not.valid) then valid = .true. if (verbose) then write (iout,20) 20 format (/,' EMBED -- Warning, Using Poor Initial', & ' Coordinates') end if end if end do c c superimpose embedded structure and enantiomer on reference c info = verbose verbose = .false. call impose (nref(1),xref,yref,zref,n,x,y,z,rmsorig) if (use_invert) then do i = 1, n x(i) = -x(i) end do call impose (nref(1),xref,yref,zref,n,x,y,z,rmsflip) if (rmsorig .lt. rmsflip) then do i = 1, n x(i) = -x(i) end do call impose (nref(1),xref,yref,zref,n,x,y,z,rmsorig) end if write (iout,30) rmsorig,rmsflip 30 format (/,' RMS Superposition for Original and', & ' Enantiomer : ',2f12.4) end if verbose = info c c compute an index of compaction for the embedded structure c call chksize c c write out the unrefined embedded atomic coordinate set c if (debug) then i = 0 exist = .true. do while (exist) i = i + 1 lext = 3 call numeral (i,ext,lext) geofile = filename(1:leng)//'-embed'//'.'//ext(1:lext) inquire (file=geofile,exist=exist) end do igeo = freeunit () open (unit=igeo,file=geofile,status='new') call prtxyz (igeo) close (unit=igeo) title = 'after Embedding :' call fracdist (title) end if c c use majorization to improve initial embedded coordinates c do i = 1, n matrix(i,i) = 0.0d0 do j = i+1, n matrix(j,i) = matrix(i,j) end do end do call majorize (matrix) c c square the bounds for use during structure refinement c do i = 1, n do j = 1, n dbnd(j,i) = dbnd(j,i)**2 end do end do c c perform dynamic allocation of some local arrays c if (use_anneal) then nvar = 3 * n allocate (v(nvar)) allocate (a(nvar)) end if c c minimize the error function via simulated annealing c if (verbose) call settime if (use_anneal) then iprint = 0 if (verbose) iprint = 10 grdmin = 1.0d0 mass = 10000.0d0 do i = 1, nvar v(i) = 0.0d0 a(i) = 0.0d0 end do errtyp = 'FINAL' call refine (errtyp,fctval,grdmin) nstep = 1000 dt = 0.04d0 temp_start = 200.0d0 temp_stop = 200.0d0 call explore (errtyp,nstep,dt,mass,temp_start,temp_stop,v,a) nstep = 10000 dt = 0.2d0 temp_start = 200.0d0 temp_stop = 0.0d0 call explore (errtyp,nstep,dt,mass,temp_start,temp_stop,v,a) grdmin = 0.01d0 call refine (errtyp,fctval,grdmin) c c minimize the error function via nonlinear optimization c else iprint = 0 if (verbose) iprint = 10 grdmin = 0.01d0 errtyp = 'INITIAL' call refine (errtyp,fctval,grdmin) errtyp = 'MIDDLE' call refine (errtyp,fctval,grdmin) errtyp = 'FINAL' call refine (errtyp,fctval,grdmin) end if if (verbose) then call gettime (wall,cpu) write (iout,40) wall 40 format (/,' Time Required for Refinement :',10x,f12.2, & ' seconds') end if c c perform deallocation of some local arrays c if (use_anneal) then deallocate (v) deallocate (a) end if c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c print the final error function and its components c bounds = bnderr (derivs) contact = vdwerr (derivs) local = locerr (derivs) chiral = chirer (derivs) torsion = torser (derivs) write (iout,50) fctval,bounds,contact,local,chiral,torsion 50 format (/,' Results of Distance Geometry Protocol :', & //,' Final Error Function Value :',10x,f16.4, & //,' Distance Restraint Error :',12x,f16.4, & /,' Hard Sphere Contact Error :',11x,f16.4, & /,' Local Geometry Error :',16x,f16.4, & /,' Chirality-Planarity Error :',11x,f16.4, & /,' Torsional Restraint Error :',11x,f16.4) c c take the root of the currently squared distance bounds c do i = 1, n do j = 1, n dbnd(j,i) = sqrt(dbnd(j,i)) end do end do c c print the final rms deviations and radius of gyration c title = 'after Refinement :' call rmserror (title) call gyrate (rg) write (iout,60) rg 60 format (/,' Radius of Gyration after Refinement :',6x,f16.4) if (verbose .and. n.le.130) call dmdump (matrix) c c print the normalized fractional distance distribution c if (debug) then title = 'after Refinement :' call fracdist (title) end if c c perform deallocation of some local arrays c deallocate (evc) deallocate (matrix) deallocate (derivs) return end c c c ############################################################## c ## ## c ## subroutine kchiral -- chirality restraint assignment ## c ## ## c ############################################################## c c c "kchiral" determines the target value for each chirality c and planarity restraint as the signed volume of the c parallelpiped spanned by vectors from a common atom to c each of three other atoms c c subroutine kchiral use atoms use inform use iounit use restrn implicit none integer i,j,ia,ib,ic,id real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 c1,c2,c3 c c c compute the signed volume of each parallelpiped; c if the defining atoms almost lie in a plane, then c set the signed volume to exactly zero c do i = 1, nchir ia = ichir(1,i) ib = ichir(2,i) ic = ichir(3,i) id = ichir(4,i) xad = x(ia) - x(id) yad = y(ia) - y(id) zad = z(ia) - z(id) xbd = x(ib) - x(id) ybd = y(ib) - y(id) zbd = z(ib) - z(id) xcd = x(ic) - x(id) ycd = y(ic) - y(id) zcd = z(ic) - z(id) c1 = ybd*zcd - zbd*ycd c2 = ycd*zad - zcd*yad c3 = yad*zbd - zad*ybd chir(1,i) = 0.1d0 chir(2,i) = xad*c1 + xbd*c2 + xcd*c3 if (abs(chir(2,i)) .lt. 1.0d0) chir(2,i) = 0.0d0 chir(3,i) = chir(2,i) end do c c print out the results for each restraint c if (verbose) then if (nchir .ne. 0) then write (iout,10) 10 format (/,' Chirality and Planarity Constraints :') write (iout,20) 20 format (/,18x,'Atom Numbers',12x,'Signed Volume',/) end if do i = 1, nchir write (iout,30) i,(ichir(j,i),j=1,4),chir(2,i) 30 format (i6,5x,4i6,5x,f12.4) end do end if return end c c c ############################################################## c ## ## c ## subroutine triangle -- triangle inequality smoothing ## c ## ## c ############################################################## c c c "triangle" smooths the upper and lower distance bounds via c the triangle inequality using a full-matrix variant of the c Floyd-Warshall shortest path algorithm; this routine is c usually much slower than the sparse matrix shortest path c methods in "geodesic" and "trifix", and should be used only c for comparison with answers generated by those routines c c literature reference: c c A. W. M. Dress and T. F. Havel, "Shortest-Path Problems and c Molecular Conformation", Discrete Applied Mathematics, 19, c 129-144 (1988) c c subroutine triangle use atoms use disgeo use iounit implicit none integer i,j,k integer ik1,ik2 integer jk1,jk2 real*8 eps real*8 lij,lik,ljk real*8 uij,uik,ujk c c c use full-matrix algorithm to smooth upper and lower bounds c eps = 1.0d-10 do k = 1, n do i = 1, n-1 ik1 = min(i,k) ik2 = max(i,k) lik = dbnd(ik2,ik1) uik = dbnd(ik1,ik2) do j = i+1, n lij = dbnd(j,i) uij = dbnd(i,j) jk1 = min(j,k) jk2 = max(j,k) ljk = dbnd(jk2,jk1) ujk = dbnd(jk1,jk2) lij = max(lij,lik-ujk,ljk-uik) uij = min(uij,uik+ujk) if (lij-uij .gt. eps) then write (iout,10) 10 format (/,' TRIANGLE -- Inconsistent Bounds;', & ' Geometrically Impossible') write (iout,20) i,j,lij,uij 20 format (/,' Error at :',6x,2i6,3x,2f9.4) write (iout,30) i,k,lik,uik,j,k,ljk,ujk 30 format (/,' Traced to :',5x,2i6,3x,2f9.4, & /,17x,2i6,3x,2f9.4) call fatal end if if (lij-dbnd(j,i) .gt. eps) then write (iout,40) i,j,dbnd(j,i),lij 40 format (' TRIANGLE -- Altered Lower Bound at', & 2x,2i6,3x,f9.4,' -->',f9.4) end if if (dbnd(i,j)-uij .gt. eps) then write (iout,50) i,j,dbnd(i,j),uij 50 format (' TRIANGLE -- Altered Upper Bound at', & 2x,2i6,3x,f9.4,' -->',f9.4) end if dbnd(j,i) = lij dbnd(i,j) = uij end do end do end do return end c c c ################################################################# c ## ## c ## subroutine geodesic -- sparse matrix triangle smoothing ## c ## ## c ################################################################# c c c "geodesic" smooths the upper and lower distance bounds via c the triangle inequality using a sparse matrix version of a c shortest path algorithm c c literature reference: c c G. M. Crippen and T. F. Havel, "Distance Geometry and Molecular c Conformation", Research Studies Press, Letchworth U.K., 1988, c John Wiley and Sons, U.S. distributor, see section 6-2 c c subroutine geodesic use atoms use disgeo use restrn implicit none integer i,j,k,nlist integer, allocatable :: list(:) integer, allocatable :: key(:) integer, allocatable :: start(:) integer, allocatable :: stop(:) real*8, allocatable :: upper(:) real*8, allocatable :: lower(:) c c c perform dynamic allocation of some local arrays c nlist = 2 * ndfix allocate (list(nlist)) allocate (key(nlist)) allocate (start(n)) allocate (stop(n)) allocate (upper(n)) allocate (lower(n)) c c build an indexed list of atoms in distance restraints c do i = 1, n start(i) = 0 stop(i) = -1 end do do i = 1, ndfix list(i) = idfix(1,i) list(i+ndfix) = idfix(2,i) end do call sort3 (nlist,list,key) j = -1 do i = 1, nlist k = list(i) if (k .ne. j) then start(k) = i j = k end if end do j = -1 do i = nlist, 1, -1 k = list(i) if (k .ne. j) then stop(k) = i j = k end if end do do i = 1, nlist k = key(i) if (k .le. ndfix) then list(i) = idfix(2,k) else list(i) = idfix(1,k-ndfix) end if end do c c triangle smooth bounds via sparse shortest path method c do i = 1, n call minpath (i,upper,lower,start,stop,list) do j = i+1, n dbnd(i,j) = upper(j) dbnd(j,i) = max(lower(j),dbnd(j,i)) end do end do c c perform deallocation of some local arrays c deallocate (list) deallocate (key) deallocate (start) deallocate (stop) deallocate (upper) deallocate (lower) return end c c c ################################################################ c ## ## c ## subroutine minpath -- triangle smoothed bounds to atom ## c ## ## c ################################################################ c c c "minpath" is a routine for finding the triangle smoothed upper c and lower bounds of each atom to a specified root atom using a c sparse variant of the Bellman-Ford shortest path algorithm c c literature reference: c c D. P. Bertsekas, "A Simple and Fast Label Correcting Algorithm c for Shortest Paths", Networks, 23, 703-709 (1993) c c subroutine minpath (root,upper,lower,start,stop,list) use atoms use couple use disgeo implicit none integer i,j,k integer narc,root integer head,tail integer, allocatable :: iarc(:) integer, allocatable :: queue(:) integer start(*) integer stop(*) integer list(*) real*8 big,small real*8 upper(*) real*8 lower(*) logical enter logical, allocatable :: queued(:) c c c perform dynamic allocation of some local arrays c allocate (iarc(n)) allocate (queue(n)) allocate (queued(n)) c c initialize candidate atom queue and the path lengths c do i = 1, n queued(i) = .false. upper(i) = 1000000.0d0 lower(i) = 0.0d0 end do c c put the root atom into the queue of candidate atoms c head = root tail = root queue(root) = 0 queued(root) = .true. upper(root) = 0.0d0 c c get the next candidate atom from head of queue c do while (head .ne. 0) j = head queued(j) = .false. head = queue(head) c c make a list of arcs to the current candidate atom c narc = 0 do i = 1, n12(j) k = i12(i,j) if (k .ne. root) then narc = narc + 1 iarc(narc) = k end if end do do i = 1, n13(j) k = i13(i,j) if (k .ne. root) then narc = narc + 1 iarc(narc) = k end if end do do i = 1, n14(j) k = i14(i,j) if (k .ne. root) then narc = narc + 1 iarc(narc) = k end if end do do i = start(j), stop(j) k = list(i) if (k .ne. root) then narc = narc + 1 iarc(narc) = k end if end do c c check each arc for alteration of the path length bounds c do i = 1, narc k = iarc(i) if (k .lt. j) then big = upper(j) + dbnd(k,j) small = max(dbnd(j,k)-upper(j),lower(j)-dbnd(k,j)) else big = upper(j) + dbnd(j,k) small = max(dbnd(k,j)-upper(j),lower(j)-dbnd(j,k)) end if enter = .false. if (upper(k) .gt. big) then upper(k) = big if (.not. queued(k)) enter = .true. end if if (lower(k) .lt. small) then lower(k) = small if (.not. queued(k)) enter = .true. end if c c enter a new candidate atom at the tail of the queue c if (enter) then queued(k) = .true. if (head .eq. 0) then head = k tail = k queue(k) = 0 else queue(tail) = k queue(k) = 0 tail = k end if end if end do end do c c perform deallocation of some local arrays c deallocate (iarc) deallocate (queue) deallocate (queued) return end c c c ################################################################ c ## ## c ## subroutine trifix -- update triangle inequality bounds ## c ## ## c ################################################################ c c c "trifix" rebuilds both the upper and lower distance bound c matrices following tightening of one or both of the bounds c between a specified pair of atoms, "p" and "q", using a c modification of Murchland's shortest path update algorithm c c literature references: c c P. A. Steenbrink, "Optimization of Transport Networks", John c Wiley and Sons, Bristol, 1974; see section 7.7 c c R. Dionne, "Etude et Extension d'un Algorithme de Murchland", c Infor, 16, 132-146 (1978) c c subroutine trifix (p,q) use atoms use disgeo use inform use iounit implicit none integer i,k,p,q integer ip,iq,np,nq integer, allocatable :: pt(:) integer, allocatable :: qt(:) real*8 eps,ipmin,ipmax real*8 iqmin,iqmax real*8, allocatable :: pmin(:) real*8, allocatable :: pmax(:) real*8, allocatable :: qmin(:) real*8, allocatable :: qmax(:) logical, allocatable :: pun(:) logical, allocatable :: qun(:) c c c perform dynamic allocation of some local arrays c allocate (pt(n)) allocate (qt(n)) allocate (pmin(n)) allocate (pmax(n)) allocate (qmin(n)) allocate (qmax(n)) allocate (pun(n)) allocate (qun(n)) c c initialize the set of nodes that may have changed bounds c eps = 1.0d-10 np = 0 nq = 0 do i = 1, n pun(i) = .true. qun(i) = .true. end do c c store the upper and lower bounds to "p" and "q" c do i = 1, p pmin(i) = dbnd(p,i) pmax(i) = dbnd(i,p) end do do i = p+1, n pmin(i) = dbnd(i,p) pmax(i) = dbnd(p,i) end do do i = 1, q qmin(i) = dbnd(q,i) qmax(i) = dbnd(i,q) end do do i = q+1, n qmin(i) = dbnd(i,q) qmax(i) = dbnd(q,i) end do c c check for changes in the upper bounds to "p" and "q" c do i = 1, n ipmax = qmax(p) + qmax(i) if (pmax(i) .gt. ipmax+eps) then np = np + 1 pt(np) = i pmax(i) = ipmax pun(i) = .false. end if iqmax = pmax(q) + pmax(i) if (qmax(i) .gt. iqmax+eps) then nq = nq + 1 qt(nq) = i qmax(i) = iqmax qun(i) = .false. end if end do c c for node pairs whose bounds to "p" and "q" have changed, c make any needed changes to upper bound of the pair c do ip = 1, np i = pt(ip) ipmax = pmax(i) do iq = 1, nq k = qt(iq) if (i .lt. k) then dbnd(i,k) = min(dbnd(i,k),ipmax+pmax(k)) else dbnd(k,i) = min(dbnd(k,i),ipmax+pmax(k)) end if end do end do c c check for changes in the lower bounds to "p" and "q" c do i = 1, n ipmin = max(qmin(p)-qmax(i),qmin(i)-qmax(p)) if (pmin(i) .lt. ipmin-eps) then if (pun(i)) then np = np + 1 pt(np) = i end if pmin(i) = ipmin end if iqmin = max(pmin(q)-pmax(i),pmin(i)-pmax(q)) if (qmin(i) .lt. iqmin-eps) then if (qun(i)) then nq = nq + 1 qt(nq) = i end if qmin(i) = iqmin end if end do c c for node pairs whose bounds to "p" and "q" have changed, c make any needed changes to lower bound of the pair c do ip = 1, np i = pt(ip) ipmin = pmin(i) ipmax = pmax(i) do iq = 1, nq k = qt(iq) if (i .lt. k) then dbnd(k,i) = max(dbnd(k,i),ipmin-pmax(k),pmin(k)-ipmax) else dbnd(i,k) = max(dbnd(i,k),ipmin-pmax(k),pmin(k)-ipmax) end if end do end do c c update the upper and lower bounds to "p" and "q" c do i = 1, p dbnd(p,i) = pmin(i) dbnd(i,p) = pmax(i) end do do i = p+1, n dbnd(i,p) = pmin(i) dbnd(p,i) = pmax(i) end do do i = 1, q dbnd(q,i) = qmin(i) dbnd(i,q) = qmax(i) end do do i = q+1, n dbnd(i,q) = qmin(i) dbnd(q,i) = qmax(i) end do c c output the atoms updated and amount of work required c c if (debug) then c write (iout,10) p,q,np*nq c 10 format (' TRIFIX -- Bounds Update for Atoms',2i6, c & ' with',i8,' Searches') c end if c c perform deallocation of some local arrays c deallocate (pt) deallocate (qt) deallocate (pmin) deallocate (pmax) deallocate (qmin) deallocate (qmax) deallocate (pun) deallocate (qun) return end c c c ################################################################ c ## ## c ## subroutine grafic -- schematic graphical matrix output ## c ## ## c ################################################################ c c c "grafic" outputs the upper & lower triangles and diagonal c of a square matrix in a schematic form for visual inspection c c subroutine grafic (n,a,title) use iounit implicit none integer i,j,k,m,n integer maxj,nrow,ndash integer minrow,maxrow integer trimtext real*8 big,v real*8 amin,dmin,bmin real*8 amax,dmax,bmax real*8 rcl,scl,tcl real*8 ca,cb,cc,cd real*8 cw,cx,cy,cz real*8 a(n,*) character*1 dash character*1 ta,tb,tc,td,te character*1 digit(0:9) character*1 symbol(130) character*240 title data dash / '-' / data ta,tb,tc,td,te / ' ','.','+','X','#' / data digit / '0','1','2','3','4','5','6','7','8','9' / c c c set bounds of length of print row and write the header c minrow = 54 maxrow = 130 ndash = min(max(n,minrow),maxrow) write (iout,10) (dash,i=1,ndash) 10 format (/,1x,130a1) write (iout,20) title(1:trimtext(title)) 20 format (/,1x,a) c c find the maximum and minimum elements of the matrix c big = 1.0d6 dmax = -big dmin = big amax = -big amin = big bmax = -big bmin = big do i = 1, n if (a(i,i) .gt. dmax) dmax = a(i,i) if (a(i,i) .lt. dmin) dmin = a(i,i) do j = 1, i-1 if (a(j,i) .gt. amax) amax = a(j,i) if (a(j,i) .lt. amin) amin = a(j,i) if (a(i,j) .gt. bmax) bmax = a(i,j) if (a(i,j) .lt. bmin) bmin = a(i,j) end do end do write (iout,30) amin,amax,dmin,dmax,bmin,bmax 30 format (/,' Range of Above Diag Elements : ',f13.4,' to',f13.4, & /,' Range of Diagonal Elements : ',f13.4,' to',f13.4, & /,' Range of Below Diag Elements : ',f13.4,' to',f13.4) c c now, print out the graphical representation c write (iout,40) 40 format (/,' Symbol Magnitude Ordering :',14x, & '# > X > + > . > '' ''',/) rcl = (bmax-bmin) / 5.0d0 scl = (amax-amin) / 5.0d0 tcl = (dmax-dmin) / 9.0d0 if (rcl .eq. 0.0d0) rcl = 1.0d0 if (scl .eq. 0.0d0) scl = 1.0d0 if (tcl .eq. 0.0d0) tcl = 1.0d0 ca = amin + scl cb = ca + scl cc = cb + scl cd = cc + scl cw = bmin + rcl cx = cw + rcl cy = cx + rcl cz = cy + rcl do j = 1, n, maxrow maxj = j + maxrow - 1 if (maxj .gt. n) maxj = n nrow = maxj - j + 1 do i = 1, n do k = j, maxj m = k - j + 1 if (k .lt. i) then v = abs(a(i,k)) if (v .le. cw) then symbol(m) = ta else if (v .le. cx) then symbol(m) = tb else if (v .le. cy) then symbol(m) = tc else if (v .le. cz) then symbol(m) = td else symbol(m) = te end if else if (k .eq. i) then symbol(m) = digit(nint((a(i,i)-dmin)/tcl)) else if (k .gt. i) then v = abs(a(i,k)) if (v .le. ca) then symbol(m) = ta else if (v .le. cb) then symbol(m) = tb else if (v .le. cc) then symbol(m) = tc else if (v .le. cd) then symbol(m) = td else symbol(m) = te end if end if end do write (iout,50) (symbol(k),k=1,nrow) 50 format (1x,130a1) end do write (iout,60) (dash,i=1,ndash) 60 format (/,1x,130a1) if (maxj .lt. n) then write (iout,70) 70 format () end if end do return end c c c ################################################################ c ## ## c ## subroutine dstmat -- choose values for distance matrix ## c ## ## c ################################################################ c c c "dstmat" selects a distance matrix containing values between c the previously smoothed upper and lower bounds; the distance c values are chosen from uniform distributions, in a triangle c correlated fashion, or using random partial metrization c c subroutine dstmat (dmx) use atoms use disgeo use inform use iounit use keys implicit none integer i,j,k,m integer index,next integer npart,npair integer nmetrize integer mik,mjk,nik,njk integer, allocatable :: list(:) real*8 random,fraction real*8 invbeta,alpha,beta real*8 corr,mean,stdev real*8 denom,swap,delta real*8 percent,eps,gap real*8 wall,cpu real*8, allocatable :: value(:) real*8 dmx(n,*) logical first,uniform logical update character*8 method character*20 keyword character*240 record character*240 string external random,invbeta save first,method,update save npart,percent save mean,stdev save alpha,beta data first / .true. / c c c initialize the method for distance element selection c if (first) then first = .false. method = 'PAIRWISE' uniform = .false. update = .true. npart = 0 percent = 0.0d0 mean = 0.0d0 compact = 0.0d0 beta = 4.0d0 c c search each line of the keyword file for options c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call 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) if (method .eq. 'HAVEL') then call getnumb (record,npart,next) else if (method .eq. 'PARTIAL') then call getnumb (record,npart,next) else if (method .eq. 'PAIRWISE') then string = record(next:240) read (string,*,err=10,end=10) percent 10 continue end if c c get a choice of initial mean for the trial distribution c else if (keyword(1:19) .eq. 'TRIAL-DISTRIBUTION ') then string = record(next:240) read (string,*,err=20,end=20) mean 20 continue update = .false. end if end do c c set extent of partial metrization during distance selection c if (method .eq. 'HAVEL') then if (npart.le.0 .or. npart.ge.n-1) npart = n else if (method .eq. 'PARTIAL') then if (npart.le.0 .or. npart.ge.n-1) npart = 4 else if (method .eq. 'PAIRWISE') then if (percent.le.0.0d0 .or. percent.ge.100.0d0) & percent = min(100.0d0,2000.0d0/dble(n)) end if c c set the initial distribution for selection of trial distances c if (method .eq. 'CLASSIC') uniform = .true. if (method .eq. 'TRICOR') uniform = .true. if (method .eq. 'HAVEL') uniform = .true. if (uniform) update = .false. if (update) then c mean = 2.35d0 / log(pathmax) mean = 1.65d0 / (pathmax)**0.25d0 c mean = 1.30d0 / (pathmax)**0.20d0 end if alpha = beta*mean / (1.0d0-mean) stdev = sqrt(alpha*beta/(alpha+beta+1.0d0)) / (alpha+beta) end if c c write out the final choice for distance matrix generation c if (verbose) then call settime if (method .eq. 'CLASSIC') then write (iout,30) 30 format (/,' Distance Matrix via Uniform Random', & ' Fractions without Metrization :') else if (method .eq. 'RANDOM') then write (iout,40) 40 format (/,' Distance Matrix Generated via Normal', & ' Fractions without Metrization :') else if (method .eq. 'TRICOR') then write (iout,50) 50 format (/,' Distance Matrix Generated via Triangle', & ' Correlated Fractions :') else if (method.eq.'HAVEL' .and. npart.lt.n) then write (iout,60) npart 60 format (/,' Distance Matrix Generated via',i4,'-Atom', & ' Partial Metrization :') else if (method .eq. 'HAVEL') then write (iout,70) 70 format (/,' Distance Matrix Generated via Randomized', & ' Atom-Based Metrization :') else if (method .eq. 'PARTIAL') then write (iout,80) npart 80 format (/,' Distance Matrix Generated via',i4,'-Atom', & ' Partial Metrization :') else if (method.eq.'PAIRWISE' .and. percent.lt.100.0d0) then write (iout,90) percent 90 format (/,' Distance Matrix Generated via',f6.2,'%', & ' Random Pairwise Metrization :') else write (iout,100) 100 format (/,' Distance Matrix Generated via Randomized', & ' Pairwise Metrization :') end if end if c c adjust the distribution for selection of trial distances c if (uniform) then write (iout,110) 110 format (/,' Trial Distances Selected at Random from', & ' Uniform Distribution') else if (update) then alpha = alpha - 0.2d0*sign(sqrt(abs(compact)),compact) mean = alpha / (alpha+beta) stdev = sqrt(alpha*beta/(alpha+beta+1.0d0)) / (alpha+beta) end if write (iout,120) mean,stdev,alpha,beta 120 format (/,' Trial Distance Beta Distribution :', & 4x,f5.2,' +/-',f5.2,3x,'Alpha-Beta',2f6.2) end if c c perform dynamic allocation of some local arrays c npair = n*(n-1) / 2 allocate (list(npair)) allocate (value(npair)) c c uniform or Gaussian distributed distances without metrization c if (method.eq.'CLASSIC' .or. method.eq.'RANDOM') then do i = 1, n dmx(i,i) = 0.0d0 end do do i = 1, n-1 do j = i+1, n fraction = random () if (method .eq. 'RANDOM') then fraction = invbeta (alpha,beta,fraction) end if delta = dbnd(i,j) - dbnd(j,i) dmx(j,i) = dbnd(j,i) + delta*fraction dmx(i,j) = dmx(j,i) end do end do c c Crippen's triangle correlated distance selection c else if (method .eq. 'TRICOR') then do i = 1, n dmx(i,i) = 0.0d0 end do do i = 1, n-1 do j = i+1, n dmx(j,i) = random () dmx(i,j) = dmx(j,i) end do end do do i = 1, n-1 do j = i+1, n denom = 0.0d0 dmx(i,j) = 0.0d0 do k = 1, n if (k .ne. i) then mik = max(i,k) mjk = max(j,k) nik = min(i,k) njk = min(j,k) if (k .eq. j) then dmx(i,j) = dmx(i,j) + dmx(j,i) denom = denom + 1.0d0 else if (dbnd(njk,mjk) .le. & 0.2d0*dbnd(nik,mik)) then if (i .gt. k) corr = 0.9d0 * dmx(i,k) if (k .gt. i) corr = 0.9d0 * dmx(k,i) dmx(i,j) = dmx(i,j) + corr denom = denom + 0.9d0 else if (dbnd(nik,mik) .le. & 0.2d0*dbnd(njk,mjk)) then if (j .gt. k) corr = 0.9d0 * dmx(j,k) if (k .gt. j) corr = 0.9d0 * dmx(k,j) dmx(i,j) = dmx(i,j) + corr denom = denom + 0.9d0 else if (dbnd(mik,nik) .ge. & 0.9d0*dbnd(njk,mjk)) then if (j .gt. k) corr = 0.5d0 * (1.0d0-dmx(j,k)) if (k .gt. j) corr = 0.5d0 * (1.0d0-dmx(k,j)) dmx(i,j) = dmx(i,j) + corr denom = denom + 0.5d0 else if (dbnd(mjk,njk) .ge. & 0.9d0*dbnd(nik,mik)) then if (i .gt. k) corr = 0.5d0 * (1.0d0-dmx(i,k)) if (k .gt. i) corr = 0.5d0 * (1.0d0-dmx(k,i)) dmx(i,j) = dmx(i,j) + corr denom = denom + 0.5d0 end if end if end do dmx(i,j) = dmx(i,j) / denom end do end do do i = 1, n-1 do j = i+1, n delta = dbnd(i,j) - dbnd(j,i) dmx(i,j) = dbnd(j,i) + delta*dmx(i,j) dmx(j,i) = dmx(i,j) end do end do c c Havel/XPLOR atom-based metrization over various distributions c else if (method.eq.'HAVEL' .or. method.eq.'PARTIAL') then do i = 1, n do j = 1, n dmx(j,i) = dbnd(j,i) end do end do do i = 1, n value(i) = random () end do call sort2 (n,value,list) gap = 0.0d0 do i = 1, n-1 k = list(i) do j = i+1, n m = list(j) fraction = random () if (method .eq. 'PARTIAL') then fraction = invbeta (alpha,beta,fraction) end if delta = abs(dbnd(k,m) - dbnd(m,k)) if (k .lt. m) then dbnd(k,m) = dbnd(m,k) + delta*fraction dbnd(m,k) = dbnd(k,m) else dbnd(k,m) = dbnd(k,m) + delta*fraction dbnd(m,k) = dbnd(k,m) end if if (i .le. npart) call trifix (k,m) if (i .gt. npart) gap = gap + delta end do end do do i = 1, n do j = 1, n swap = dmx(j,i) dmx(j,i) = dbnd(j,i) dbnd(j,i) = swap end do end do if (verbose .and. npart.lt.n-1) then write (iout,130) gap/dble((n-npart)*(n-npart-1)/2) 130 format (/,' Average Bound Gap after Partial Metrization :', & 3x,f12.4) end if c c use partial randomized pairwise distance-based metrization c else if (method.eq.'PAIRWISE' .and. percent.le.10.0d0) then npair = n*(n-1) / 2 nmetrize = nint(0.01d0*percent*dble(npair)) do i = 1, n do j = 1, n dmx(j,i) = dbnd(j,i) end do end do do i = 1, nmetrize 140 continue k = int(dble(n)*random()) + 1 m = int(dble(n)*random()) + 1 if (dbnd(k,m) .eq. dbnd(m,k)) goto 140 if (k .gt. m) then j = k k = m m = j end if fraction = random () fraction = invbeta (alpha,beta,fraction) delta = dbnd(k,m) - dbnd(m,k) dbnd(k,m) = dbnd(m,k) + delta*fraction dbnd(m,k) = dbnd(k,m) call trifix (k,m) end do gap = 0.0d0 do i = 1, n-1 do j = i, n delta = dbnd(i,j) - dbnd(j,i) if (delta .ne. 0.0d0) then gap = gap + delta fraction = random () fraction = invbeta (alpha,beta,fraction) dbnd(i,j) = dbnd(j,i) + delta*fraction dbnd(j,i) = dbnd(i,j) end if end do end do do i = 1, n do j = 1, n swap = dmx(j,i) dmx(j,i) = dbnd(j,i) dbnd(j,i) = swap end do end do if (verbose .and. nmetrize.lt.npair) then write (iout,150) gap/dble(npair-nmetrize) 150 format (/,' Average Bound Gap after Partial Metrization :', & 3x,f12.4) end if c c use randomized pairwise distance-based metrization c else if (method .eq. 'PAIRWISE') then npair = n*(n-1) / 2 nmetrize = nint(0.01d0*percent*dble(npair)) do i = 1, n do j = 1, n dmx(j,i) = dbnd(j,i) end do end do do i = 1, npair value(i) = random () end do call sort2 (npair,value,list) eps = 1.0d-10 gap = 0.0d0 do i = 1, npair index = list(i) k = int(0.5d0 * (dble(2*n+1) & - sqrt(dble(4*n*(n-1)-8*index+9))) + eps) m = n*(1-k) + k*(k+1)/2 + index fraction = random () fraction = invbeta (alpha,beta,fraction) delta = dbnd(k,m) - dbnd(m,k) dbnd(k,m) = dbnd(m,k) + delta*fraction dbnd(m,k) = dbnd(k,m) if (i .le. nmetrize) call trifix (k,m) if (i .gt. nmetrize) gap = gap + delta end do do i = 1, n do j = 1, n swap = dmx(j,i) dmx(j,i) = dbnd(j,i) dbnd(j,i) = swap end do end do if (verbose .and. nmetrize.lt.npair) then write (iout,160) gap/dble(npair-nmetrize) 160 format (/,' Average Bound Gap after Partial Metrization :', & 3x,f12.4) end if end if c c perform deallocation of some local arrays c deallocate (list) deallocate (value) c c get the time required for distance matrix generation c if (verbose) then call gettime (wall,cpu) write (iout,170) wall 170 format (/,' Time Required for Distance Matrix :',5x,f12.2, & ' seconds') end if return end c c c ############################################################### c ## ## c ## subroutine metric -- computation of the metric matrix ## c ## ## c ############################################################### c c c "metric" takes as input the trial distance matrix and computes c the metric matrix of all possible dot products between the atomic c vectors and the center of mass using the law of cosines and the c following formula for the distances to the center of mass: c c dcm(i)**2 = (1/n) * sum(j=1,n)(dist(i,j)**2) c - (1/n**2) * sum(j=NONE] : ',$) read (input,30) prmfile 30 format (a240) next = 1 call getword (prmfile,none,next) call upcase (none) if (next .eq. 1) then exist = .true. useprm = .false. else if (none.eq.'NONE' .and. next.eq.5) then exist = .true. useprm = .false. else if (prmfile(1:2) .eq. '~/') then call getenv ('HOME',prefix) prmfile = prefix(1:trimtext(prefix))// & prmfile(2:trimtext(prmfile)) end if call suffix (prmfile,'prm','old') inquire (file=prmfile,exist=exist) end if end do if (.not. exist) call fatal c c read the parameter file to get number of lines c nprm = 0 if (useprm) then iprm = freeunit () open (unit=iprm,file=prmfile,status='old') rewind (unit=iprm) do while (.true.) read (iprm,40,err=50,end=50) 40 format () nprm = nprm + 1 end do 50 continue rewind (unit=iprm) end if c c perform dynamic allocation of some global arrays c if (allocated(prmline)) deallocate (prmline) allocate (prmline(nprm)) c c reread the parameter file and store for latter use c do i = 1, nprm read (iprm,60,err=70,end=70) record 60 format (a240) prmline(i) = record end do 70 continue close (unit=iprm) c c convert underbar characters to dashes in all keywords c do i = 1, nprm next = 1 record = prmline(i) call gettext (record,keyword,next) do j = 1, next-1 if (record(j:j) .eq. '_') record(j:j) = '-' end do prmline(i) = record end do c c count and allocate memory for the parameter values c call setprm c c initialize force field control and parameter values c call initprm c c get control and parameter values from the parameter file c if (useprm) call readprm return end c c c ################################################### c ## COPYRIGHT (C) 1996 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine getref -- get structure from reference area ## c ## ## c ################################################################ c c c "getref" copies structure information from the reference area c into the standard variables for the current system structure c c subroutine getref (iref) use atomid use atoms use boxes use couple use files use refer use titles implicit none integer i,j,iref c c c retrieve the filename and title line for the structure c filename = reffile(iref) leng = refleng(iref) title = reftitle(iref) ltitle = refltitle(iref) c c retrieve the coordinates, type and connectivity of each atom c n = nref(iref) do i = 1, n name(i) = refnam(i,iref) x(i) = xref(i,iref) y(i) = yref(i,iref) z(i) = zref(i,iref) type(i) = reftyp(i,iref) n12(i) = n12ref(i,iref) do j = 1, n12(i) i12(j,i) = i12ref(j,i,iref) end do end do c c retrieve any unit cell parameters defining a periodic box c xbox = xboxref(iref) ybox = yboxref(iref) zbox = zboxref(iref) alpha = alpharef(iref) beta = betaref(iref) gamma = gammaref(iref) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine getstring -- extract double quoted string ## c ## ## c ############################################################## c c c "getstring" searches for a quoted text string within an input c character string; the region between the first and second c double quote is returned as the "text"; if the actual text is c too long, only the first part is returned c c variables and parameters: c c string input character string to be searched c text the quoted text found in the input string c next input with first position of search string; c output with the position following text c c subroutine getstring (string,text,next) use ascii implicit none integer i,j,k,m integer len,length integer size,next integer code,extent integer initial,final integer first,last integer maxascii character*(*) string character*(*) text c c c get the length of input string and output text c length = len(string(next:)) size = len(text) c c convert first two non-ascii regions to delimiting quotes c maxascii = 126 initial = next final = next + length - 1 do i = initial, final code = ichar(string(i:i)) if (code .gt. maxascii) then string(i:i) = ' ' do j = i+1, final code = ichar(string(j:j)) if (code .le. maxascii) then string(j-1:j-1) = '"' do k = j+1, final code = ichar(string(k:k)) if (code .gt. maxascii) then string(k:k) = '"' do m = k+1, final code = ichar(string(m:m)) if (code .gt. maxascii) then string(m:m) = ' ' end if end do goto 10 end if end do end if end do end if end do 10 continue c c search the string for quoted region of text characters c first = next last = 0 do i = initial, final code = ichar(string(i:i)) if (code .eq. quote) then first = i + 1 do j = first, final code = ichar(string(j:j)) if (code .eq. quote) then last = j - 1 next = j + 1 goto 20 end if end do end if end do 20 continue c c trim the actual word if it is too long to return c extent = last - first + 1 final = first + size - 1 if (extent .gt. size) last = final c c transfer the text into the return string c j = 0 do i = first, last j = j + 1 text(j:j) = string(i:i) end do do i = last+1, final j = j + 1 text(j:j) = ' ' end do return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################## c ## ## c ## subroutine gettext -- extract text from a string ## c ## ## c ########################################################## c c c "gettext" searches an input string for the first string of c non-blank characters; the region from a non-blank character c to the first space or tab is returned as "text"; if the c actual text is too long, only the first part is returned c c variables and parameters: c c string input character string to be searched c text output with the first text string found c next input with first position of search string; c output with the position following text c c subroutine gettext (string,text,next) use ascii implicit none integer i,j integer len,length integer size,next integer first,last integer code,extent integer initial,final character*(*) string character*(*) text c c c get the length of input string and output text c length = len(string(next:)) size = len(text) c c search the string for the first non-blank character c first = next last = 0 initial = next final = next + length - 1 do i = initial, final code = ichar(string(i:i)) if (code.ne.space .and. code.ne.tab) then first = i do j = i+1, final code = ichar(string(j:j)) if (code.eq.space .or. code.eq.tab) then