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) 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 call initial call getcart (ixyz) call mechanic 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 reopen the coordinates file and read the first structure c frame = 0 close (unit=ixyz) ixyz = freeunit () xyzfile = filename if (archive) then call suffix (xyzfile,'xyz','old') open (unit=ixyz,file=xyzfile,status ='old') rewind (unit=ixyz) call readxyz (ixyz) else if (binary) then call suffix (xyzfile,'dcd','old') open (unit=ixyz,file=xyzfile,form='unformatted',status ='old') rewind (unit=ixyz) first = .true. call readdcd (ixyz,first) 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 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 disk 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),valence(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',18x,'Spline Grid',/) end if j = itt(2,i) write (iout,640) i,ia,ib,ic,id,ie,tnx(j),tny(j) 640 format (i6,3x,5i6,10x,2i6) 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),valence(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 use iounit implicit none integer i,j,k,m integer ia,ib,ic integer maxang c c c perform dynamic allocation of some global arrays c maxang = 6 * n if (allocated(iang)) deallocate (iang) if (allocated(anglist)) deallocate (anglist) if (allocated(balist)) deallocate (balist) allocate (iang(4,maxang)) allocate (anglist(maxval*(maxval-1)/2,n)) allocate (balist(2,maxang)) c c loop over all atoms, storing the atoms 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 if (nangle .gt. maxang) then write (iout,10) 10 format (/,' ANGLES -- Too many Bond Angles;', & ' Increase MAXANG') call fatal end if 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 valence valence number 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 story descriptive type for each atom in system c c module atomid use sizes implicit none integer tag(maxatm) integer class(maxatm) integer atomic(maxatm) integer valence(maxatm) real*8 mass(maxatm) character*3 name(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') write (ibar,190) nfrma,tempa,titlea(1:ltitlea) 190 format (i8,f10.2,2x,a) do i = 1, nfrma if (vola(i) .eq. 0.0d0) then write (ibar,200) i,ua0(i),ua1(i) 200 format (i8,2x,2f18.4) else write (ibar,210) i,ua0(i),ua1(i),vola(i) 210 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,220) 220 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,230,err=250,end=250) record 230 format (a240) if (record(1:18) .eq. ' Current Potential') then string = record(19:240) read (string,*,err=240,end=240) ub1(i) abort = .false. end if 240 continue end do 250 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,260) i 260 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,270) 270 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,280) i,ub0(i),ub1(i),ub0(i)-ub1(i) 280 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 write (ibar,290) nfrmb,tempb,titleb(1:ltitleb) 290 format (i8,f10.2,2x,a) do i = 1, nfrmb if (volb(i) .eq. 0.0d0) then write (ibar,300) i,ub0(i),ub1(i) 300 format (i8,2x,2f18.4) else write (ibar,310) i,ub0(i),ub1(i),volb(i) 310 format (i8,2x,3f18.4) end if end do close (unit=ibar) write (iout,320) barfile(1:trimtext(barfile)) 320 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) titlea(1:ltitlea) 260 format (/,' Simulation Trajectory A and Thermodynamic', & ' State 0 : ',//,' ',a) write (iout,270) nfrma,tempa 270 format (' Number of Frames :',4x,i8,/,' Temperature :',7x,f10.2) write (iout,280) titleb(1:ltitleb) 280 format (/,' Simulation Trajectory B and Thermodynamic', & ' State 1 : ',//,' ',a) write (iout,290) nfrmb,tempb 290 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,300) 300 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,310) cfore,stdcf 310 format (' Free Energy via Forward FEP',9x,f12.4, & ' +/-',f9.4,' Kcal/mol') write (iout,320) cback,stdcb 320 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,330) 330 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,340) iter,cnew 340 format (' BAR Iteration',i4,19x,f12.4,' Kcal/mol') if (delta .lt. eps) then done = .true. write (iout,350) cnew,stdev 350 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,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 (/,' Free Energy via BAR Iteration',7x,f12.4, & ' +/-',f9.4,' Kcal/mol') end if if (iter.ge.maxiter .and. .not.done) then done = .true. write (iout,380) maxiter 380 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,390) cnew,stdev 390 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,400) 400 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,410) uave0,stdev0 410 format (' Average Energy for State 0',10x,f12.4, & ' +/-',f9.4,' Kcal/mol') write (iout,420) uave1,stdev1 420 format (' Average Energy for State 1',10x,f12.4, & ' +/-',f9.4,' Kcal/mol') if (epv .ne. 0.0d0) then write (iout,430) epv,stdpv 430 format (' PdV Work Term for 1 Atm',13x,f12.4, & ' +/-',f9.4,' Kcal/mol') end if write (iout,440) hdir,stdev 440 format (' Enthalpy via Direct Estimate',8x,f12.4, & ' +/-',f9.4,' Kcal/mol') c c calculate the enthalpy via thermodynamic perturbation c write (iout,450) 450 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,460) hfore,stdhf 460 format (' Enthalpy via Forward FEP',12x,f12.4, & ' +/-',f9.4,' Kcal/mol') write (iout,470) sfore 470 format (' Entropy via Forward FEP',13x,f12.6,' Kcal/mol/K') write (iout,480) -tempa*sfore 480 format (' Forward FEP -T*dS Value',13x,f12.4,' Kcal/mol') write (iout,490) hback,stdhb 490 format (/,' Enthalpy via Backward FEP',11x,f12.4, & ' +/-',f9.4,' Kcal/mol') write (iout,500) sback 500 format (' Entropy via Backward FEP',12x,f12.6,' Kcal/mol/K') write (iout,510) -tempb*sback 510 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,520) 520 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,530) hbar,stdev 530 format (' Enthalpy via BAR Estimate',11x,f12.4 & ' +/-',f9.4,' Kcal/mol') write (iout,540) sbar 540 format (' Entropy via BAR Estimate',12x,f12.6,' Kcal/mol/K') write (iout,550) -tsbar 550 format (' BAR Estimate of -T*dS',15x,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 use iounit implicit none integer i,j,k integer ia,ib,ic,id,ie integer maxbitor c c c perform dynamic allocation of some global arrays c maxbitor = 54 * n if (allocated(ibitor)) deallocate (ibitor) allocate (ibitor(5,maxbitor)) c c loop over all angles, storing the atoms 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 if (nbitor .gt. maxbitor) then write (iout,10) 10 format (/,' BITORS -- Too many Adjacent', & ' Torsions; Increase MAXBITOR') call fatal end if 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 use iounit implicit none integer i,j,k,m integer maxbnd c c c perform dynamic allocation of some global arrays c maxbnd = 4 * n if (allocated(ibnd)) deallocate (ibnd) if (allocated(bndlist)) deallocate (bndlist) allocate (ibnd(2,maxbnd)) allocate (bndlist(maxval,n)) c c loop over all atoms, storing the atoms 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 if (nbond .gt. maxbnd) then write (iout,10) 10 format (/,' BONDS -- Too many Bonds; Increase', & ' MAXBND') call fatal end if ibnd(1,nbond) = i ibnd(2,nbond) = k bndlist(j,i) = nbond do m = 1, n12(k) if (i .eq. i12(m,k)) then bndlist(m,k) = nbond goto 20 end if end do 20 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 c module bound implicit none real*8 polycut real*8 polycut2 logical use_bounds logical use_replica logical use_polymer 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, an internal mirror plane or 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-1 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 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', & ' [0.01] : ',$) read (input,40) grdmin 40 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.01d0 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 if (use(i)) then nvar = nvar + 1 xx(nvar) = x(i) nvar = nvar + 1 xx(nvar) = y(i) nvar = nvar + 1 xx(nvar) = z(i) end if 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 if (use(i)) then nvar = nvar + 1 x(i) = xx(nvar) nvar = nvar + 1 y(i) = xx(nvar) nvar = nvar + 1 z(i) = xx(nvar) end if end do c c compute the final function and RMS gradient values c call gradient (epot,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 usage implicit none integer i integer nvar integer nrsd real*8 epot real*8 xx(*) real*8 rsd(*) real*8, allocatable :: derivs(:,:) c c c translate optimization parameters to atomic coordinates c nvar = 0 do i = 1, n if (use(i)) then nvar = nvar + 1 x(i) = xx(nvar) nvar = nvar + 1 y(i) = xx(nvar) nvar = nvar + 1 z(i) = xx(nvar) end if end do 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 store the gradient components as the residual vector c nvar = 0 do i = 1, n if (use(i)) then nvar = nvar + 1 rsd(nvar) = derivs(1,i) nvar = nvar + 1 rsd(nvar) = derivs(2,i) nvar = nvar + 1 rsd(nvar) = derivs(3,i) end if 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 a disk 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,nhydro 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 nhydro = 0 if (answer .eq. 'Y') then do j = 1, 4 letter = name(i12(j,i))(1:1) if (letter .eq. 'H') nhydro = nhydro + 1 end do end if if (nhydro .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 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 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 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 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 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 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 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 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 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 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 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 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(ii),pchg(kk),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(ii),pchg(kk),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 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 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 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 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 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 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,20) prmfile 20 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 and store it for latter use c nprm = 0 if (useprm) then iprm = freeunit () open (unit=iprm,file=prmfile,status='old') rewind (unit=iprm) do while (.true.) read (iprm,30,err=50,end=50) record 30 format (a240) nprm = nprm + 1 prmline(nprm) = record if (nprm .ge. maxprm) then write (iout,40) 40 format (/,' GETPRM -- Parameter File Too Large;', & ' Increase MAXPRM') call fatal end if end do 50 continue close (unit=iprm) end if 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 last = j - 1 next = j goto 10 end if end do last = final next = last + 1 end if end do 10 continue c c trim the actual text if it is too long to return c extent = next - first 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 = next, 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 getword -- extract first word from a string ## c ## ## c ################################################################ c c c "getword" searches an input string for the first alphabetic c character (A-Z or a-z); the region from this first character c to the first blank space or separator is returned as a "word"; c if the actual word is too long, only the first part is returned c c variables and parameters: c c string input character string to be searched c word output with the first word in the string c next input with first position of search string; c output with the position following word c c subroutine getword (string,word,next) use ascii implicit none integer i,j integer len,length integer size,next integer first,last integer code,extent integer initial,final character*1 letter character*(*) string character*(*) word c c c get the length of input string and output word c length = len(string(next:)) size = len(word) c c search the string for the first alphabetic character c first = next last = 0 initial = next final = next + length - 1 do i = initial, final letter = string(i:i) if ((letter.ge.'A' .and. letter.le.'Z') .or. & (letter.ge.'a' .and. letter.le.'z')) then first = i do j = i+1, final code = ichar(string(j:j)) if (code.eq.space .or. code.eq.tab .or. & code.eq.comma .or. code.eq.colon .or. & code.eq.semicolon) then last = j - 1 next = j goto 10 end if end do last = final next = last + 1 end if end do 10 continue c c trim the actual word if it is too long to return c extent = next - first final = first + size - 1 if (extent .gt. size) last = final c c transfer the word into the return string c j = 0 do i = first, last j = j + 1 word(j:j) = string(i:i) end do do i = next, final j = j + 1 word(j:j) = ' ' end do c c skip over the next character when it is a separator c code = ichar(string(next:next)) if (code.eq.tab .or. code.eq.comma .or. & code.eq.colon .or. code.eq.semicolon) then next = next + 1 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 getxyz -- get XYZ-format coordinates file ## c ## ## c ############################################################## c c c "getxyz" asks for a Cartesian coordinate file name, c then reads in the coordinates file c c subroutine getxyz use files use inform use iounit use output implicit none integer ixyz,nask integer freeunit logical exist character*240 xyzfile c c c try to get a filename from the command line arguments c call nextarg (xyzfile,exist) if (exist) then call basefile (xyzfile) call suffix (xyzfile,'xyz','old') inquire (file=xyzfile,exist=exist) end if c c ask for the user specified input structure filename c nask = 0 do while (.not.exist .and. nask.lt.maxask) nask = nask + 1 write (iout,10) 10 format (/,' Enter Cartesian Coordinate File Name : ',$) read (input,20) xyzfile 20 format (a240) call basefile (xyzfile) call suffix (xyzfile,'xyz','old') inquire (file=xyzfile,exist=exist) end do if (.not. exist) call fatal c c first open and then read the Cartesian coordinates file c filename = xyzfile coordtype = 'CARTESIAN' ixyz = freeunit () open (unit=ixyz,file=xyzfile,status='old') rewind (unit=ixyz) call readxyz (ixyz) close (unit=ixyz) c c quit if the Cartesian coordinates file contains no atoms c if (abort) then write (iout,30) 30 format (/,' GETXYZ -- Cartesian Coordinate File', & ' was not Read Correctly') call fatal end if return end c c c ############################################################### c ## COPYRIGHT (C) 2011 by John Chodera & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################### c c ################################################################ c ## ## c ## subroutine ghmcstep -- generalized hybrid MC time step ## c ## ## c ################################################################ c c c "ghmcstep" performs a single stochastic dynamics time step via c the generalized hybrid Monte Carlo (GHMC) algorithm to ensure c exact sampling from the Boltzmann density c c literature references: c c T. Lelievre, M. Rousset and G. Stoltz, "Free Energy Computations: c A Mathematical Perspective", Imperial College Press, London, 2010, c Algorithm 2.11 c c T. Lelievre, M. Rousset and G. Stoltz, "Langevin Dynamics c with Constraints and Computation of Free Energy Differences", c Mathematics of Computation, 81, 2071-2125 (2012) [eq 3.16-3.18] c c original version written by John D. Chodera, University of c California, Berkeley, November 2010 c c subroutine ghmcstep (istep,dt) use atoms use atomid use bath use freeze use iounit use moldyn use units use usage use virial implicit none integer i,j,k integer istep integer nrej real*8 dt,dt_2 real*8 epot,etot real*8 epold,etold real*8 eksum,de real*8 temp,pres real*8 random,ratio 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 :: vold(:,:) real*8, allocatable :: derivs(:,:) real*8, allocatable :: alpha(:,:) real*8, allocatable :: beta(:,:) external random save epot,nrej c c c compute the half time step value c dt_2 = 0.5d0 * dt c c perform dynamic allocation of some local arrays c allocate (alpha(3,n)) allocate (beta(3,n)) c c evolve velocities according to midpoint Euler for half-step c call ghmcterm (istep,dt,alpha,beta) do i = 1, nuse k = iuse(i) do j = 1, 3 v(j,k) = v(j,k)*alpha(j,k) + beta(j,k) end do end do c c accumulate the kinetic energy and store the energy values c call kinetic (eksum,ekin,temp) epold = epot etold = eksum + epot c c perform dynamic allocation of some local arrays c allocate (xold(n)) allocate (yold(n)) allocate (zold(n)) allocate (vold(3,n)) allocate (derivs(3,n)) c c store the current positions and velocities, find half-step c velocities and full-step positions via Verlet recursion c do i = 1, nuse k = iuse(i) do j = 1, 3 vold(j,k) = v(j,k) aalt(j,k) = a(j,k) v(j,k) = v(j,k) + a(j,k)*dt_2 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 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 current values as previous energies for first step c if (istep .eq. 1) then nrej = 0 epold = epot etold = eksum + epot end if 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 find the constraint-corrected full-step velocities c if (use_rattle) call rattle2 (dt) c c determine the kinetic energy, temperature and total energy c call kinetic (eksum,ekin,temp) etot = eksum + epot c c accept or reject according to Metropolis scheme; c note that velocities are reversed upon rejection c de = (etot-etold) / (gasconst*kelvin) if (de.gt.0.0d0 .and. random().gt.exp(-de)) then nrej = nrej + 1 ratio = 1.0d0 - dble(nrej)/dble(istep) write (iout,10) ratio 10 format (' GHMC Step Rejected',6x,'Acceptance Ratio',f8.3) epot = epold do i = 1, nuse k = iuse(i) x(k) = xold(k) y(k) = yold(k) z(k) = zold(k) do j = 1, 3 v(j,k) = -vold(j,k) a(j,k) = aalt(j,k) end do end do end if c c evolve velocities according to midpoint Euler for half-step c call ghmcterm (istep,dt,alpha,beta) do i = 1, nuse k = iuse(i) do j = 1, 3 v(j,k) = v(j,k)*alpha(j,k) + beta(j,k) end do end do c c perform deallocation of some local arrays c deallocate (xold) deallocate (yold) deallocate (zold) deallocate (vold) deallocate (derivs) deallocate (alpha) deallocate (beta) c c update 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) 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) return end c c c ################################################################## c ## ## c ## subroutine ghmcterm -- GHMC friction & fluctuation terms ## c ## ## c ################################################################## c c c "ghmcterm" finds the friction and fluctuation terms needed c to update velocities during GHMC stochastic dynamics c c subroutine ghmcterm (istep,dt,alpha,beta) use atoms use atomid use bath use stodyn use units use usage implicit none integer i,j,k integer istep real*8 dt,dt_2,dt_4 real*8 gamma,sigma real*8 normal real*8 alpha(3,*) real*8 beta(3,*) logical first external normal save first data first / .true. / c c c perform dynamic allocation of some global arrays c if (first) then first = .false. if (.not. allocated(fgamma)) allocate (fgamma(n)) c c set the atomic friction coefficients to the global value c do i = 1, n fgamma(i) = friction * mass(i) end do end if c c set the value of the friction coefficient for each atom c if (use_sdarea) call sdarea (istep) c c get the viscous friction and fluctuation terms for GHMC c dt_2 = 0.5d0 * dt dt_4 = 0.25d0 * dt do i = 1, nuse k = iuse(i) gamma = dt_4 * fgamma(k) / mass(k) sigma = sqrt(2.0d0*boltzmann*kelvin*fgamma(k)) do j = 1, 3 alpha(j,k) = (1.0d0-gamma) / (1.0d0+gamma) beta(j,k) = normal() * sqrt(dt_2) * sigma & / ((1.0d0+gamma)*mass(k)) end do end do return end c c c ################################################################ c ## COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ################################################################ c ## ## c ## module gkstuf -- generalized Kirkwood solvation values ## c ## ## c ################################################################ c c c gkc tuning parameter exponent in the f(GB) function c c module gkstuf use sizes implicit none real*8 gkc save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine gradient -- find energy & gradient components ## c ## ## c ################################################################## c c c "gradient" calls subroutines to calculate the potential energy c and first derivatives with respect to Cartesian coordinates c c subroutine gradient (energy,derivs) use atoms use couple use deriv use energi use inform use inter use iounit use limits use potent use rigid use vdwpot use virial implicit none integer i,j real*8 energy,cutoff real*8 derivs(3,*) 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(desum)) then if (size(desum) .lt. 3*n) then deallocate (desum) deallocate (deb) deallocate (dea) deallocate (deba) deallocate (deub) deallocate (deaa) deallocate (deopb) deallocate (deopd) deallocate (deid) deallocate (deit) deallocate (det) deallocate (dept) deallocate (debt) deallocate (deat) deallocate (dett) deallocate (dev) deallocate (der) deallocate (dedsp) deallocate (dec) deallocate (decd) deallocate (ded) deallocate (dem) deallocate (dep) deallocate (dect) deallocate (derxf) deallocate (des) deallocate (delf) deallocate (deg) deallocate (dex) end if end if if (.not. allocated(desum)) then allocate (desum(3,n)) allocate (deb(3,n)) allocate (dea(3,n)) allocate (deba(3,n)) allocate (deub(3,n)) allocate (deaa(3,n)) allocate (deopb(3,n)) allocate (deopd(3,n)) allocate (deid(3,n)) allocate (deit(3,n)) allocate (det(3,n)) allocate (dept(3,n)) allocate (debt(3,n)) allocate (deat(3,n)) allocate (dett(3,n)) allocate (dev(3,n)) allocate (der(3,n)) allocate (dedsp(3,n)) allocate (dec(3,n)) allocate (decd(3,n)) allocate (ded(3,n)) allocate (dem(3,n)) allocate (dep(3,n)) allocate (dect(3,n)) allocate (derxf(3,n)) allocate (des(3,n)) allocate (delf(3,n)) allocate (deg(3,n)) allocate (dex(3,n)) end if c c zero out each of the first derivative components c do i = 1, n do j = 1, 3 derivs(j,i) = 0.0d0 desum(j,i) = 0.0d0 deb(j,i) = 0.0d0 dea(j,i) = 0.0d0 deba(j,i) = 0.0d0 deub(j,i) = 0.0d0 deaa(j,i) = 0.0d0 deopb(j,i) = 0.0d0 deopd(j,i) = 0.0d0 deid(j,i) = 0.0d0 deit(j,i) = 0.0d0 det(j,i) = 0.0d0 dept(j,i) = 0.0d0 debt(j,i) = 0.0d0 deat(j,i) = 0.0d0 dett(j,i) = 0.0d0 dev(j,i) = 0.0d0 der(j,i) = 0.0d0 dedsp(j,i) = 0.0d0 dec(j,i) = 0.0d0 decd(j,i) = 0.0d0 ded(j,i) = 0.0d0 dem(j,i) = 0.0d0 dep(j,i) = 0.0d0 dect(j,i) = 0.0d0 derxf(j,i) = 0.0d0 des(j,i) = 0.0d0 delf(j,i) = 0.0d0 deg(j,i) = 0.0d0 dex(j,i) = 0.0d0 end do end do c c zero out the virial and the intermolecular energy c do i = 1, 3 do j = 1, 3 vir(j,i) = 0.0d0 end do end do einter = 0.0d0 c c skip gradient calculation when using GPU coprocessor c if (gpucard .ne. 0) return c c update the pairwise interaction neighbor lists c if (use_list) call nblist c c remove any previous use of the replicates method c cutoff = 0.0d0 call replica (cutoff) 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 and gradient routines c if (use_bond) call ebond1 if (use_angle) call eangle1 if (use_strbnd) call estrbnd1 if (use_urey) call eurey1 if (use_angang) call eangang1 if (use_opbend) call eopbend1 if (use_opdist) call eopdist1 if (use_improp) call eimprop1 if (use_imptor) call eimptor1 if (use_tors) call etors1 if (use_pitors) call epitors1 if (use_strtor) call estrtor1 if (use_angtor) call eangtor1 if (use_tortor) call etortor1 c c call the electrostatic energy and gradient routines c if (use_charge) call echarge1 if (use_chgdpl) call echgdpl1 if (use_dipole) call edipole1 if (use_mpole) call empole1 if (use_polar) call epolar1 if (use_chgtrn) call echgtrn1 if (use_rxnfld) call erxnfld1 c c call the van der Waals energy and gradient routines c if (use_vdw) then if (vdwtyp .eq. 'LENNARD-JONES') call elj1 if (vdwtyp .eq. 'BUCKINGHAM') call ebuck1 if (vdwtyp .eq. 'MM3-HBOND') call emm3hb1 if (vdwtyp .eq. 'BUFFERED-14-7') call ehal1 if (vdwtyp .eq. 'GAUSSIAN') call egauss1 end if if (use_repel) call erepel1 if (use_disp) call edisp1 c c call any miscellaneous energy and gradient routines c if (use_solv) call esolv1 if (use_metal) call emetal1 if (use_geom) call egeom1 if (use_extra) call extra1 c c sum up to get the total energy and first derivatives 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 do i = 1, n do j = 1, 3 desum(j,i) = deb(j,i) + dea(j,i) + deba(j,i) & + deub(j,i) + deaa(j,i) + deopb(j,i) & + deopd(j,i) + deid(j,i) + deit(j,i) & + det(j,i) + dept(j,i) + debt(j,i) & + deat(j,i) + dett(j,i) + dev(j,i) & + der(j,i) + dedsp(j,i) + dec(j,i) & + decd(j,i) + ded(j,i) + dem(j,i) & + dep(j,i) + dect(j,i) + derxf(j,i) & + des(j,i) + delf(j,i) & + deg(j,i) + dex(j,i) derivs(j,i) = desum(j,i) end do 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 (/,' GRADIENT -- Illegal Value for the Total', & ' Potential Energy') call fatal end if return end c c c ############################################################## c ## COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ############################################################### c ## ## c ## subroutine gradrgd -- energy & gradient of rigid body ## c ## ## c ############################################################### c c c "gradrgd" calls subroutines to calculate the potential energy c and first derivatives with respect to rigid body coordinates c c subroutine gradrgd (energy,derivs) use atoms use group use rigid implicit none integer i,j,k integer init,stop real*8 energy real*8 xcm,ycm,zcm real*8 xterm,yterm,zterm real*8 phi,cphi,sphi real*8 theta,ctheta,stheta real*8 ephi(3),etheta(3) real*8 epsi(3),tau(3) real*8 derivs(6,*) real*8, allocatable :: g(:,:) c c c zero out the total of rigid body derivative components c do i = 1, ngrp do j = 1, 6 derivs(j,i) = 0.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (g(3,n)) c c calculate the energy and Cartesian first derivatives c call gradient (energy,g) c c compute the rigid body gradient components for each group c do i = 1, ngrp init = igrp(1,i) stop = igrp(2,i) xcm = rbc(1,i) ycm = rbc(2,i) zcm = rbc(3,i) phi = rbc(4,i) theta = rbc(5,i) cphi = cos(phi) sphi = sin(phi) ctheta = cos(theta) stheta = sin(theta) c c get unit vectors along the phi, theta and psi rotation axes c ephi(1) = 0.0d0 ephi(2) = 0.0d0 ephi(3) = 1.0d0 etheta(1) = -sphi etheta(2) = cphi etheta(3) = 0.0d0 epsi(1) = ctheta * cphi epsi(2) = ctheta * sphi epsi(3) = -stheta c c find the rigid body gradients for translations c do j = init, stop k = kgrp(j) derivs(1,i) = derivs(1,i) + g(1,k) derivs(2,i) = derivs(2,i) + g(2,k) derivs(3,i) = derivs(3,i) + g(3,k) end do c c accumulate the moment arm along each axis of rotation c do j = 1, 3 tau(j) = 0.0d0 end do do j = init, stop k = kgrp(j) xterm = x(k) - xcm yterm = y(k) - ycm zterm = z(k) - zcm tau(1) = tau(1) + yterm*g(3,k) - zterm*g(2,k) tau(2) = tau(2) + zterm*g(1,k) - xterm*g(3,k) tau(3) = tau(3) + xterm*g(2,k) - yterm*g(1,k) end do c c find the rigid body gradients for rotations c do j = 1, 3 derivs(4,i) = derivs(4,i) + tau(j)*ephi(j) derivs(5,i) = derivs(5,i) + tau(j)*etheta(j) derivs(6,i) = derivs(6,i) + tau(j)*epsi(j) end do end do c c perform deallocation of some local arrays c deallocate (g) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################### c ## ## c ## subroutine gradrot -- energy and torsional derivs ## c ## ## c ########################################################### c c c "gradrot" calls subroutines to calculate the potential c energy and its torsional first derivatives c c subroutine gradrot (energy,derivs) use atoms use deriv use domega use omega use potent use rotbnd implicit none integer i,j,k integer base,partner real*8 energy,norm real*8 xatom,yatom,zatom real*8 xdist,ydist,zdist real*8 xterm,yterm,zterm real*8 derivs(*) real*8, allocatable :: g(:,:) c c c perform dynamic allocation of some global arrays c if (allocated(tesum)) then if (size(tesum) .lt. nomega) then deallocate (tesum) deallocate (teb) deallocate (tea) deallocate (teba) deallocate (teub) deallocate (teaa) deallocate (teopb) deallocate (teopd) deallocate (teid) deallocate (teit) deallocate (tet) deallocate (tept) deallocate (tebt) deallocate (teat) deallocate (tett) deallocate (tev) deallocate (ter) deallocate (tedsp) deallocate (tec) deallocate (tecd) deallocate (ted) deallocate (tem) deallocate (tep) deallocate (tect) deallocate (terxf) deallocate (tes) deallocate (telf) deallocate (teg) deallocate (tex) end if end if if (.not. allocated(tesum)) then allocate (tesum(nomega)) allocate (teb(nomega)) allocate (tea(nomega)) allocate (teba(nomega)) allocate (teub(nomega)) allocate (teaa(nomega)) allocate (teopb(nomega)) allocate (teopd(nomega)) allocate (teid(nomega)) allocate (teit(nomega)) allocate (tet(nomega)) allocate (tept(nomega)) allocate (tebt(nomega)) allocate (teat(nomega)) allocate (tett(nomega)) allocate (tev(nomega)) allocate (ter(nomega)) allocate (tedsp(nomega)) allocate (tec(nomega)) allocate (tecd(nomega)) allocate (ted(nomega)) allocate (tem(nomega)) allocate (tep(nomega)) allocate (tect(nomega)) allocate (terxf(nomega)) allocate (tes(nomega)) allocate (telf(nomega)) allocate (teg(nomega)) allocate (tex(nomega)) end if c c zero out individual components of torsional derivatives c do i = 1, nomega derivs(i) = 0.0d0 tesum(i) = 0.0d0 teb(i) = 0.0d0 tea(i) = 0.0d0 teba(i) = 0.0d0 teub(i) = 0.0d0 teaa(i) = 0.0d0 teopb(i) = 0.0d0 teopd(i) = 0.0d0 teid(i) = 0.0d0 teit(i) = 0.0d0 tet(i) = 0.0d0 tept(i) = 0.0d0 tebt(i) = 0.0d0 teat(i) = 0.0d0 tett(i) = 0.0d0 tev(i) = 0.0d0 ter(i) = 0.0d0 tedsp(i) = 0.0d0 tec(i) = 0.0d0 tecd(i) = 0.0d0 ted(i) = 0.0d0 tem(i) = 0.0d0 tep(i) = 0.0d0 tect(i) = 0.0d0 terxf(i) = 0.0d0 tes(i) = 0.0d0 telf(i) = 0.0d0 teg(i) = 0.0d0 tex(i) = 0.0d0 end do c c perform dynamic allocation of some local arrays c allocate (g(3,n)) c c calculate the energy and Cartesian first derivatives c call gradient (energy,g) c c perform deallocation of some local arrays c deallocate (g) c c transform Cartesian derivatives to torsional space c do i = 1, nomega base = iomega(1,i) partner = iomega(2,i) call rotlist (base,partner) xdist = x(base) - x(partner) ydist = y(base) - y(partner) zdist = z(base) - z(partner) norm = sqrt(xdist**2 + ydist**2 + zdist**2) xdist = xdist / norm ydist = ydist / norm zdist = zdist / norm do j = 1, nrot k = rot(j) xatom = x(k) - x(base) yatom = y(k) - y(base) zatom = z(k) - z(base) xterm = ydist*zatom - zdist*yatom yterm = zdist*xatom - xdist*zatom zterm = xdist*yatom - ydist*xatom teb(i) = teb(i) + deb(1,k)*xterm + deb(2,k)*yterm & + deb(3,k)*zterm tea(i) = tea(i) + dea(1,k)*xterm + dea(2,k)*yterm & + dea(3,k)*zterm teba(i) = teba(i) + deba(1,k)*xterm + deba(2,k)*yterm & + deba(3,k)*zterm teub(i) = teub(i) + deub(1,k)*xterm + deub(2,k)*yterm & + deub(3,k)*zterm teaa(i) = teaa(i) + deaa(1,k)*xterm + deaa(2,k)*yterm & + deaa(3,k)*zterm teopb(i) = teopb(i) + deopb(1,k)*xterm + deopb(2,k)*yterm & + deopb(3,k)*zterm teopd(i) = teopd(i) + deopd(1,k)*xterm + deopd(2,k)*yterm & + deopd(3,k)*zterm teid(i) = teid(i) + deid(1,k)*xterm + deid(2,k)*yterm & + deid(3,k)*zterm teit(i) = teit(i) + deit(1,k)*xterm + deit(2,k)*yterm & + deit(3,k)*zterm tet(i) = tet(i) + det(1,k)*xterm + det(2,k)*yterm & + det(3,k)*zterm tept(i) = tept(i) + dept(1,k)*xterm + dept(2,k)*yterm & + dept(3,k)*zterm tebt(i) = tebt(i) + debt(1,k)*xterm + debt(2,k)*yterm & + debt(3,k)*zterm teat(i) = teat(i) + deat(1,k)*xterm + deat(2,k)*yterm & + deat(3,k)*zterm tett(i) = tett(i) + dett(1,k)*xterm + dett(2,k)*yterm & + dett(3,k)*zterm tev(i) = tev(i) + dev(1,k)*xterm + dev(2,k)*yterm & + dev(3,k)*zterm ter(i) = ter(i) + der(1,k)*xterm + der(2,k)*yterm & + der(3,k)*zterm tedsp(i) = tedsp(i) + dedsp(1,k)*xterm + dedsp(2,k)*yterm & + dedsp(3,k)*zterm tec(i) = tec(i) + dec(1,k)*xterm + dec(2,k)*yterm & + dec(3,k)*zterm tecd(i) = tecd(i) + decd(1,k)*xterm + decd(2,k)*yterm & + decd(3,k)*zterm ted(i) = ted(i) + ded(1,k)*xterm + ded(2,k)*yterm & + ded(3,k)*zterm tem(i) = tem(i) + dem(1,k)*xterm + dem(2,k)*yterm & + dem(3,k)*zterm tep(i) = tep(i) + dep(1,k)*xterm + dep(2,k)*yterm & + dep(3,k)*zterm tect(i) = tect(i) + dect(1,k)*xterm + dect(2,k)*yterm & + dect(3,k)*zterm terxf(i) = terxf(i) + derxf(1,k)*xterm + derxf(2,k)*yterm & + derxf(3,k)*zterm tes(i) = tes(i) + des(1,k)*xterm + des(2,k)*yterm & + des(3,k)*zterm telf(i) = telf(i) + delf(1,k)*xterm + delf(2,k)*yterm & + delf(3,k)*zterm teg(i) = teg(i) + deg(1,k)*xterm + deg(2,k)*yterm & + deg(3,k)*zterm tex(i) = tex(i) + dex(1,k)*xterm + dex(2,k)*yterm & + dex(3,k)*zterm end do end do c c sum up to give the total torsional first derivatives c do i = 1, nomega tesum(i) = teb(i) + tea(i) + teba(i) + teub(i) + teaa(i) & + teopb(i) + teopd(i) + teid(i) + teit(i) & + tet(i) + tept(i) + tebt(i) + teat(i) + tett(i) & + tev(i) + ter(i) + tedsp(i) + tec(i) + tecd(i) & + ted(i) + tem(i) + tep(i) + tect(i) + terxf(i) & + tes(i) + telf(i) + teg(i) + tex(i) derivs(i) = tesum(i) end do return end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module group -- partitioning of system into atom groups ## c ## ## c ################################################################# c c c ngrp total number of atom groups in the system c kgrp contiguous list of the atoms in each group c grplist number of the group to which each atom belongs c igrp first and last atom of each group in the list c grpmass total mass of all the atoms in each group c wgrp weight for each set of group-group interactions c use_group flag to use partitioning of system into groups c use_intra flag to include only intragroup interactions c use_inter flag to include only intergroup interactions c c module group implicit none integer ngrp integer, allocatable :: kgrp(:) integer, allocatable :: grplist(:) integer, allocatable :: igrp(:,:) real*8, allocatable :: grpmass(:) real*8, allocatable :: wgrp(:,:) logical use_group logical use_intra logical use_inter save end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine groups -- group membership of set of atoms ## c ## ## c ############################################################### c c c "groups" tests a set of atoms to see if all are members of a c single atom group or a pair of atom groups; if so, then the c correct intra- or intergroup weight is assigned c c note the default group-based interaction weight is 1.0; only c interactions involving two or fewer groups can be scaled c c subroutine groups (proceed,weigh,ia,ib,ic,id,ie,ig) use group implicit none integer ia,ib,ic integer id,ie,ig integer iga,igb,igc integer igd,ige,igg integer nset integer gmax,gmin real*8 weigh logical proceed c c c determine the number of atoms in the set to be compared c nset = 0 weigh = 1.0d0 if (ig .ne. 0) then nset = 6 else if (ie .ne. 0) then nset = 5 else if (id .ne. 0) then nset = 4 else if (ic .ne. 0) then nset = 3 else if (ib .ne. 0) then nset = 2 else if (ia .ne. 0) then nset = 1 end if c c check group membership for a set containing one atom c if (nset .eq. 1) then iga = grplist(ia) weigh = wgrp(iga,iga) c c check group membership for a set containing two atoms c else if (nset .eq. 2) then iga = grplist(ia) igb = grplist(ib) weigh = wgrp(iga,igb) c c check group membership for a set containing three atoms c else if (nset .eq. 3) then iga = grplist(ia) igb = grplist(ib) igc = grplist(ic) if (iga.eq.igb .or. igb.eq.igc) then weigh = wgrp(iga,igc) else if (iga .eq. igc) then weigh = wgrp(iga,igb) end if c c check group membership for a set containing four atoms c else if (nset .eq. 4) then iga = grplist(ia) igb = grplist(ib) igc = grplist(ic) igd = grplist(id) gmin = min(iga,igb,igc,igd) gmax = max(iga,igb,igc,igd) if ((iga.eq.gmin .or. iga.eq.gmax) .and. & (igb.eq.gmin .or. igb.eq.gmax) .and. & (igc.eq.gmin .or. igc.eq.gmax) .and. & (igd.eq.gmin .or. igd.eq.gmax)) weigh = wgrp(gmin,gmax) c c check group membership for a set containing five atoms c else if (nset .eq. 5) then iga = grplist(ia) igb = grplist(ib) igc = grplist(ic) igd = grplist(id) ige = grplist(ie) gmin = min(iga,igb,igc,igd,ige) gmax = max(iga,igb,igc,igd,ige) if ((iga.eq.gmin .or. iga.eq.gmax) .and. & (igb.eq.gmin .or. igb.eq.gmax) .and. & (igc.eq.gmin .or. igc.eq.gmax) .and. & (igd.eq.gmin .or. igd.eq.gmax) .and. & (ige.eq.gmin .or. ige.eq.gmax)) weigh = wgrp(gmin,gmax) c c check group membership for a set containing five atoms c else if (nset .eq. 6) then iga = grplist(ia) igb = grplist(ib) igc = grplist(ic) igd = grplist(id) ige = grplist(ie) igg = grplist(ig) gmin = min(iga,igb,igc,igd,ige,igg) gmax = max(iga,igb,igc,igd,ige,igg) if ((iga.eq.gmin .or. iga.eq.gmax) .and. & (igb.eq.gmin .or. igb.eq.gmax) .and. & (igc.eq.gmin .or. igc.eq.gmax) .and. & (igd.eq.gmin .or. igd.eq.gmax) .and. & (ige.eq.gmin .or. ige.eq.gmax) .and. & (igg.eq.gmin .or. igg.eq.gmax)) weigh = wgrp(gmin,gmax) end if c c interaction will be used if its group has nonzero weight c if (weigh .eq. 0.0d0) then proceed = .false. else proceed = .true. end if return end c c c ################################################### c ## COPYRIGHT (C) 2001 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine grpline -- test atom groups for linearity ## c ## ## c ############################################################## c c c "grpline" tests each atom group for linearity of the sites c contained in the group c c subroutine grpline use atomid use atoms use group use rgddyn implicit none integer i,j,k,size integer start,stop real*8 xx,yy,zz real*8 x2,y2,z2 real*8 eps,det real*8 weigh real*8 rcm(3) real*8 inert(6) real*8, allocatable :: xcm(:) real*8, allocatable :: ycm(:) real*8, allocatable :: zcm(:) c c c perform dynamic allocation of some local arrays c allocate (xcm(n)) allocate (ycm(n)) allocate (zcm(n)) c c get atomic coordinates relative to group center of mass c do i = 1, ngrp start = igrp(1,i) stop = igrp(2,i) do j = 1, 3 rcm(j) = 0.0d0 end do do j = start, stop k = kgrp(j) weigh = mass(k) rcm(1) = rcm(1) + x(k)*weigh rcm(2) = rcm(2) + y(k)*weigh rcm(3) = rcm(3) + z(k)*weigh end do weigh = max(1.0d0,grpmass(i)) do j = 1, 3 rcm(j) = rcm(j) / weigh end do do j = start, stop k = kgrp(j) xcm(k) = x(k) - rcm(1) ycm(k) = y(k) - rcm(2) zcm(k) = z(k) - rcm(3) end do end do c c compute the moments of inertia and check for linearity c eps = 1.0d-8 do i = 1, ngrp size = igrp(2,i) - igrp(1,i) + 1 linear(i) = .false. if (size .eq. 2) then linear(i) = .true. else if (size .gt. 2) then do j = 1, 6 inert(j) = 0.0d0 end do do j = igrp(1,i), igrp(2,i) k = kgrp(j) xx = xcm(k) yy = ycm(k) zz = zcm(k) x2 = xx * xx y2 = yy * yy z2 = zz * zz weigh = mass(k) inert(1) = inert(1) + weigh*(y2+z2) inert(2) = inert(2) - weigh*xx*yy inert(3) = inert(3) + weigh*(x2+z2) inert(4) = inert(4) - weigh*xx*zz inert(5) = inert(5) - weigh*yy*zz inert(6) = inert(6) + weigh*(x2+y2) end do det = inert(1)*inert(3)*inert(6) & + 2.0d0*inert(2)*inert(5)*inert(4) & - inert(3)*inert(4)*inert(4) & - inert(1)*inert(5)*inert(5) & - inert(2)*inert(2)*inert(6) if (abs(det) .lt. eps) linear(i) = .true. end if end do c c perform deallocation of some local arrays c deallocate (xcm) deallocate (ycm) deallocate (zcm) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine gyrate -- compute the radius of gyration ## c ## ## c ############################################################# c c c "gyrate" computes the radius of gyration of a molecular system c from its atomic coordinates; only active atoms are included c c subroutine gyrate (rg) use atoms use usage implicit none integer i,k real*8 rg,xc,yc,zc c c c find the centroid of the atomic coordinates c xc = 0.0d0 yc = 0.0d0 zc = 0.0d0 do i = 1, nuse k = iuse(i) xc = xc + x(k) yc = yc + y(k) zc = zc + z(k) end do xc = xc / dble(nuse) yc = yc / dble(nuse) zc = zc / dble(nuse) c c compute and print out the radius of gyration c rg = 0.0d0 do i = 1, nuse k = iuse(i) rg = rg + (x(k)-xc)**2 + (y(k)-yc)**2 + (z(k)-zc)**2 end do rg = sqrt(rg/dble(nuse)) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## module hescut -- cutoff for Hessian matrix elements ## c ## ## c ############################################################# c c c hesscut magnitude of smallest allowed Hessian element c c module hescut implicit none real*8 hesscut save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine hessian -- atom-by-atom Hessian elements ## c ## ## c ############################################################# c c c "hessian" calls subroutines to calculate the Hessian elements c for each atom in turn with respect to Cartesian coordinates c c subroutine hessian (h,hinit,hstop,hindex,hdiag) use atoms use couple use hescut use hessn use inform use iounit use limits use mpole use potent use rigid use usage use vdw use vdwpot implicit none integer i,j,k integer ii,nhess integer hindex(*) integer hinit(3,*) integer hstop(3,*) real*8 rdn,cutoff real*8 hmax,percent real*8 h(*) real*8 hdiag(3,*) logical first logical, allocatable :: keep(:) save first data first / .true. / c c c zero out total number of indexed Hessian elements c nhess = 0 do i = 1, n do j = 1, 3 hinit(j,i) = 1 hstop(j,i) = 0 hdiag(j,i) = 0.0d0 end do end do 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 compute the induced dipoles at polarizable atoms c if (use_polar) then call chkpole call rotpole ('MPOLE') call induce end if c c calculate the reduced atomic coordinates c if (use_vdw) then do i = 1, n ii = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(ii)) + x(ii) yred(i) = rdn*(y(i)-y(ii)) + y(ii) zred(i) = rdn*(z(i)-z(ii)) + z(ii) end do end if c c perform dynamic allocation of some global arrays c if (first) then first = .false. if (.not. allocated(hessx)) allocate (hessx(3,n)) if (.not. allocated(hessy)) allocate (hessy(3,n)) if (.not. allocated(hessz)) allocate (hessz(3,n)) end if c c perform dynamic allocation of some local arrays c allocate (keep(n)) c c zero out the Hessian elements for the current atom c do i = 1, n if (use(i)) then do k = 1, n do j = 1, 3 hessx(j,k) = 0.0d0 hessy(j,k) = 0.0d0 hessz(j,k) = 0.0d0 end do end do c c remove any previous use of the replicates method c cutoff = 0.0d0 call replica (cutoff) c c call the local geometry Hessian component routines c if (use_bond) call ebond2 (i) if (use_angle) call eangle2 (i) if (use_strbnd) call estrbnd2 (i) if (use_urey) call eurey2 (i) if (use_angang) call eangang2 (i) if (use_opbend) call eopbend2 (i) if (use_opdist) call eopdist2 (i) if (use_improp) call eimprop2 (i) if (use_imptor) call eimptor2 (i) if (use_tors) call etors2 (i) if (use_pitors) call epitors2 (i) if (use_strtor) call estrtor2 (i) if (use_angtor) call eangtor2 (i) if (use_tortor) call etortor2 (i) c c call the electrostatic Hessian component routines c if (use_charge) call echarge2 (i) if (use_chgdpl) call echgdpl2 (i) if (use_dipole) call edipole2 (i) if (use_mpole) call empole2 (i) if (use_polar) call epolar2 (i) if (use_chgtrn) call echgtrn2 (i) if (use_rxnfld) call erxnfld2 (i) c c call the van der Waals Hessian component routines c if (use_vdw) then if (vdwtyp .eq. 'LENNARD-JONES') call elj2 (i) if (vdwtyp .eq. 'BUCKINGHAM') call ebuck2 (i) if (vdwtyp .eq. 'MM3-HBOND') call emm3hb2 (i) if (vdwtyp .eq. 'BUFFERED-14-7') call ehal2 (i) if (vdwtyp .eq. 'GAUSSIAN') call egauss2 (i) end if if (use_repel) call erepel2 (i) if (use_disp) call edisp2 (i) c c call any miscellaneous Hessian component routines c if (use_solv) call esolv2 (i) if (use_metal) call emetal2 (i) if (use_geom) call egeom2 (i) if (use_extra) call extra2 (i) c c set the diagonal Hessian matrix elements c hdiag(1,i) = hdiag(1,i) + hessx(1,i) hdiag(2,i) = hdiag(2,i) + hessy(2,i) hdiag(3,i) = hdiag(3,i) + hessz(3,i) c c search each 3x3 block to see which blocks will be kept c do k = i+1, n keep(k) = .false. if (use(k)) then hmax = max(abs(hessx(1,k)),abs(hessx(2,k)), & abs(hessx(3,k)),abs(hessy(1,k)), & abs(hessy(2,k)),abs(hessy(3,k)), & abs(hessz(1,k)),abs(hessz(2,k)), & abs(hessz(3,k))) if (hmax .ge. hesscut) keep(k) = .true. end if end do c c copy selected off-diagonal Hessian elements for current c atom into an indexed master list of Hessian elements; c if any elements of 3x3 block are kept, keep them all c hinit(1,i) = nhess + 1 do j = 2, 3 nhess = nhess + 1 hindex(nhess) = 3*i + j - 3 h(nhess) = hessx(j,i) end do do k = i+1, n if (keep(k)) then do j = 1, 3 nhess = nhess + 1 hindex(nhess) = 3*k + j - 3 h(nhess) = hessx(j,k) end do end if end do hstop(1,i) = nhess hinit(2,i) = nhess + 1 nhess = nhess + 1 hindex(nhess) = 3*i h(nhess) = hessy(3,i) do k = i+1, n if (keep(k)) then do j = 1, 3 nhess = nhess + 1 hindex(nhess) = 3*k + j - 3 h(nhess) = hessy(j,k) end do end if end do hstop(2,i) = nhess hinit(3,i) = nhess + 1 do k = i+1, n if (keep(k)) then do j = 1, 3 nhess = nhess + 1 hindex(nhess) = 3*k + j - 3 h(nhess) = hessz(j,k) end do end if end do hstop(3,i) = nhess end if end do c c perform deallocation of some local arrays c deallocate (keep) c c print message telling how much storage was finally used c if (verbose) then percent = 100.0d0 * dble(nhess)/dble(3*n*(3*n-1)/2) write (iout,10) nhess,percent 10 format (' HESSIAN --',i11,' Elements',f9.2, & ' % Off-Diag Hessian Storage') 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 hessn -- Cartesian Hessian elements for one atom ## c ## ## c ################################################################# c c c hessx Hessian elements for x-component of current atom c hessy Hessian elements for y-component of current atom c hessz Hessian elements for z-component of current atom c c module hessn implicit none real*8, allocatable :: hessx(:,:) real*8, allocatable :: hessy(:,:) real*8, allocatable :: hessz(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################### c ## ## c ## subroutine hessrgd -- rigid body Hessian elements ## c ## ## c ########################################################### c c c "hessrgd" computes the numerical Hessian elements with c respect to rigid body coordinates via 6*ngroup+1 gradient c evaluations c c subroutine hessrgd (hrigid) use atoms use group use rigid implicit none integer i,j,k,m,nvar real*8 e,eps,old real*8 hrigid(6*ngrp,*) real*8, allocatable :: g(:,:) real*8, allocatable :: g0(:,:) c c c perform dynamic allocation of some local arrays c allocate (g(6,ngrp)) allocate (g0(6,ngrp)) c c calculate base values for the rigid body gradient c eps = 0.00001d0 call gradrgd (e,g0) c c compute one-sided numerical Hessian from gradient values; c set off-diagonal elements to the average symmetric value c nvar = 6 * ngrp do i = 1, nvar j = (i-1)/6 + 1 k = mod(i-1,6) + 1 old = rbc(k,j) rbc(k,j) = rbc(k,j) + eps call rigidxyz call gradrgd (e,g) rbc(k,j) = old do m = 1, nvar j = (m-1)/6 + 1 k = mod(m-1,6) + 1 hrigid(m,i) = (g(k,j)-g0(k,j)) / eps end do do m = 1, i-1 hrigid(m,i) = 0.5d0 * (hrigid(m,i)+hrigid(i,m)) hrigid(i,m) = hrigid(m,i) end do end do c c perform deallocation of some local arrays c deallocate (g) deallocate (g0) c c restore the Cartesian coordinates to original values c call rigidxyz return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################## c ## ## c ## subroutine hessrot -- torsional Hessian elements ## c ## ## c ########################################################## c c c "hessrot" computes numerical Hessian elements with respect c to torsional angles; either the diagonal or the full matrix c can be calculated; the full matrix needs nomega+1 gradient c evaluations while the diagonal needs just two evaluations c c subroutine hessrot (mode,hrot) use omega use math use zcoord implicit none integer i,j,line real*8 e,eps real*8, allocatable :: g(:) real*8, allocatable :: g0(:) real*8, allocatable :: old(:) real*8 hrot(nomega,*) character*4 mode c c c perform dynamic allocation of some local arrays c allocate (g(nomega)) allocate (g0(nomega)) allocate (old(nomega)) c c calculate base values for the torsional gradient c eps = 0.0001d0 call gradrot (e,g0) c c compute one-sided numerical Hessian from gradient values; c set off-diagonal elements to the average symmetric value c if (mode .eq. 'FULL') then do i = 1, nomega line = zline(i) old(i) = ztors(line) ztors(line) = ztors(line) + radian*eps call makexyz call gradrot (e,g) ztors(line) = old(i) do j = 1, nomega hrot(j,i) = (g(j)-g0(j)) / eps end do do j = 1, i-1 hrot(j,i) = 0.5d0 * (hrot(j,i)+hrot(i,j)) hrot(i,j) = hrot(j,i) end do end do c c compute numerical Hessian diagonal from gradient values c else if (mode .eq. 'DIAG') then do i = 1, nomega line = zline(i) old(i) = ztors(line) ztors(line) = ztors(line) + radian*eps end do call makexyz call gradrot (e,g) do i = 1, nomega hrot(i,i) = (g(i)-g0(i)) / eps line = zline(i) ztors(line) = old(i) end do end if c c perform deallocation of some local arrays c deallocate (g) deallocate (g0) deallocate (old) c c restore the Cartesian coordinates to original values c call makexyz return end c c c ################################################### c ## COPYRIGHT (C) 2010 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module hpmf -- hydrophobic potential of mean force term ## c ## ## c ################################################################# c c c rcarbon radius of a carbon atom for use with HPMF c rwater radius of a water molecule for use with HPMF c acsurf surface area of a hydrophobic carbon atom c safact constant for calculation of atomic surface area c tgrad tanh slope (set very steep, default=100) c toffset shift the tanh plot along the x-axis (default=6) c hpmfcut cutoff distance for pairwise HPMF interactions c hd1,hd2,hd3 hydrophobic PMF well depth parameter c hc1,hc2,hc3 hydrophobic PMF well center point c hw1,hw2,hw3 reciprocal of the hydrophobic PMF well width c c npmf number of hydrophobic carbon atoms in the system c ipmf number of the atom for each HPMF carbon atom site c rpmf radius of each atom for use with hydrophobic PMF c acsa SASA value for each hydrophobic PMF carbon atom c c module hpmf implicit none real*8 rcarbon,rwater real*8 acsurf,safact real*8 tgrad,toffset real*8 hpmfcut real*8 hd1,hd2,hd3 real*8 hc1,hc2,hc3 real*8 hw1,hw2,hw3 parameter (rcarbon=1.7d0) parameter (rwater=1.4d0) parameter (acsurf=120.7628d0) parameter (safact=0.3516d0) parameter (tgrad=100.0d0) parameter (toffset=6.0d0) parameter (hpmfcut=11.0d0) parameter (hd1=-0.7308004860404441194d0) parameter (hd2=0.2001645051578760659d0) parameter (hd3=-0.0905499953418473502d0) parameter (hc1=3.8167879266271396155d0) parameter (hc2=5.4669162286016419472d0) parameter (hc3=7.1167694861385353278d0) parameter (hw1=1.6858993102248638341d0) parameter (hw2=1.3906405621629980285d0) parameter (hw3=1.5741657341338335385d0) integer npmf integer, allocatable :: ipmf(:) real*8, allocatable :: rpmf(:) real*8, allocatable :: acsa(:) save end c c c ############################################################### c ## COPYRIGHT (C) 1991 by Shawn Huston & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################### c c ############################################################### c ## ## c ## subroutine hybrid -- set parameters for hybrid system ## c ## ## c ############################################################### c c c "hybrid" constructs the hybrid hamiltonian for a specified c initial state, final state and mutation parameter "lambda" c c subroutine hybrid use iounit use mutant implicit none c c c set the potential energy parameters for hybrid atoms c if (nmut .ne. 0) then write (iout,10) lambda 10 format (/,' Lambda Coupling Parameter for FEP :',f12.3) call hatom call hbond call hangle call hstrbnd call himptor call htors call hstrtor call hvdw call hcharge call hdipole end if return end c c c ########################################################### c ## ## c ## subroutine hatom -- assign hybrid atom parameters ## c ## ## c ########################################################### c c c "hatom" assigns a new atom type to each hybrid site c c subroutine hatom use atomid use atoms use inform use iounit use katoms use mutant implicit none integer i,k,ntype integer it,it0,it1 c c c find the total number of atom types currently used; c exclude the "HYB" types so that they can be reused c do i = 1, maxtyp if (symbol(i).eq.' ' .or. symbol(i).eq.'HYB') then ntype = i - 1 goto 10 end if end do 10 continue c c stop if there are too many atom types required c if (maxtyp .lt. ntype+nmut) then abort = .true. write (iout,20) 20 format (' HATOM -- Too many Sites to be Altered;', & ' Increase MAXTYP') end if c c create a new atom type for each of the hybrid atoms c do i = 1, nmut k = imut(i) it = ntype + i it0 = type0(i) it1 = type1(i) symbol(it) = 'HYB' atmnum(it) = 0 weight(it) = lambda*weight(it1) + (1.0d0-lambda)*weight(it0) ligand(it) = 0 describe(it) = 'Hybrid Atom Type ' type(k) = it name(k) = symbol(it) atomic(k) = atmnum(it) mass(k) = weight(it) valence(k) = ligand(it) story(k) = describe(it) end do return end c c c ######################################################### c ## ## c ## subroutine hbond -- find hybrid bond parameters ## c ## ## c ######################################################### c c c "hbond" constructs hybrid bond stretch parameters given c an initial state, final state and "lambda" value c c subroutine hbond use atomid use atoms use bndstr use iounit use inform use kbonds use mutant implicit none integer i,j,k integer ia,ib integer ita,itb integer size real*8 bk0,bk1 real*8 bl0,bl1 logical header character*4 pa,pb character*8 pt c c c assign the hybrid parameters for individual bonds c header = .true. do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (mut(ia) .or. mut(ib)) then ita = class(ia) itb = class(ib) c c find the bond parameters for the initial state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class0(j) if (k .eq. ib) itb = class0(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pt = pa//pb else pt = pb//pa end if bk0 = 0.0d0 bl0 = 0.0d0 do j = 1, maxnb if (kb(j) .eq. pt) then bk0 = bcon(j) bl0 = blen(j) goto 10 end if end do 10 continue c c find the bond parameters for the final state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class1(j) if (k .eq. ib) itb = class1(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pt = pa//pb else pt = pb//pa end if bk1 = 0.0d0 bl1 = 0.0d0 do j = 1, maxnb if (kb(j) .eq. pt) then bk1 = bcon(j) bl1 = blen(j) goto 20 end if end do 20 continue c c form the hybrid parameters for the current bond c if (bl0 .eq. 0.0d0) bl0 = bl1 if (bl1 .eq. 0.0d0) bl1 = bl0 bk(i) = lambda*bk1 + (1.0d0-lambda)*bk0 bl(i) = lambda*bl1 + (1.0d0-lambda)*bl0 if (verbose) then if (header) then header = .false. write (iout,30) 30 format (/,' Hybrid Bond Stretching Parameters :', & //,6x,'Atom Numbers',9x,'KS',7x,'Length',/) end if write (iout,40) ia,ib,bk(i),bl(i) 40 format (6x,2i5,f14.3,f12.4) end if end if end do return end c c c ########################################################### c ## ## c ## subroutine hangle -- find hybrid angle parameters ## c ## ## c ########################################################### c c c "hangle" constructs hybrid angle bending parameters given c an initial state, final state and "lambda" value c c subroutine hangle use angbnd use atomid use atoms use iounit use inform use kangs use mutant implicit none integer i,j,k,size integer ia,ib,ic integer ita,itb,itc real*8 ak0,ak1 real*8 anat0,anat1 logical header character*4 pa,pb,pc character*12 pt c c c assign the hybrid parameters for individual angles c header = .true. do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) if (mut(ia) .or. mut(ib) .or. mut(ic)) then ita = class(ia) itb = class(ib) itc = class(ic) c c find the angle parameters for the initial state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class0(j) if (k .eq. ib) itb = class0(j) if (k .eq. ic) itc = class0(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pt = pa//pb//pc else pt = pc//pb//pa end if ak0 = 0.0d0 anat0 = 0.0d0 do j = 1, maxna if (ka(j) .eq. pt) then ak0 = acon(j) anat0 = ang(1,j) goto 10 end if end do 10 continue c c find the angle parameters for the final state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class1(j) if (k .eq. ib) itb = class1(j) if (k .eq. ic) itc = class1(j) end do size = 4 call numeral (ita,pa,3) call numeral (itb,pb,3) call numeral (itc,pc,3) if (ita .le. itc) then pt = pa//pb//pc else pt = pc//pb//pa end if ak1 = 0.0d0 anat1 = 0.0d0 do j = 1, maxna if (ka(j) .eq. pt) then ak1 = acon(j) anat1 = ang(1,j) goto 20 end if end do 20 continue c c form the hybrid parameters for the current angle c if (anat0 .eq. 0.0d0) anat0 = anat1 if (anat1 .eq. 0.0d0) anat1 = anat0 ak(i) = lambda*ak1 + (1.0d0-lambda)*ak0 anat(i) = lambda*anat1 + (1.0d0-lambda)*anat0 if (verbose) then if (header) then header = .false. write (iout,30) 30 format (/,' Hybrid Angle Bending Parameters :', & //,6x,'Atom Numbers',9x,'KB',8x,'Angle',/) end if write (iout,40) ia,ib,ic,ak(i),anat(i) 40 format (3x,3i5,2f12.3) end if end if end do return end c c c ############################################################## c ## ## c ## subroutine hstrbnd -- hybrid stretch-bend parameters ## c ## ## c ############################################################## c c c "hstrbnd" constructs hybrid stretch-bend parameters given c an initial state, final state and "lambda" value c c subroutine hstrbnd use angbnd use atmlst use atomid use atoms use couple use iounit use inform use katoms use kstbnd use mutant use strbnd implicit none integer i,j,k,size integer ia,ib,ic integer ita,itb,itc integer nba,nbc real*8 sbk0(2),sbk1(2) logical header,used character*4 pa,pb,pc character*12 pt c c c assign hybrid parameters for the stretch-bend sites c header = .true. do i = 1, nangle used = .false. ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) if (mut(ia) .or. mut(ib) .or. mut(ic)) then ita = class(ia) itb = class(ib) itc = class(ic) do j = 1, n12(ib) if (i12(j,ib) .eq. ia) nba = bndlist(j,ib) if (i12(j,ib) .eq. ic) nbc = bndlist(j,ib) end do c c find the stretch-bend parameters for the initial state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class0(j) if (k .eq. ib) itb = class0(j) if (k .eq. ic) itc = class0(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pt = pa//pb//pc else pt = pc//pb//pa end if sbk0(1) = 0.0d0 sbk0(2) = 0.0d0 do j = 1, maxnsb if (ksb(j) .eq. pt) then used = .true. if (ita .le. itc) then sbk0(1) = stbn(1,j) sbk0(2) = stbn(2,j) else sbk0(1) = stbn(2,j) sbk0(2) = stbn(1,j) end if goto 10 end if end do 10 continue c c find the stretch-bend parameters for the final state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class1(j) if (k .eq. ib) itb = class1(j) if (k .eq. ic) itc = class1(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pt = pa//pb//pc else pt = pc//pb//pa end if sbk1(1) = 0.0d0 sbk1(2) = 0.0d0 do j = 1, maxnsb if (ksb(j) .eq. pt) then used = .true. if (ita .le. itc) then sbk1(1) = stbn(1,j) sbk1(2) = stbn(2,j) else sbk1(1) = stbn(2,j) sbk1(2) = stbn(1,j) end if goto 20 end if end do 20 continue c c form hybrid parameters for the current stretch-bend c if (used) then nstrbnd = nstrbnd + 1 k = nstrbnd isb(1,k) = i isb(2,k) = nba isb(3,k) = nbc sbk(1,k) = lambda*sbk1(1) + (1.0d0-lambda)*sbk0(1) sbk(2,k) = lambda*sbk1(2) + (1.0d0-lambda)*sbk0(2) if (verbose) then if (header) then header = .false. write (iout,30) 30 format (/,' Hybrid Stretch-Bend Parameters :', & //,6x,'Atom Numbers',8x,'KSB 1', & 7x,'KSB 2',/) end if write (iout,40) ia,ib,ic,sbk(1,i),sbk(2,i) 40 format (3x,3i5,2f12.3) end if end if end if end do return end c c c ############################################################# c ## ## c ## subroutine himptor -- find hybrid improper torsions ## c ## ## c ############################################################# c c c "himptor" constructs hybrid improper torsional parameters c given an initial state, final state and "lambda" value c c note this version does not handle multiple parameters at c a single trigonal site c c subroutine himptor use atomid use atoms use couple use iounit use inform use imptor use kitors use math use mutant implicit none integer i,j,k integer ia,ib,ic,id integer ita,itb,itc,itd integer nti,size real*8 angle,symm real*8 v1_0,v2_0,v3_0 real*8 s1_0,s2_0,s3_0 real*8 v1_1,v2_1,v3_1 real*8 s1_1,s2_1,s3_1 logical header,used character*4 pa,pb,pc,pd character*4 zeros character*16 blank character*16 pt0,pt(6) c c c construct hybrid improper torsion parameters c blank = ' ' zeros = '0000' header = .true. c c determine the total number of forcefield parameters c nti = maxnti do i = maxnti, 1, -1 if (kti(i) .eq. blank) nti = i - 1 end do c c construct hybrid improper torsion parameters c do i = 1, n if (n12(i) .eq. 3) then used = .false. ia = i12(1,i) ib = i12(2,i) ic = i id = i12(3,i) if (mut(ia) .or. mut(ib) .or. mut(ic) .or. mut(id)) then ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) c c find improper torsion parameters for the initial state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class0(j) if (k .eq. ib) itb = class0(j) if (k .eq. ic) itc = class0(j) if (k .eq. id) itd = class0(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) pt(1) = pa//pb//pc//pd pt(2) = pb//pa//pc//pd pt(3) = pa//pd//pc//pb pt(4) = pd//pa//pc//pb pt(5) = pb//pd//pc//pa pt(6) = pd//pb//pc//pa pt0 = zeros//zeros//pc//zeros symm = 1.0d0 if (pa.eq.pb .or. pa.eq.pd .or. pb.eq.pd) symm = 2.0d0 if (pa.eq.pb .and. pa.eq.pd .and. pb.eq.pd) symm = 6.0d0 v1_0 = 0.0d0 s1_0 = 0.0d0 v2_0 = 0.0d0 s2_0 = 0.0d0 v3_0 = 0.0d0 s3_0 = 0.0d0 do j = 1, nti if (kti(j)(9:12) .eq. pc) then do k = 1, 6 if (kti(j) .eq. pt(k)) then used = .true. v1_0 = ti1(1,j) / symm s1_0 = ti1(2,j) v2_0 = ti2(1,j) / symm s2_0 = ti2(2,j) v3_0 = ti3(1,j) / symm s3_0 = ti3(2,j) goto 10 end if end do end if end do do j = 1, nti if (kti(j) .eq. pt0) then used = .true. v1_0 = ti1(1,j) / symm s1_0 = ti1(2,j) v2_0 = ti2(1,j) / symm s2_0 = ti2(2,j) v3_0 = ti3(1,j) / symm s3_0 = ti3(2,j) goto 10 end if end do 10 continue c c find improper torsion parameters for the final state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class1(j) if (k .eq. ib) itb = class1(j) if (k .eq. ic) itc = class1(j) if (k .eq. id) itd = class1(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) pt(1) = pa//pb//pc//pd pt(2) = pb//pa//pc//pd pt(3) = pa//pd//pc//pb pt(4) = pd//pa//pc//pb pt(5) = pb//pd//pc//pa pt(6) = pd//pb//pc//pa pt0 = zeros//zeros//pc//zeros symm = 1.0d0 if (pa.eq.pb .or. pa.eq.pd .or. pb.eq.pd) symm = 2.0d0 if (pa.eq.pb .and. pa.eq.pd .and. pb.eq.pd) symm = 6.0d0 v1_1 = 0.0d0 s1_1 = 0.0d0 v2_1 = 0.0d0 s2_1 = 0.0d0 v3_1 = 0.0d0 s3_1 = 0.0d0 do j = 1, nti if (kti(j)(9:12) .eq. pc) then do k = 1, 6 if (kti(j) .eq. pt(k)) then used = .true. v1_1 = ti1(1,j) / symm s1_1 = ti1(2,j) v2_1 = ti2(1,j) / symm s2_1 = ti2(2,j) v3_1 = ti3(1,j) / symm s3_1 = ti3(2,j) goto 20 end if end do end if end do do j = 1, nti if (kti(j) .eq. pt0) then used = .true. v1_1 = ti1(1,j) / symm s1_1 = ti1(2,j) v2_1 = ti2(1,j) / symm s2_1 = ti2(2,j) v3_1 = ti3(1,j) / symm s3_1 = ti3(2,j) goto 20 end if end do 20 continue c c form hybrid parameters for the current improper torsion c if (used) then do j = 1, nitors if (iitors(3,j) .eq. ic) then k = j goto 30 end if end do nitors = nitors + 1 k = nitors iitors(1,k) = ia iitors(2,k) = ib iitors(3,k) = ic iitors(4,k) = id 30 continue if (s1_0 .eq. 0.0d0) s1_0 = s1_1 if (s2_0 .eq. 0.0d0) s2_0 = s2_1 if (s3_0 .eq. 0.0d0) s3_0 = s3_1 if (s1_1 .eq. 0.0d0) s1_1 = s1_0 if (s2_1 .eq. 0.0d0) s2_1 = s2_0 if (s3_1 .eq. 0.0d0) s3_1 = s3_0 itors1(1,k) = lambda*v1_1 + (1.0d0-lambda)*v1_0 itors1(2,k) = lambda*s1_1 + (1.0d0-lambda)*s1_0 angle = itors1(2,k) / radian itors1(3,k) = cos(angle) itors1(4,k) = sin(angle) itors2(1,k) = lambda*v2_1 + (1.0d0-lambda)*v2_0 itors2(2,k) = lambda*s2_1 + (1.0d0-lambda)*s2_0 angle = itors2(2,k) / radian itors2(3,k) = cos(angle) itors2(4,k) = sin(angle) itors3(1,k) = lambda*v3_1 + (1.0d0-lambda)*v3_0 itors3(2,k) = lambda*s3_1 + (1.0d0-lambda)*s3_0 angle = itors3(2,k) / radian itors3(3,k) = cos(angle) itors3(4,k) = sin(angle) if (verbose) then if (header) then header = .false. write (iout,40) 40 format (/,' Hybrid Improper Torsional', & ' Parameters :', & //,6x,'Atom Numbers',16x,'KIT1', & 13x,'KIT2',13x,'KIT3',/) end if ia = iitors(1,i) ib = iitors(2,i) ic = iitors(3,i) id = iitors(4,i) write (iout,50) ia,ib,ic,id,itors1(1,k), & itors1(2,k),itors2(1,k), & itors2(2,k),itors3(1,k), & itors3(2,k) 50 format (1x,4i5,4x,3(f10.4,f7.1)) end if end if end if end if end do return end c c c ############################################################ c ## ## c ## subroutine htors -- find hybrid torsion parameters ## c ## ## c ############################################################ c c c "htors" constructs hybrid torsional parameters for a given c initial state, final state and "lambda" value c c subroutine htors use atomid use atoms use inform use iounit use ktorsn use math use mutant use tors implicit none integer i,j,k,size integer ia,ib,ic,id integer ita,itb,itc,itd real*8 angle real*8 v1_0,v2_0,v3_0 real*8 v4_0,v5_0,v6_0 real*8 s1_0,s2_0,s3_0 real*8 s4_0,s5_0,s6_0 real*8 v1_1,v2_1,v3_1 real*8 v4_1,v5_1,v6_1 real*8 s1_1,s2_1,s3_1 real*8 s4_1,s5_1,s6_1 logical header character*4 pa,pb,pc,pd character*4 zeros character*16 pt,pt0 c c c construct hybrid torsional parameters c zeros = '0000' header = .true. do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) if (mut(ia) .or. mut(ib) .or. mut(ic) .or. mut(id)) then ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) c c find the torsion parameters for the initial state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class0(j) if (k .eq. ib) itb = class0(j) if (k .eq. ic) itc = class0(j) if (k .eq. id) itd = class0(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .lt. itc) then pt = pa//pb//pc//pd else if (itc .lt. itb) then pt = pd//pc//pb//pa else if (ita .le. itd) then pt = pa//pb//pc//pd else if (itd .lt. ita) then pt = pd//pc//pb//pa end if pt0 = zeros//pt(5:12)//zeros v1_0 = 0.0d0 s1_0 = 0.0d0 v2_0 = 0.0d0 s2_0 = 0.0d0 v3_0 = 0.0d0 s3_0 = 0.0d0 v4_0 = 0.0d0 s4_0 = 0.0d0 v5_0 = 0.0d0 s5_0 = 0.0d0 v6_0 = 0.0d0 s6_0 = 0.0d0 do j = 1, maxnt if (kt(j) .eq. pt) then v1_0 = t1(1,j) s1_0 = t1(2,j) v2_0 = t2(1,j) s2_0 = t2(2,j) v3_0 = t3(1,j) s3_0 = t3(2,j) v4_0 = t4(1,j) s4_0 = t4(2,j) v5_0 = t5(1,j) s5_0 = t5(2,j) v6_0 = t6(1,j) s6_0 = t6(2,j) goto 10 end if end do do j = 1, maxnt if (kt(j) .eq. pt0) then v1_0 = t1(1,j) s1_0 = t1(2,j) v2_0 = t2(1,j) s2_0 = t2(2,j) v3_0 = t3(1,j) s3_0 = t3(2,j) v4_0 = t4(1,j) s4_0 = t4(2,j) v5_0 = t5(1,j) s5_0 = t5(2,j) v6_0 = t6(1,j) s6_0 = t6(2,j) goto 10 end if end do 10 continue c c find the torsion parameters for the final state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class1(j) if (k .eq. ib) itb = class1(j) if (k .eq. ic) itc = class1(j) if (k .eq. id) itd = class1(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .lt. itc) then pt = pa//pb//pc//pd else if (itc .lt. itb) then pt = pd//pc//pb//pa else if (ita .le. itd) then pt = pa//pb//pc//pd else if (itd .lt. ita) then pt = pd//pc//pb//pa end if pt0 = zeros//pt(5:12)//zeros v1_1 = 0.0d0 s1_1 = 0.0d0 v2_1 = 0.0d0 s2_1 = 0.0d0 v3_1 = 0.0d0 s3_1 = 0.0d0 v4_1 = 0.0d0 s4_1 = 0.0d0 v5_1 = 0.0d0 s5_1 = 0.0d0 v6_1 = 0.0d0 s6_1 = 0.0d0 do j = 1, maxnt if (kt(j) .eq. pt) then v1_1 = t1(1,j) s1_1 = t1(2,j) v2_1 = t2(1,j) s2_1 = t2(2,j) v3_1 = t3(1,j) s3_1 = t3(2,j) v4_1 = t4(1,j) s4_1 = t4(2,j) v5_1 = t5(1,j) s5_1 = t5(2,j) v6_1 = t6(1,j) s6_1 = t6(2,j) goto 20 end if end do do j = 1, maxnt if (kt(j) .eq. pt0) then v1_1 = t1(1,j) s1_1 = t1(2,j) v2_1 = t2(1,j) s2_1 = t2(2,j) v3_1 = t3(1,j) s3_1 = t3(2,j) v4_1 = t4(1,j) s4_1 = t4(2,j) v5_1 = t5(1,j) s5_1 = t5(2,j) v6_1 = t6(1,j) s6_1 = t6(2,j) goto 20 end if end do 20 continue c c form the hybrid parameters for the current torsion c if (s1_0 .eq. 0.0d0) s1_0 = s1_1 if (s2_0 .eq. 0.0d0) s2_0 = s2_1 if (s3_0 .eq. 0.0d0) s3_0 = s3_1 if (s4_0 .eq. 0.0d0) s4_0 = s4_1 if (s5_0 .eq. 0.0d0) s5_0 = s5_1 if (s6_0 .eq. 0.0d0) s6_0 = s6_1 if (s1_1 .eq. 0.0d0) s1_1 = s1_0 if (s2_1 .eq. 0.0d0) s2_1 = s2_0 if (s3_1 .eq. 0.0d0) s3_1 = s3_0 if (s4_1 .eq. 0.0d0) s4_1 = s4_0 if (s5_1 .eq. 0.0d0) s5_1 = s5_0 if (s6_1 .eq. 0.0d0) s6_1 = s6_0 tors1(1,i) = lambda*v1_1 + (1.0d0-lambda)*v1_0 tors1(2,i) = lambda*s1_1 + (1.0d0-lambda)*s1_0 angle = tors1(2,i) / radian tors1(3,i) = cos(angle) tors1(4,i) = sin(angle) tors2(1,i) = lambda*v2_1 + (1.0d0-lambda)*v2_0 tors2(2,i) = lambda*s2_1 + (1.0d0-lambda)*s2_0 angle = tors2(2,i) / radian tors2(3,i) = cos(angle) tors2(4,i) = sin(angle) tors3(1,i) = lambda*v3_1 + (1.0d0-lambda)*v3_0 tors3(2,i) = lambda*s3_1 + (1.0d0-lambda)*s3_0 angle = tors3(2,i) / radian tors3(3,i) = cos(angle) tors3(4,i) = sin(angle) tors4(1,i) = lambda*v4_1 + (1.0d0-lambda)*v4_0 tors4(2,i) = lambda*s4_1 + (1.0d0-lambda)*s4_0 angle = tors4(2,i) / radian tors4(3,i) = cos(angle) tors4(4,i) = sin(angle) tors5(1,i) = lambda*v5_1 + (1.0d0-lambda)*v5_0 tors5(2,i) = lambda*s5_1 + (1.0d0-lambda)*s5_0 angle = tors5(2,i) / radian tors5(3,i) = cos(angle) tors5(4,i) = sin(angle) tors6(1,i) = lambda*v6_1 + (1.0d0-lambda)*v6_0 tors6(2,i) = lambda*s6_1 + (1.0d0-lambda)*s6_0 angle = tors6(2,i) / radian tors6(3,i) = cos(angle) tors6(4,i) = sin(angle) if (verbose) then if (header) then header = .false. write (iout,30) 30 format (/,' Hybrid Torsional Parameters :', & //,5x,'Atom Numbers',6x,'KT1',7x,'KT2', & 7x,'KT3',7x,'KT4',7x,'KT5',7x,'KT6',/) end if write (iout,40) ia,ib,ic,id, & tors1(1,i),nint(tors1(2,i)), & tors2(1,i),nint(tors2(2,i)), & tors3(1,i),nint(tors3(2,i)), & tors4(1,i),nint(tors4(2,i)), & tors5(1,i),nint(tors5(2,i)), & tors6(1,i),nint(tors6(2,i)) 40 format (1x,4i4,1x,6(f6.2,i4)) end if end if end do return end c c c ############################################################ c ## ## c ## subroutine hstrtor -- hybrid stretch-torsion terms ## c ## ## c ############################################################ c c c "hstrtor" constructs hybrid stretch-torsion parameters c given an initial state, final state and "lambda" value c c subroutine hstrtor use atmlst use atomid use atoms use couple use inform use iounit use ksttor use mutant use strtor use tors implicit none integer i,j,k,size integer ia,ib,ic,id integer ita,itb,itc,itd real*8 kst0(3),kst1(3) logical header character*4 pa,pb,pc,pd character*4 zeros character*16 pt,pt0 c c c assign hybrid parameters for the stretch-torsion sites c zeros = '0000' header = .true. do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) if (mut(ia) .or. mut(ib) .or. mut(ic) .or. mut(id)) then ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) c c find the stretch-torsion parameters for the initial state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class0(j) if (k .eq. ib) itb = class0(j) if (k .eq. ic) itc = class0(j) if (k .eq. id) itd = class0(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .lt. itc) then pt = pa//pb//pc//pd else if (itc .lt. itb) then pt = pd//pc//pb//pa else if (ita .le. itd) then pt = pa//pb//pc//pd else if (itd .lt. ita) then pt = pd//pc//pb//pa end if pt0 = zeros//pt(5:12)//zeros do k = 1, 3 kst0(k) = 0.0d0 end do do j = 1, maxnbt if (kbt(j) .eq. pt) then do k = 1, 3 kst0(k) = btcon(k,j) end do goto 10 end if end do do j = 1, maxnbt if (kbt(j) .eq. pt0) then do k = 1, 3 kst0(k) = btcon(k,j) end do goto 10 end if end do 10 continue c c find the stretch-torsion parameters for the final state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = class0(j) if (k .eq. ib) itb = class0(j) if (k .eq. ic) itc = class0(j) if (k .eq. id) itd = class0(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .lt. itc) then pt = pa//pb//pc//pd else if (itc .lt. itb) then pt = pd//pc//pb//pa else if (ita .le. itd) then pt = pa//pb//pc//pd else if (itd .lt. ita) then pt = pd//pc//pb//pa end if pt0 = zeros//pt(5:12)//zeros do k = 1, 3 kst1(k) = 0.0d0 end do do j = 1, maxnbt if (kbt(j) .eq. pt) then do k = 1, 3 kst1(k) = btcon(k,j) end do goto 20 end if end do do j = 1, maxnbt if (kbt(j) .eq. pt0) then do k = 1, 3 kst1(k) = btcon(k,j) end do goto 20 end if end do 20 continue c c form hybrid parameters for the current stretch-torsion c do j = 1, 3 kst(j,i) = lambda*kst1(j) + (1.0d0-lambda)*kst0(j) end do if (kst(1,i).eq.0.0d0 .and. kst(2,i).eq.0.0d0 & .and. kst(3,i).eq.0.0d0) then if (ist(1,i) .ne. 0) then nstrtor = nstrtor - 1 ist(1,i) = 0 end if else if (ist(1,i) .ne. i) then nstrtor = nstrtor + 1 ist(1,i) = i do j = 1, n12(ib) if (i12(j,ib) .eq. ic) then ist(2,i) = bndlist(j,ib) goto 30 end if end do 30 continue end if if (verbose) then if (header) then header = .false. write (iout,40) 40 format (/,' Hybrid Stretch-Torsion Parameters :', & //,6x,'Atom Numbers',13x,'KST1',8x,'KST2', & 8x,'KST3',/) end if write (iout,50) ia,ib,ic,id,(kst(j,i),j=1,3) 50 format (3x,4i5,3f12.3) end if end if end if end do return end c c c ############################################################ c ## ## c ## subroutine hvdw -- hybrid van der Waals parameters ## c ## ## c ############################################################ c c c "hvdw" constructs hybrid van der Waals parameters given c an initial state, final state and "lambda" value c c subroutine hvdw use atomid use atoms use inform use iounit use kvdws use math use mutant use vdw use vdwpot implicit none integer i,j,k integer it,kt integer itm,ktm integer it0,it1 integer nlist integer, allocatable :: list(:) real*8 radius,rd,ep real*8, allocatable :: srad(:) real*8, allocatable :: seps(:) logical header c c c assign the hybrid van der Waals parameters c do j = 1, nmut i = imut(j) if (vdwindex .eq. 'TYPE') then it = type(i) it0 = type0(j) it1 = type1(j) else it = class(i) it0 = class0(j) it1 = class1(j) end if rad(it) = lambda*rad(it1) + (1.0d0-lambda)*rad(it0) eps(it) = lambda*eps(it1) + (1.0d0-lambda)*eps(it0) end do c c perform dynamic allocation of some local arrays c allocate (srad(maxtyp)) allocate (seps(maxtyp)) allocate (list(n)) c c get the square roots of the vdw radii and well depths c do i = 1, maxclass srad(i) = sqrt(rad(i)) seps(i) = sqrt(eps(i)) end do c c set type or class index into condensed pair matrices c nlist = n do i = 1, n list(i) = 0 if (vdwindex .eq. 'TYPE') then list(i) = type(i) else list(i) = class(i) end if end do call sort8 (nlist,list) c c use combination rules to set pairwise vdw radii sums c do j = 1, nmut i = imut(j) if (vdwindex .eq. 'TYPE') then it = type(i) else it = class(i) end if itm = mvdw(it) do k = 1, nlist kt = list(k) ktm = mvdw(kt) if (kt .ne. 0) then if (rad(it).eq.0.0d0 .and. rad(kt).eq.0.0d0) then rd = 0.0d0 else if (radrule(1:10) .eq. 'ARITHMETIC') then rd = rad(it) + rad(kt) else if (radrule(1:9) .eq. 'GEOMETRIC') then rd = 2.0d0*(srad(it)*srad(kt)) else if (radrule(1:10) .eq. 'CUBIC-MEAN') then rd = 2.0d0*(rad(it)**3+rad(kt)**3) & / (rad(it)**2+rad(kt)**2) else rd = rad(it) + rad(kt) end if end if radmin(itm,ktm) = rd radmin(ktm,itm) = rd end do end do c c use combination rules to set pairwise well depths c do j = 1, nmut i = imut(j) if (vdwindex .eq. 'TYPE') then it = type(i) else it = class(i) end if itm = mvdw(it) do k = 1, nlist kt = list(k) ktm = mvdw(kt) if (kt .ne. 0) then if (eps(it).eq.0.0d0 .and. eps(kt).eq.0.0d0) then ep = 0.0d0 else if (epsrule(1:10) .eq. 'ARITHMETIC') then ep = 0.5d0 * (eps(it) + eps(kt)) else if (epsrule(1:9) .eq. 'GEOMETRIC') then ep = seps(it) * seps(kt) else if (epsrule(1:8) .eq. 'HARMONIC') then ep = 2.0d0 * (eps(it)*eps(kt)) / (eps(it)+eps(kt)) else if (epsrule(1:3) .eq. 'HHG') then ep = 4.0d0 * (eps(it)*eps(kt)) & / (seps(it)+seps(kt))**2 else ep = seps(it) * seps(kt) end if end if epsilon(itm,ktm) = ep epsilon(ktm,itm) = ep end do end do c c print the van der Waals parameters for hybrid atoms c header = .true. do j = 1, nmut i = imut(j) if (vdwindex .eq. 'TYPE') then it = type(i) else it = class(i) end if if (verbose) then if (header) then header = .false. write (iout,10) 10 format (/,' Hybrid van der Waals Parameters :', & //,5x,'Atom Number',14x,'Size',8x,'Epsilon',/) end if radius = rad(it) if (radsiz .eq. 'DIAMETER') radius = 2.0d0 * radius if (radtyp .eq. 'SIGMA') radius = radius / twosix write (iout,20) i,radius,eps(it) 20 format (6x,i6,7x,2f15.4) end if end do c c perform deallocation of some local arrays c deallocate (srad) deallocate (seps) deallocate (list) return end c c c ############################################################# c ## ## c ## subroutine hcharge -- find hybrid charge parameters ## c ## ## c ############################################################# c c c "hcharge" constructs hybrid charge interaction parameters c given an initial state, final state and "lambda" value c c subroutine hcharge use atoms use charge use inform use iounit use kchrge use mutant implicit none integer i,j,k,kk integer it,it0,it1 real*8 chg0,chg1 real*8 hybchg logical header,used c c c assign the hybrid parameters for atomic charges c header = .true. do j = 1, nmut used = .false. i = imut(j) it = type(i) it0 = type0(j) it1 = type1(j) chg0 = chg(it0) chg1 = chg(it1) hybchg = lambda*chg1 + (1.0d0-lambda)*chg0 do kk = 1, nion k = iion(kk) if (k .eq. i) then used = .true. pchg(k) = hybchg goto 10 end if end do if (chg0.ne.0.0d0 .or. chg1.ne.0.0d0) then used = .true. nion = nion + 1 iion(nion) = i kion(i) = i pchg(i) = hybchg end if 10 continue if (verbose .and. used) then if (header) then header = .false. write (iout,20) 20 format (/,' Hybrid Atomic Partial Charge Parameters :', & //,5x,'Atom Number',12x,'Charge',/) end if write (iout,30) i,hybchg 30 format (6x,i6,7x,f15.4) end if end do return end c c c ############################################################# c ## ## c ## subroutine hdipole -- find hybrid dipole parameters ## c ## ## c ############################################################# c c c "hdipole" constructs hybrid dipole interaction parameters c given an initial state, final state and "lambda" value c c subroutine hdipole use atoms use bndstr use dipole use inform use iounit use kdipol use mutant implicit none integer i,j,k integer ia,ib integer ita,itb integer size real*8 dpl0,dpl1,hybdpl real*8 pos0,pos1,hybpos logical header,used character*4 pa,pb character*8 blank,pt c c c assign the hybrid parameters for bond dipoles c blank = ' ' header = .true. do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (mut(ia) .or. mut(ib)) then ita = type(ia) itb = type(ib) c c find the dipole parameters for the initial state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = type0(j) if (k .eq. ib) itb = type0(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pt = pa//pb else pt = pb//pa end if dpl0 = 0.0d0 pos0 = 0.5d0 do j = 1, maxnd if (kd(j) .eq. blank) goto 10 if (kd(j) .eq. pt) then if (ita .le. itb) then dpl0 = bdpl(j) pos0 = sdpl(j) else dpl0 = -bdpl(j) pos0 = 1.0d0 - sdpl(j) end if end if end do 10 continue c c find the dipole parameters for the final state c do j = 1, nmut k = imut(j) if (k .eq. ia) ita = type1(j) if (k .eq. ib) itb = type1(j) end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pt = pa//pb else pt = pb//pa end if dpl1 = 0.0d0 pos1 = 0.5d0 do j = 1, maxnd if (kd(j) .eq. blank) goto 20 if (kd(j) .eq. pt) then if (ita .le. itb) then dpl1 = bdpl(j) pos1 = sdpl(j) else dpl1 = -bdpl(j) pos1 = 1.0d0 - sdpl(j) end if end if end do 20 continue c c form the hybrid parameters for the current dipole c hybdpl = lambda*dpl1 + (1.0d0-lambda)*dpl0 hybpos = lambda*pos1 + (1.0d0-lambda)*pos0 used = .false. do j = 1, ndipole if ((idpl(1,j).eq.ia .and. idpl(2,j).eq.ib) .or. & (idpl(1,j).eq.ib .and. idpl(2,j).eq.ia)) then idpl(1,j) = ia idpl(2,j) = ib bdpl(j) = hybdpl sdpl(j) = hybpos used = .true. goto 30 end if end do if (hybdpl .ne. 0.0d0) then ndipole = ndipole + 1 idpl(1,ndipole) = ia idpl(2,ndipole) = ib bdpl(ndipole) = hybdpl sdpl(ndipole) = hybpos used = .true. end if 30 continue if (verbose .and. used) then if (header) then header = .false. write (iout,40) 40 format (/,' Hybrid Bond Dipole Moment Parameters :', & //,6x,'Atom Numbers',7x,'Moment', & 7x,'Position',/) end if write (iout,50) ia,ib,hybdpl,hybpos 50 format (6x,2i5,2f15.3) end if end if end do return end c c c ############################################################### c ## COPYRIGHT (C) 2014 by Alex Albaugh & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################### c c ############################################################## c ## ## c ## module ielscf -- extended Lagrangian induced dipoles ## c ## ## c ############################################################## c c c nfree_aux total degrees of freedom for auxiliary dipoles c tautemp_aux time constant for auliliary Berendsen thermostat c kelvin_aux target system temperature for auxiliary dipoles c uaux auxiliary induced dipole value at each site c upaux auxiliary shadow induced dipoles at each site c vaux auxiliary induced dipole velocity at each site c vpaux auxiliary shadow dipole velocity at each site c aaux auxiliary induced dipole acceleration at each site c apaux auxiliary shadow dipole acceleration at each site c use_ielscf flag to use inertial extended Lagrangian method c c module ielscf implicit none integer nfree_aux real*8 tautemp_aux real*8 kelvin_aux real*8, allocatable :: uaux(:,:) real*8, allocatable :: upaux(:,:) real*8, allocatable :: vaux(:,:) real*8, allocatable :: vpaux(:,:) real*8, allocatable :: aaux(:,:) real*8, allocatable :: apaux(:,:) logical use_ielscf save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine image -- compute the minimum image distance ## c ## ## c ################################################################ c c c "image" takes the components of pairwise distance between c two points in a periodic box and converts to the components c of the minimum image distance c c literature reference: c c U. K. Deiters, "Efficient Coding of the Minimum Image Convention", c Zeitschrift fur Physikalische Chemie, 227, 345-352 (2013) c c note the "do while" clause below can be written using the "nint" c intrinsic, and the two forms give equivalent values: c c do while (abs(xr) .gt. xbox2) c xr = xr - sign(xbox,xr) vs. xr = xr - xbox*nint(xr/xbox) c end do c c which one is faster depends upon specific machine and compiler c combinations, and other implementations are also possible c c subroutine image (xr,yr,zr) use boxes use cell use math implicit none real*8 xr,yr,zr real*8 corr c c c for orthogonal lattice, find the desired image directly c if (orthogonal) then do while (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) end do do while (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) end do do while (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) end do c c for monoclinic lattice, convert x and z to fractional, c find desired image, then translate back to Cartesian c else if (monoclinic) then zr = zr / beta_sin xr = xr - zr*beta_cos do while (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) end do do while (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) end do do while (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) end do xr = xr + zr*beta_cos zr = zr * beta_sin c c for triclinic lattice, convert to fractional coordinates, c find image, then translate fractional back to Cartesian c else if (triclinic) then zr = zr / gamma_term yr = (yr - zr*beta_term) / gamma_sin xr = xr - yr*gamma_cos - zr*beta_cos do while (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) end do do while (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) end do do while (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) end do xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term c c for truncated octahedron, remove the corner pieces c else if (octahedron) then do while (abs(xr) .gt. xbox2) xr = xr - sign(xbox,xr) end do do while (abs(yr) .gt. ybox2) yr = yr - sign(ybox,yr) end do do while (abs(zr) .gt. zbox2) zr = zr - sign(zbox,zr) end do if (abs(xr)+abs(yr)+abs(zr) .gt. box34) then xr = xr - sign(xbox2,xr) yr = yr - sign(ybox2,yr) zr = zr - sign(zbox2,zr) end if c c for rhombic dodecahedron, align along the x- and y-axes c else if (dodecadron) then do while (abs(xr) .gt. xbox2) xr = xr - sign(xbox,xr) end do do while (abs(yr) .gt. ybox2) yr = yr - sign(ybox,yr) end do zr = zr - root2*zbox*nint(zr/(zbox*root2)) corr = xbox2 * int(abs(xr/xbox)+abs(yr/ybox) & +abs(root2*zr/zbox)) xr = xr - sign(corr,xr) yr = yr - sign(corr,yr) zr = zr - sign(corr,zr)*root2 end if return end c c c ############################################################### c ## ## c ## subroutine imager -- replicate minimum image distance ## c ## ## c ############################################################### c c c "imager" takes the components of pairwise distance between c two points in the same or neighboring periodic boxes and c converts to the components of the minimum image distance c c subroutine imager (xr,yr,zr,i) use boxes use cell use math implicit none integer i real*8 xr,yr,zr real*8 xmove,ymove,zmove real*8 corr c c c set the distance to translate along each cell axis c xmove = icell(1,i) * xbox ymove = icell(2,i) * ybox zmove = icell(3,i) * zbox c c for orthogonal lattice, find the desired image directly c if (orthogonal) then xr = xr + xmove do while (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) end do yr = yr + ymove do while (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) end do zr = zr + zmove do while (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) end do c c for monoclinic lattice, convert x and z to fractional, c find desired image, then translate back to Cartesian c else if (monoclinic) then zr = zr / beta_sin xr = xr - zr*beta_cos xr = xr + xmove do while (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) end do yr = yr + ymove do while (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) end do zr = zr + zmove do while (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) end do xr = xr + zr*beta_cos zr = zr * beta_sin c c for triclinic lattice, convert to fractional coordinates, c find image, then translate fractional back to Cartesian c else if (triclinic) then zr = zr / gamma_term yr = (yr - zr*beta_term) / gamma_sin xr = xr - yr*gamma_cos - zr*beta_cos xr = xr + xmove do while (abs(xr) .gt. xcell2) xr = xr - sign(xcell,xr) end do yr = yr + ymove do while (abs(yr) .gt. ycell2) yr = yr - sign(ycell,yr) end do zr = zr + zmove do while (abs(zr) .gt. zcell2) zr = zr - sign(zcell,zr) end do xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term c c for truncated octahedron, remove the corner pieces c else if (octahedron) then do while (abs(xr) .gt. xbox2) xr = xr - sign(xbox,xr) end do do while (abs(yr) .gt. ybox2) yr = yr - sign(ybox,yr) end do do while (abs(zr) .gt. zbox2) zr = zr - sign(zbox,zr) end do if (abs(xr)+abs(yr)+abs(zr) .gt. box34) then xr = xr - sign(xbox2,xr) yr = yr - sign(ybox2,yr) zr = zr - sign(zbox2,zr) end if c c for rhombic dodecahedron, align along the x- and y-axes c else if (dodecadron) then do while (abs(xr) .gt. xbox2) xr = xr - sign(xbox,xr) end do do while (abs(yr) .gt. ybox2) yr = yr - sign(ybox,yr) end do zr = zr - root2*zbox*nint(zr/(zbox*root2)) corr = xbox2 * int(abs(xr/xbox)+abs(yr/ybox) & +abs(root2*zr/zbox)) xr = xr - sign(corr,xr) yr = yr - sign(corr,yr) zr = zr - sign(corr,zr)*root2 end if return end c c c ########################################################### c ## ## c ## subroutine imagen -- fast minimum image magnitude ## c ## ## c ########################################################### c c c "imagen" takes the components of pairwise distance between c two points and converts to the components of the minimum c image distance c c note this is a fast version for use in computing the 3D c distance during neighbor list construction c c subroutine imagen (xr,yr,zr) use boxes use math implicit none real*8 xr,yr,zr real*8 corr c c c for orthogonal lattice, find the desired image directly c if (orthogonal) then xr = xr - xbox*nint(xr/xbox) yr = yr - ybox*nint(yr/ybox) zr = zr - zbox*nint(zr/zbox) c c for monoclinic lattice, convert x and z to fractional, c find desired image, then translate back to Cartesian c else if (monoclinic) then zr = zr / beta_sin xr = xr - zr*beta_cos xr = xr - xbox*nint(xr/xbox) yr = yr - ybox*nint(yr/ybox) zr = zr - zbox*nint(zr/zbox) xr = xr + zr*beta_cos zr = zr * beta_sin c c for triclinic lattice, convert to fractional coordinates, c find image, then translate fractional back to Cartesian c else if (triclinic) then zr = zr / gamma_term yr = (yr - zr*beta_term) / gamma_sin xr = xr - yr*gamma_cos - zr*beta_cos xr = xr - xbox*nint(xr/xbox) yr = yr - ybox*nint(yr/ybox) zr = zr - zbox*nint(zr/zbox) xr = xr + yr*gamma_cos + zr*beta_cos yr = yr*gamma_sin + zr*beta_term zr = zr * gamma_term c c for truncated octahedron, remove the corner pieces c else if (octahedron) then xr = xr - xbox*nint(xr/xbox) yr = yr - ybox*nint(yr/ybox) zr = zr - zbox*nint(zr/zbox) if (abs(xr)+abs(yr)+abs(zr) .gt. box34) then xr = xr - sign(xbox2,xr) yr = yr - sign(ybox2,yr) zr = zr - sign(zbox2,zr) end if c c for rhombic dodecahedron, align along the x- and y-axes c else if (dodecadron) then xr = xr - xbox*nint(xr/xbox) yr = yr - ybox*nint(yr/ybox) zr = zr - root2*zbox*nint(zr/(zbox*root2)) corr = xbox2 * int(abs(xr/xbox)+abs(yr/ybox) & +abs(root2*zr/zbox)) xr = xr - sign(corr,xr) yr = yr - sign(corr,yr) zr = zr - sign(corr,zr)*root2 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 impose -- superimpose two coordinate sets ## c ## ## c ############################################################## c c c "impose" performs the least squares best superposition c of two atomic coordinate sets via a quaternion method; c upon return, the first coordinate set is unchanged while c the second set is translated and rotated to give best fit; c the final root mean square fit is returned in "rmsvalue" c c subroutine impose (n1,x1,y1,z1,n2,x2,y2,z2,rmsvalue) use align use inform use iounit implicit none integer i,n1,n2,nmax real*8 xmid,ymid,zmid real*8 rmsvalue,rmsfit real*8 x1(*),x2(*) real*8 y1(*),y2(*) real*8 z1(*),z2(*) c c c perform dynamic allocation of some global arrays c nmax = max(n1,n2) if (.not. allocated(ifit)) allocate (ifit(2,nmax)) if (.not. allocated(wfit)) allocate (wfit(nmax)) c c superimpose the full structures if not specified c if (nfit .eq. 0) then nfit = min(n1,n2) do i = 1, nfit ifit(1,i) = i ifit(2,i) = i wfit(i) = 1.0d0 end do end if c c if the weights are all zero, set them to unity c do i = 1, nfit if (wfit(i) .ne. 0.0d0) goto 10 end do do i = 1, nfit wfit(i) = 1.0d0 end do 10 continue c c find the rms fit of input coordinates c if (verbose) then rmsvalue = rmsfit (x1,y1,z1,x2,y2,z2) write (iout,20) rmsvalue 20 format (/,' IMPOSE -- Input Coordinates',12x,f12.6) end if c c superimpose the centroids of active atom pairs c call center (n1,x1,y1,z1,n2,x2,y2,z2,xmid,ymid,zmid) if (verbose) then rmsvalue = rmsfit (x1,y1,z1,x2,y2,z2) write (iout,30) rmsvalue 30 format (' IMPOSE -- After Translation',12x,f12.6) end if c c use a quaternion method to achieve the superposition c call quatfit (n1,x1,y1,z1,n2,x2,y2,z2) rmsvalue = rmsfit (x1,y1,z1,x2,y2,z2) if (verbose) then write (iout,40) rmsvalue 40 format (' IMPOSE -- After Rotation',15x,f12.6) end if c c translate both coordinate sets so as to return c the first set to its original position c do i = 1, n1 x1(i) = x1(i) + xmid y1(i) = y1(i) + ymid z1(i) = z1(i) + zmid end do do i = 1, n2 x2(i) = x2(i) + xmid y2(i) = y2(i) + ymid z2(i) = z2(i) + zmid 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 improp -- improper dihedrals in current structure ## c ## ## c ######################################################3########### c c c niprop total number of improper dihedral angles in the system c iiprop numbers of the atoms in each improper dihedral angle c kprop force constant values for improper dihedral angles c vprop ideal improper dihedral angle value in degrees c c module improp implicit none integer niprop integer, allocatable :: iiprop(:,:) real*8, allocatable :: kprop(:) real*8, allocatable :: vprop(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module imptor -- improper torsions in current structure ## c ## ## c ################################################################# c c c nitors total number of improper torsional angles in the system c iitors numbers of the atoms in each improper torsional angle c itors1 1-fold amplitude and phase for each improper torsion c itors2 2-fold amplitude and phase for each improper torsion c itors3 3-fold amplitude and phase for each improper torsion c c module imptor implicit none integer nitors integer, allocatable :: iitors(:,:) real*8, allocatable :: itors1(:,:) real*8, allocatable :: itors2(:,:) real*8, allocatable :: itors3(:,:) save end c c c ############################################################# c ## COPYRIGHT (C) 1999 by Pengyu Ren & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################# c c ############################################################## c ## ## c ## subroutine induce -- evaluate induced dipole moments ## c ## ## c ############################################################## c c c "induce" computes the induced dipole moments at polarizable c sites due to direct or mutual polarization c c assumes multipole components have already been rotated into c the global coordinate frame; computes induced dipoles based c on full system, use of active or inactive atoms is ignored c c subroutine induce use inform use iounit use limits use mpole use polar use polpot use potent use solpot use units use uprior implicit none integer i,j,k,ii real*8 norm logical header c c c choose the method for computation of induced dipoles c if (solvtyp(1:2) .eq. 'PB') then call induce0d else if (solvtyp(1:2) .eq. 'GK') then call induce0c else if (poltyp .eq. 'TCG') then call induce0b else call induce0a end if c c update the lists of previous induced dipole values c if (use_pred) then nualt = min(nualt+1,maxualt) do ii = 1, npole i = ipole(ii) do j = 1, 3 do k = nualt, 2, -1 udalt(k,j,i) = udalt(k-1,j,i) upalt(k,j,i) = upalt(k-1,j,i) end do udalt(1,j,i) = uind(j,i) upalt(1,j,i) = uinp(j,i) if (use_solv) then do k = nualt, 2, -1 usalt(k,j,i) = usalt(k-1,j,i) upsalt(k,j,i) = upsalt(k-1,j,i) end do usalt(1,j,i) = uinds(j,i) upsalt(1,j,i) = uinps(j,i) end if end do end do end if c c print out a list of the final induced dipole moments c if (use_polar .and. debug) then header = .true. do ii = 1, npole i = ipole(ii) if (polarity(i) .ne. 0.0d0) then if (header) then header = .false. if (solvtyp(1:2).eq.'GK' .or. & solvtyp(1:2).eq.'PB') then write (iout,10) 10 format (/,' Vacuum Induced Dipole Moments', & ' (Debye) :') else write (iout,20) 20 format (/,' Induced Dipole Moments (Debye) :') end if write (iout,30) 30 format (/,4x,'Atom',15x,'X',12x,'Y',12x,'Z', & 11x,'Total',/) end if norm = sqrt(uind(1,i)**2+uind(2,i)**2+uind(3,i)**2) write (iout,40) i,(debye*uind(j,i),j=1,3),debye*norm 40 format (i8,5x,3f13.4,1x,f13.4) end if end do header = .true. if (solvtyp(1:2).eq.'GK' .or. solvtyp(1:2).eq.'PB') then do ii = 1, npole i = ipole(ii) if (polarity(i) .ne. 0.0d0) then if (header) then header = .false. write (iout,50) 50 format (/,' SCRF Induced Dipole Moments', & ' (Debye) :') write (iout,60) 60 format (/,4x,'Atom',15x,'X',12x,'Y',12x,'Z', & 11x,'Total',/) end if norm = sqrt(uinds(1,i)**2+uinds(2,i)**2 & +uinds(3,i)**2) write (iout,70) i,(debye*uinds(j,i),j=1,3), & debye*norm 70 format (i8,5x,3f13.4,1x,f13.4) end if end do end if end if return end c c c ################################################################# c ## ## c ## subroutine induce0a -- conjugate gradient dipole solver ## c ## ## c ################################################################# c c c "induce0a" computes the induced dipole moments at polarizable c sites using a preconditioned conjugate gradient solver c c subroutine induce0a use atoms use expol use extfld use ielscf use inform use iounit use limits use mpole use neigh use polar use polopt use polpcg use polpot use potent use units use uprior implicit none integer i,j,k integer ii,iter integer miniter integer maxiter real*8 polmin real*8 eps,epsold real*8 epsd,epsp real*8 udsum,upsum real*8 a,ap,b,bp real*8 sum,sump,term real*8, allocatable :: poli(:) real*8, allocatable :: field(:,:) real*8, allocatable :: fieldp(:,:) real*8, allocatable :: rsd(:,:) real*8, allocatable :: rsdp(:,:) real*8, allocatable :: zrsd(:,:) real*8, allocatable :: zrsdp(:,:) real*8, allocatable :: conj(:,:) real*8, allocatable :: conjp(:,:) real*8, allocatable :: vec(:,:) real*8, allocatable :: vecp(:,:) real*8, allocatable :: usum(:,:) real*8, allocatable :: usump(:,:) logical done character*6 mode c c c zero out the induced dipoles at each site c do i = 1, n do j = 1, 3 uind(j,i) = 0.0d0 uinp(j,i) = 0.0d0 end do end do if (.not. use_polar) return c c perform dynamic allocation of some local arrays c allocate (field(3,n)) allocate (fieldp(3,n)) c c compute induced dipoles based on direct and mutual fields c 10 continue c c get the electrostatic field due to permanent multipoles c if (use_ewald) then call dfield0c (field,fieldp) else if (use_mlist) then call dfield0b (field,fieldp) else call dfield0a (field,fieldp) end if c c add external electric field to the direct field values c if (use_exfld) then do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) + exfld(j) fieldp(j,i) = fieldp(j,i) + exfld(j) end do end do end if c c modify polarizability to account for exchange polarization c if (use_expol) call alterpol c c set induced dipoles to polarizability times direct field c do ii = 1, npole i = ipole(ii) if (douind(i) .and. .not.use_expol) then do j = 1, 3 udir(j,i) = polarity(i) * field(j,i) udirp(j,i) = polarity(i) * fieldp(j,i) if (pcgguess) then uind(j,i) = udir(j,i) uinp(j,i) = udirp(j,i) end if end do else if (douind(i) .and. use_expol) then do j = 1, 3 udir(j,i) = polarity(i) * field(j,i) udirp(j,i) = polarity(i) * fieldp(j,i) if (pcgguess) then do k = 1, 3 uind(j,i) = polarity(i) & * (polinv(j,1,i)*field(1,i) & + polinv(j,2,i)*field(2,i) & + polinv(j,3,i)*field(3,i)) uinp(j,i) = polarity(i) & * (polinv(j,1,i)*fieldp(1,i) & + polinv(j,2,i)*fieldp(2,i) & + polinv(j,3,i)*fieldp(3,i)) end do end if end do end if end do c get induced dipoles via the OPT extrapolation method c if (poltyp .eq. 'OPT') then do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uopt(0,j,i) = udir(j,i) uoptp(0,j,i) = udirp(j,i) end do end if end do do k = 1, optorder optlevel = k - 1 if (use_ewald) then call ufield0c (field,fieldp) else if (use_mlist) then call ufield0b (field,fieldp) else call ufield0a (field,fieldp) end if do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uopt(k,j,i) = polarity(i) * field(j,i) uoptp(k,j,i) = polarity(i) * fieldp(j,i) uind(j,i) = uopt(k,j,i) uinp(j,i) = uoptp(k,j,i) end do end if end do end do allocate (usum(3,n)) allocate (usump(3,n)) do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = 0.0d0 uinp(j,i) = 0.0d0 usum(j,i) = 0.0d0 usump(j,i) = 0.0d0 do k = 0, optorder usum(j,i) = usum(j,i) + uopt(k,j,i) usump(j,i) = usump(j,i) + uoptp(k,j,i) uind(j,i) = uind(j,i) + copt(k)*usum(j,i) uinp(j,i) = uinp(j,i) + copt(k)*usump(j,i) end do end do end if end do deallocate (usum) deallocate (usump) end if c c set tolerances for computation of mutual induced dipoles c if (poltyp .eq. 'MUTUAL') then done = .false. miniter = min(3,n) maxiter = 100 iter = 0 polmin = 0.00000001d0 eps = 100.0d0 c c estimate induced dipoles using a polynomial predictor c if (use_pred .and. nualt.eq.maxualt) then call ulspred do ii = 1, npole i = ipole(ii) do j = 1, 3 udsum = 0.0d0 upsum = 0.0d0 do k = 1, nualt-1 udsum = udsum + bpred(k)*udalt(k,j,i) upsum = upsum + bpredp(k)*upalt(k,j,i) end do uind(j,i) = udsum uinp(j,i) = upsum end do end do end if c c estimate induced dipoles via inertial extended Lagrangian c if (use_ielscf) then do ii = 1, npole i = ipole(ii) do j = 1, 3 uind(j,i) = uaux(j,i) uinp(j,i) = upaux(j,i) end do end do end if c c perform dynamic allocation of some local arrays c allocate (poli(n)) allocate (rsd(3,n)) allocate (rsdp(3,n)) allocate (zrsd(3,n)) allocate (zrsdp(3,n)) allocate (conj(3,n)) allocate (conjp(3,n)) allocate (vec(3,n)) allocate (vecp(3,n)) c c get the electrostatic field due to induced dipoles c if (use_ewald) then call ufield0c (field,fieldp) else if (use_mlist) then call ufield0b (field,fieldp) else call ufield0a (field,fieldp) end if c c set initial values for the residual vector components c do ii = 1, npole i = ipole(ii) if (douind(i)) then poli(i) = max(polmin,polarity(i)) do j = 1, 3 if (pcgguess) then if (use_expol) then rsd(j,i) = (udir(j,i) & - uind(1,i)*polscale(j,1,i) & - uind(2,i)*polscale(j,2,i) & - uind(3,i)*polscale(j,3,i)) & /poli(i) + field(j,i) rsdp(j,i) = (udirp(j,i) & - uinp(1,i)*polscale(j,1,i) & - uinp(2,i)*polscale(j,2,i) & - uinp(3,i)*polscale(j,3,i)) & /poli(i) + fieldp(j,i) else rsd(j,i) = (udir(j,i)-uind(j,i))/poli(i) & + field(j,i) rsdp(j,i) = (udirp(j,i)-uinp(j,i))/poli(i) & + fieldp(j,i) end if else rsd(j,i) = udir(j,i) / poli(i) rsdp(j,i) = udirp(j,i) / poli(i) end if zrsd(j,i) = rsd(j,i) zrsdp(j,i) = rsdp(j,i) end do else do j = 1, 3 rsd(j,i) = 0.0d0 rsdp(j,i) = 0.0d0 zrsd(j,i) = 0.0d0 zrsdp(j,i) = 0.0d0 end do end if end do c c perform dynamic allocation of some global arrays c if (pcgprec) then if (.not. allocated(mindex)) allocate (mindex(n)) if (.not. allocated(minv)) allocate (minv(3*maxulst*n)) c c apply a sparse matrix conjugate gradient preconditioner c mode = 'BUILD' if (use_ulist) then call uscale0b (mode,rsd,rsdp,zrsd,zrsdp) mode = 'APPLY' call uscale0b (mode,rsd,rsdp,zrsd,zrsdp) else call uscale0a (mode,rsd,rsdp,zrsd,zrsdp) mode = 'APPLY' call uscale0a (mode,rsd,rsdp,zrsd,zrsdp) end if end if c c set the initial conjugate vector to be the residuals c do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 conj(j,i) = zrsd(j,i) conjp(j,i) = zrsdp(j,i) end do end if end do c c conjugate gradient iteration of the mutual induced dipoles c do while (.not. done) iter = iter + 1 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 vec(j,i) = uind(j,i) vecp(j,i) = uinp(j,i) uind(j,i) = conj(j,i) uinp(j,i) = conjp(j,i) end do end if end do if (use_ewald) then call ufield0c (field,fieldp) else if (use_mlist) then call ufield0b (field,fieldp) else call ufield0a (field,fieldp) end if do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = vec(j,i) uinp(j,i) = vecp(j,i) if (use_expol) then vec(j,i) = (conj(1,i)*polscale(j,1,i) & + conj(2,i)*polscale(j,2,i) & + conj(3,i)*polscale(j,3,i)) 7 /poli(i) - field(j,i) vecp(j,i) = (conjp(1,i)*polscale(j,1,i) & + conjp(2,i)*polscale(j,2,i) & + conjp(3,i)*polscale(j,3,i)) & /poli(i) - field(j,i) else vec(j,i) = conj(j,i)/poli(i) - field(j,i) vecp(j,i) = conjp(j,i)/poli(i) - fieldp(j,i) end if end do end if end do a = 0.0d0 ap = 0.0d0 sum = 0.0d0 sump = 0.0d0 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 a = a + conj(j,i)*vec(j,i) ap = ap + conjp(j,i)*vecp(j,i) sum = sum + rsd(j,i)*zrsd(j,i) sump = sump + rsdp(j,i)*zrsdp(j,i) end do end if end do if (a .ne. 0.0d0) a = sum / a if (ap .ne. 0.0d0) ap = sump / ap do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = uind(j,i) + a*conj(j,i) uinp(j,i) = uinp(j,i) + ap*conjp(j,i) rsd(j,i) = rsd(j,i) - a*vec(j,i) rsdp(j,i) = rsdp(j,i) - ap*vecp(j,i) zrsd(j,i) = rsd(j,i) zrsdp(j,i) = rsdp(j,i) end do end if end do if (pcgprec) then if (use_ulist) then call uscale0b (mode,rsd,rsdp,zrsd,zrsdp) else call uscale0a (mode,rsd,rsdp,zrsd,zrsdp) end if end if b = 0.0d0 bp = 0.0d0 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 b = b + rsd(j,i)*zrsd(j,i) bp = bp + rsdp(j,i)*zrsdp(j,i) end do end if end do if (sum .ne. 0.0d0) b = b / sum if (sump .ne. 0.0d0) bp = bp / sump epsd = 0.0d0 epsp = 0.0d0 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 conj(j,i) = zrsd(j,i) + b*conj(j,i) conjp(j,i) = zrsdp(j,i) + bp*conjp(j,i) epsd = epsd + rsd(j,i)*rsd(j,i) epsp = epsp + rsdp(j,i)*rsdp(j,i) end do end if end do c c check the convergence of the mutual induced dipoles c epsold = eps eps = max(epsd,epsp) eps = debye * sqrt(eps/dble(npolar)) if (debug) then if (iter .eq. 1) then write (iout,20) 20 format (/,' Determination of SCF Induced Dipole', & ' Moments :', & //,4x,'Iter',7x,'RMS Residual (Debye)',/) end if write (iout,30) iter,eps 30 format (i8,7x,f16.10) end if if (eps .lt. poleps) done = .true. c if (eps .gt. epsold) done = .true. if (iter .lt. miniter) done = .false. if (iter .ge. politer) done = .true. c c apply a "peek" iteration to the mutual induced dipoles c if (done) then do ii = 1, npole i = ipole(ii) if (douind(i)) then term = pcgpeek * poli(i) do j = 1, 3 uind(j,i) = uind(j,i) + term*rsd(j,i) uinp(j,i) = uinp(j,i) + term*rsdp(j,i) end do end if end do end if end do c c perform deallocation of some local arrays c deallocate (poli) deallocate (rsd) deallocate (rsdp) deallocate (zrsd) deallocate (zrsdp) deallocate (conj) deallocate (conjp) deallocate (vec) deallocate (vecp) c c print the results from the conjugate gradient iteration c if (polprt .or. debug) then write (iout,40) iter,eps 40 format (/,' Induced Dipoles :',4x,'Iterations',i5, & 7x,'RMS Residual',f15.10) end if c c terminate the calculation if dipoles fail to converge c if (iter.ge.maxiter .or. eps.gt.epsold) then if (use_ulist) then use_ulist = .false. usolvcut = 0.0d0 if (verbose) then write (iout,50) 50 format (/,' INDUCE -- Switching to Diagonal', & ' PCG Preconditioner') end if goto 10 else write (iout,60) 60 format (/,' INDUCE -- Warning, Induced Dipoles', & ' are not Converged') call prterr call fatal end if end if end if c c perform deallocation of some local arrays c deallocate (field) deallocate (fieldp) return end c c c ################################################################# c ## ## c ## subroutine dfield0a -- direct induction via double loop ## c ## ## c ################################################################# c c c "dfield0a" computes the direct electrostatic field due to c permanent multipole moments via a double loop c c subroutine dfield0a (field,fieldp) use atoms use bound use cell use chgpen use couple use mplpot use mpole use polar use polgrp use polpot use shunt implicit none integer i,j,k,m integer ii,kk real*8 xr,yr,zr real*8 r,r2,rr3 real*8 rr5,rr7 real*8 rr3i,rr5i,rr7i real*8 rr3k,rr5k,rr7k real*8 ci,dix,diy,diz real*8 qixx,qixy,qixz real*8 qiyy,qiyz,qizz real*8 ck,dkx,dky,dkz real*8 qkxx,qkxy,qkxz real*8 qkyy,qkyz,qkzz real*8 dir,dkr real*8 qix,qiy,qiz,qir real*8 qkx,qky,qkz,qkr real*8 corei,corek real*8 vali,valk real*8 alphai,alphak real*8 fid(3),fkd(3) real*8 fip(3),fkp(3) real*8 dmpi(7),dmpk(7) real*8 dmpik(7) real*8, allocatable :: dscale(:) real*8, allocatable :: pscale(:) real*8 field(3,*) real*8 fieldp(3,*) character*6 mode c c c zero out the value of the field at each site c do i = 1, n do j = 1, 3 field(j,i) = 0.0d0 fieldp(j,i) = 0.0d0 end do end do c c set the switching function coefficients c mode = 'MPOLE' call switch (mode) c c perform dynamic allocation of some local arrays c allocate (dscale(n)) allocate (pscale(n)) c c set array needed to scale atom and group interactions c do i = 1, n dscale(i) = 1.0d0 pscale(i) = 1.0d0 end do c c find the electrostatic field due to permanent multipoles c do ii = 1, npole-1 i = ipole(ii) ci = rpole(1,i) dix = rpole(2,i) diy = rpole(3,i) diz = rpole(4,i) qixx = rpole(5,i) qixy = rpole(6,i) qixz = rpole(7,i) qiyy = rpole(9,i) qiyz = rpole(10,i) qizz = rpole(13,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c if (dpequal) then 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 dscale(i12(j,i)) = pscale(i12(j,i)) 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 dscale(i13(j,i)) = pscale(i13(j,i)) 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 dscale(i14(j,i)) = pscale(i14(j,i)) 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 dscale(i15(j,i)) = pscale(i15(j,i)) end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = d1scale end do do j = 1, np12(i) dscale(ip12(j,i)) = d2scale end do do j = 1, np13(i) dscale(ip13(j,i)) = d3scale end do do j = 1, np14(i) dscale(ip14(j,i)) = d4scale end do end if c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) ck = rpole(1,k) dkx = rpole(2,k) dky = rpole(3,k) dkz = rpole(4,k) qkxx = rpole(5,k) qkxy = rpole(6,k) qkxz = rpole(7,k) qkyy = rpole(9,k) qkyz = rpole(10,k) qkzz = rpole(13,k) c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr qix = qixx*xr + qixy*yr + qixz*zr qiy = qixy*xr + qiyy*yr + qiyz*zr qiz = qixz*xr + qiyz*yr + qizz*zr qir = qix*xr + qiy*yr + qiz*zr dkr = dkx*xr + dky*yr + dkz*zr qkx = qkxx*xr + qkxy*yr + qkxz*zr qky = qkxy*xr + qkyy*yr + qkyz*zr qkz = qkxz*xr + qkyz*yr + qkzz*zr qkr = qkx*xr + qky*yr + qkz*zr c c find the field components for Thole polarization damping c if (use_thole) then call damptholed (i,k,7,r,dmpik) rr3 = dmpik(3) / (r*r2) rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2) fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dkx + 2.0d0*rr5*qkx fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dky + 2.0d0*rr5*qky fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dkz + 2.0d0*rr5*qkz fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*dix - 2.0d0*rr5*qix fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*diy - 2.0d0*rr5*qiy fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*diz - 2.0d0*rr5*qiz c c find the field components for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampdir (r,alphai,alphak,dmpi,dmpk) rr3 = 1.0d0 / (r*r2) rr5 = 3.0d0 * rr3 / r2 rr7 = 5.0d0 * rr5 / r2 rr3i = dmpi(3) * rr3 rr5i = dmpi(5) * rr5 rr7i = dmpi(7) * rr7 rr3k = dmpk(3) * rr3 rr5k = dmpk(5) * rr5 rr7k = dmpk(7) * rr7 fid(1) = -xr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkx + 2.0d0*rr5k*qkx fid(2) = -yr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dky + 2.0d0*rr5k*qky fid(3) = -zr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkz + 2.0d0*rr5k*qkz fkd(1) = xr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*dix - 2.0d0*rr5i*qix fkd(2) = yr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diy - 2.0d0*rr5i*qiy fkd(3) = zr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diz - 2.0d0*rr5i*qiz end if c c increment the direct electrostatic field components c do j = 1, 3 field(j,i) = field(j,i) + fid(j)*dscale(k) field(j,k) = field(j,k) + fkd(j)*dscale(k) fieldp(j,i) = fieldp(j,i) + fid(j)*pscale(k) fieldp(j,k) = fieldp(j,k) + fkd(j)*pscale(k) end do end if end do c c reset exclusion coefficients for connected atoms c if (dpequal) then do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 dscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 dscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 dscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 dscale(i15(j,i)) = 1.0d0 end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) dscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) dscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) dscale(ip14(j,i)) = 1.0d0 end do end if end do c c periodic boundary for large cutoffs via replicates method c if (use_replica) then do ii = 1, npole i = ipole(ii) ci = rpole(1,i) dix = rpole(2,i) diy = rpole(3,i) diz = rpole(4,i) qixx = rpole(5,i) qixy = rpole(6,i) qixz = rpole(7,i) qiyy = rpole(9,i) qiyz = rpole(10,i) qizz = rpole(13,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c if (dpequal) then 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 dscale(i12(j,i)) = pscale(i12(j,i)) 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 dscale(i13(j,i)) = pscale(i13(j,i)) 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 dscale(i14(j,i)) = pscale(i14(j,i)) 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 dscale(i15(j,i)) = pscale(i15(j,i)) end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = d1scale end do do j = 1, np12(i) dscale(ip12(j,i)) = d2scale end do do j = 1, np13(i) dscale(ip13(j,i)) = d3scale end do do j = 1, np14(i) dscale(ip14(j,i)) = d4scale end do end if c c evaluate all sites within the cutoff distance c do kk = ii, npole k = ipole(kk) ck = rpole(1,k) dkx = rpole(2,k) dky = rpole(3,k) dkz = rpole(4,k) qkxx = rpole(5,k) qkxy = rpole(6,k) qkxz = rpole(7,k) qkyy = rpole(9,k) qkyz = rpole(10,k) qkzz = rpole(13,k) do m = 2, ncell xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) call imager (xr,yr,zr,m) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr qix = qixx*xr + qixy*yr + qixz*zr qiy = qixy*xr + qiyy*yr + qiyz*zr qiz = qixz*xr + qiyz*yr + qizz*zr qir = qix*xr + qiy*yr + qiz*zr dkr = dkx*xr + dky*yr + dkz*zr qkx = qkxx*xr + qkxy*yr + qkxz*zr qky = qkxy*xr + qkyy*yr + qkyz*zr qkz = qkxz*xr + qkyz*yr + qkzz*zr qkr = qkx*xr + qky*yr + qkz*zr c c find the field components for Thole polarization damping c if (use_thole) then call damptholed (i,k,7,r,dmpik) rr3 = dmpik(3) / (r*r2) rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2) fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dkx + 2.0d0*rr5*qkx fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dky + 2.0d0*rr5*qky fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dkz + 2.0d0*rr5*qkz fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*dix - 2.0d0*rr5*qix fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*diy - 2.0d0*rr5*qiy fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*diz - 2.0d0*rr5*qiz c c find the field components for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampdir (r,alphai,alphak,dmpi,dmpk) rr3 = 1.0d0 / (r*r2) rr5 = 3.0d0 * rr3 / r2 rr7 = 5.0d0 * rr5 / r2 rr3i = dmpi(3) * rr3 rr5i = dmpi(5) * rr5 rr7i = dmpi(7) * rr7 rr3k = dmpk(3) * rr3 rr5k = dmpk(5) * rr5 rr7k = dmpk(7) * rr7 fid(1) = -xr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkx + 2.0d0*rr5k*qkx fid(2) = -yr*(rr3*corek + rr3k*valk & - rr5k*dkr+rr7k*qkr) & - rr3k*dky + 2.0d0*rr5k*qky fid(3) = -zr*(rr3*corek + rr3k*valk & - rr5k*dkr+rr7k*qkr) & - rr3k*dkz + 2.0d0*rr5k*qkz fkd(1) = xr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*dix - 2.0d0*rr5i*qix fkd(2) = yr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diy - 2.0d0*rr5i*qiy fkd(3) = zr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diz - 2.0d0*rr5i*qiz end if c c increment the direct electrostatic field components c do j = 1, 3 fip(j) = fid(j) fkp(j) = fkd(j) end do if (use_polymer .and. r2.le.polycut2) then do j = 1, 3 fid(j) = fid(j) * dscale(k) fip(j) = fip(j) * pscale(k) fkd(j) = fkd(j) * dscale(k) fkp(j) = fkp(j) * pscale(k) end do end if do j = 1, 3 field(j,i) = field(j,i) + fid(j) fieldp(j,i) = fieldp(j,i) + fip(j) if (i .ne. k) then field(j,k) = field(j,k) + fkd(j) fieldp(j,k) = fieldp(j,k) + fkp(j) end if end do end if end do end do c c reset exclusion coefficients for connected atoms c if (dpequal) then do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 dscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 dscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 dscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 dscale(i15(j,i)) = 1.0d0 end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) dscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) dscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) dscale(ip14(j,i)) = 1.0d0 end do end if end do end if c c perform deallocation of some local arrays c deallocate (dscale) deallocate (pscale) return end c c c ################################################################# c ## ## c ## subroutine ufield0a -- mutual induction via double loop ## c ## ## c ################################################################# c c c "ufield0a" computes the mutual electrostatic field due to c induced dipole moments via a double loop c c subroutine ufield0a (field,fieldp) use atoms use bound use cell use chgpen use couple use mplpot use mpole use polar use polgrp use polpot use shunt implicit none integer i,j,k,m integer ii,kk real*8 xr,yr,zr real*8 r,r2,rr3,rr5 real*8 dix,diy,diz real*8 pix,piy,piz real*8 dkx,dky,dkz real*8 pkx,pky,pkz real*8 dir,pir real*8 dkr,pkr real*8 corei,corek real*8 vali,valk real*8 alphai,alphak real*8 fid(3),fkd(3) real*8 fip(3),fkp(3) real*8 dmpik(5) real*8, allocatable :: uscale(:) real*8, allocatable :: wscale(:) real*8 field(3,*) real*8 fieldp(3,*) character*6 mode c c c zero out the value of the field at each site c do i = 1, n do j = 1, 3 field(j,i) = 0.0d0 fieldp(j,i) = 0.0d0 end do end do c c set the switching function coefficients c mode = 'MPOLE' call switch (mode) c c perform dynamic allocation of some local arrays c allocate (uscale(n)) allocate (wscale(n)) c c set array needed to scale atom and group interactions c do i = 1, n uscale(i) = 1.0d0 wscale(i) = 1.0d0 end do c c find the electrostatic field due to mutual induced dipoles c do ii = 1, npole-1 i = ipole(ii) dix = uind(1,i) diy = uind(2,i) diz = uind(3,i) pix = uinp(1,i) piy = uinp(2,i) piz = uinp(3,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do do j = 1, n12(i) wscale(i12(j,i)) = w2scale end do do j = 1, n13(i) wscale(i13(j,i)) = w3scale end do do j = 1, n14(i) wscale(i14(j,i)) = w4scale end do do j = 1, n15(i) wscale(i15(j,i)) = w5scale end do c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) dkx = uind(1,k) dky = uind(2,k) dkz = uind(3,k) pkx = uinp(1,k) pky = uinp(2,k) pkz = uinp(3,k) c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr dkr = dkx*xr + dky*yr + dkz*zr pir = pix*xr + piy*yr + piz*zr pkr = pkx*xr + pky*yr + pkz*zr c c find the scale factors for Thole polarization damping c if (use_thole) then call dampthole (i,k,5,r,dmpik) dmpik(3) = uscale(k) * dmpik(3) dmpik(5) = uscale(k) * dmpik(5) c c find the scale factors for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampmut (r,alphai,alphak,dmpik) dmpik(3) = wscale(k) * dmpik(3) dmpik(5) = wscale(k) * dmpik(5) end if c c increment the mutual electrostatic field components c rr3 = -dmpik(3) / (r*r2) rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) fid(1) = rr3*dkx + rr5*dkr*xr fid(2) = rr3*dky + rr5*dkr*yr fid(3) = rr3*dkz + rr5*dkr*zr fkd(1) = rr3*dix + rr5*dir*xr fkd(2) = rr3*diy + rr5*dir*yr fkd(3) = rr3*diz + rr5*dir*zr fip(1) = rr3*pkx + rr5*pkr*xr fip(2) = rr3*pky + rr5*pkr*yr fip(3) = rr3*pkz + rr5*pkr*zr fkp(1) = rr3*pix + rr5*pir*xr fkp(2) = rr3*piy + rr5*pir*yr fkp(3) = rr3*piz + rr5*pir*zr do j = 1, 3 field(j,i) = field(j,i) + fid(j) field(j,k) = field(j,k) + fkd(j) fieldp(j,i) = fieldp(j,i) + fip(j) fieldp(j,k) = fieldp(j,k) + fkp(j) end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 end do do j = 1, n12(i) wscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) wscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) wscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) wscale(i15(j,i)) = 1.0d0 end do end do c c periodic boundary for large cutoffs via replicates method c if (use_replica) then do ii = 1, npole i = ipole(ii) dix = uind(1,i) diy = uind(2,i) diz = uind(3,i) pix = uinp(1,i) piy = uinp(2,i) piz = uinp(3,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do do j = 1, n12(i) wscale(i12(j,i)) = w2scale end do do j = 1, n13(i) wscale(i13(j,i)) = w3scale end do do j = 1, n14(i) wscale(i14(j,i)) = w4scale end do do j = 1, n15(i) wscale(i15(j,i)) = w5scale end do c c evaluate all sites within the cutoff distance c do kk = ii, npole k = ipole(kk) dkx = uind(1,k) dky = uind(2,k) dkz = uind(3,k) pkx = uinp(1,k) pky = uinp(2,k) pkz = uinp(3,k) do m = 2, ncell xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) call imager (xr,yr,zr,m) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr dkr = dkx*xr + dky*yr + dkz*zr pir = pix*xr + piy*yr + piz*zr pkr = pkx*xr + pky*yr + pkz*zr c c find the scale factors for Thole polarization damping c if (use_thole) then call dampthole (i,k,5,r,dmpik) dmpik(3) = uscale(k) * dmpik(3) dmpik(5) = uscale(k) * dmpik(5) c c find the scale factors for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampmut (r,alphai,alphak,dmpik) dmpik(3) = wscale(k) * dmpik(3) dmpik(5) = wscale(k) * dmpik(5) end if c c increment the mutual electrostatic field components c rr3 = -dmpik(3) / (r*r2) rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) fid(1) = rr3*dkx + rr5*dkr*xr fid(2) = rr3*dky + rr5*dkr*yr fid(3) = rr3*dkz + rr5*dkr*zr fkd(1) = rr3*dix + rr5*dir*xr fkd(2) = rr3*diy + rr5*dir*yr fkd(3) = rr3*diz + rr5*dir*zr fip(1) = rr3*pkx + rr5*pkr*xr fip(2) = rr3*pky + rr5*pkr*yr fip(3) = rr3*pkz + rr5*pkr*zr fkp(1) = rr3*pix + rr5*pir*xr fkp(2) = rr3*piy + rr5*pir*yr fkp(3) = rr3*piz + rr5*pir*zr if (use_polymer) then if (r2 .le. polycut2) then do j = 1, 3 fid(j) = fid(j) * uscale(k) fkd(j) = fkd(j) * uscale(k) fip(j) = fip(j) * uscale(k) fkp(j) = fkp(j) * uscale(k) end do end if end if do j = 1, 3 field(j,i) = field(j,i) + fid(j) fieldp(j,i) = fieldp(j,i) + fip(j) if (i .ne. k) then field(j,k) = field(j,k) + fkd(j) fieldp(j,k) = fieldp(j,k) + fkp(j) end if end do end if end do end do c c reset exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 end do do j = 1, n12(i) wscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) wscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) wscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) wscale(i15(j,i)) = 1.0d0 end do end do end if c c perform deallocation of some local arrays c deallocate (uscale) deallocate (wscale) return end c c c ############################################################### c ## ## c ## subroutine dfield0b -- direct induction via pair list ## c ## ## c ############################################################### c c c "dfield0b" computes the direct electrostatic field due to c permanent multipole moments via a pair list c c subroutine dfield0b (field,fieldp) use atoms use bound use chgpen use couple use mplpot use mpole use neigh use polar use polgrp use polpot use shunt implicit none integer i,j,k integer ii,kk real*8 xr,yr,zr real*8 r,r2,rr3 real*8 rr5,rr7 real*8 rr3i,rr5i,rr7i real*8 rr3k,rr5k,rr7k real*8 ci,dix,diy,diz real*8 qixx,qixy,qixz real*8 qiyy,qiyz,qizz real*8 ck,dkx,dky,dkz real*8 qkxx,qkxy,qkxz real*8 qkyy,qkyz,qkzz real*8 dir,dkr real*8 qix,qiy,qiz,qir real*8 qkx,qky,qkz,qkr real*8 corei,corek real*8 vali,valk real*8 alphai,alphak real*8 fid(3),fkd(3) real*8 dmpi(7),dmpk(7) real*8 dmpik(7) real*8, allocatable :: dscale(:) real*8, allocatable :: pscale(:) real*8 field(3,*) real*8 fieldp(3,*) real*8, allocatable :: fieldt(:,:) real*8, allocatable :: fieldtp(:,:) character*6 mode c c c set the switching function coefficients c mode = 'MPOLE' call switch (mode) c c perform dynamic allocation of some local arrays c allocate (dscale(n)) allocate (pscale(n)) allocate (fieldt(3,n)) allocate (fieldtp(3,n)) c c set array needed to scale connected atom interactions c do i = 1, n dscale(i) = 1.0d0 pscale(i) = 1.0d0 end do c c initialize local variables for OpenMP calculation c do i = 1, n do j = 1, 3 fieldt(j,i) = 0.0d0 fieldtp(j,i) = 0.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(npole,ipole,rpole,x,y,z,pcore,pval,palpha,n12,i12, !$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14, !$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale, !$OMP& p5iscale,d1scale,d2scale,d3scale,d4scale,nelst,elst,dpequal, !$OMP& use_thole,use_chgpen,use_bounds,off2,field,fieldp) !$OMP& firstprivate(dscale,pscale) shared (fieldt,fieldtp) !$OMP DO reduction(+:fieldt,fieldtp) schedule(guided) c c find the electrostatic field due to permanent multipoles c do ii = 1, npole i = ipole(ii) ci = rpole(1,i) dix = rpole(2,i) diy = rpole(3,i) diz = rpole(4,i) qixx = rpole(5,i) qixy = rpole(6,i) qixz = rpole(7,i) qiyy = rpole(9,i) qiyz = rpole(10,i) qizz = rpole(13,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c if (dpequal) then 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 dscale(i12(j,i)) = pscale(i12(j,i)) 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 dscale(i13(j,i)) = pscale(i13(j,i)) 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 dscale(i14(j,i)) = pscale(i14(j,i)) 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 dscale(i15(j,i)) = pscale(i15(j,i)) end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = d1scale end do do j = 1, np12(i) dscale(ip12(j,i)) = d2scale end do do j = 1, np13(i) dscale(ip13(j,i)) = d3scale end do do j = 1, np14(i) dscale(ip14(j,i)) = d4scale end do end if c c evaluate all sites within the cutoff distance c do kk = 1, nelst(i) k = elst(kk,i) xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) ck = rpole(1,k) dkx = rpole(2,k) dky = rpole(3,k) dkz = rpole(4,k) qkxx = rpole(5,k) qkxy = rpole(6,k) qkxz = rpole(7,k) qkyy = rpole(9,k) qkyz = rpole(10,k) qkzz = rpole(13,k) c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr qix = qixx*xr + qixy*yr + qixz*zr qiy = qixy*xr + qiyy*yr + qiyz*zr qiz = qixz*xr + qiyz*yr + qizz*zr qir = qix*xr + qiy*yr + qiz*zr dkr = dkx*xr + dky*yr + dkz*zr qkx = qkxx*xr + qkxy*yr + qkxz*zr qky = qkxy*xr + qkyy*yr + qkyz*zr qkz = qkxz*xr + qkyz*yr + qkzz*zr qkr = qkx*xr + qky*yr + qkz*zr c c find the field components for Thole polarization damping c if (use_thole) then call damptholed (i,k,7,r,dmpik) rr3 = dmpik(3) / (r*r2) rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2) fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dkx + 2.0d0*rr5*qkx fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dky + 2.0d0*rr5*qky fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dkz + 2.0d0*rr5*qkz fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*dix - 2.0d0*rr5*qix fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*diy - 2.0d0*rr5*qiy fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*diz - 2.0d0*rr5*qiz c c find the field components for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampdir (r,alphai,alphak,dmpi,dmpk) rr3 = 1.0d0 / (r*r2) rr5 = 3.0d0 * rr3 / r2 rr7 = 5.0d0 * rr5 / r2 rr3i = dmpi(3) * rr3 rr5i = dmpi(5) * rr5 rr7i = dmpi(7) * rr7 rr3k = dmpk(3) * rr3 rr5k = dmpk(5) * rr5 rr7k = dmpk(7) * rr7 fid(1) = -xr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkx + 2.0d0*rr5k*qkx fid(2) = -yr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dky + 2.0d0*rr5k*qky fid(3) = -zr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkz + 2.0d0*rr5k*qkz fkd(1) = xr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*dix - 2.0d0*rr5i*qix fkd(2) = yr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diy - 2.0d0*rr5i*qiy fkd(3) = zr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diz - 2.0d0*rr5i*qiz end if c c increment the direct electrostatic field components c do j = 1, 3 fieldt(j,i) = fieldt(j,i) + fid(j)*dscale(k) fieldt(j,k) = fieldt(j,k) + fkd(j)*dscale(k) fieldtp(j,i) = fieldtp(j,i) + fid(j)*pscale(k) fieldtp(j,k) = fieldtp(j,k) + fkd(j)*pscale(k) end do end if end do c c reset exclusion coefficients for connected atoms c if (dpequal) then do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 dscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 dscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 dscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 dscale(i15(j,i)) = 1.0d0 end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) dscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) dscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) dscale(ip14(j,i)) = 1.0d0 end do end if end do !$OMP END DO c c add local to global variables for OpenMP calculation c !$OMP DO do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = fieldt(j,i) fieldp(j,i) = fieldtp(j,i) end do end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (dscale) deallocate (pscale) deallocate (fieldt) deallocate (fieldtp) return end c c c ############################################################### c ## ## c ## subroutine ufield0b -- mutual induction via pair list ## c ## ## c ############################################################### c c c "ufield0b" computes the mutual electrostatic field due to c induced dipole moments via a pair list c c subroutine ufield0b (field,fieldp) use atoms use bound use chgpen use couple use mplpot use mpole use neigh use polar use polgrp use polpot use shunt implicit none integer i,j,k integer ii,kk real*8 xr,yr,zr real*8 r,r2,rr3,rr5 real*8 dix,diy,diz real*8 pix,piy,piz real*8 dkx,dky,dkz real*8 pkx,pky,pkz real*8 dir,pir real*8 dkr,pkr real*8 corei,corek real*8 vali,valk real*8 alphai,alphak real*8 fid(3),fkd(3) real*8 fip(3),fkp(3) real*8 dmpik(5) real*8, allocatable :: uscale(:) real*8, allocatable :: wscale(:) real*8 field(3,*) real*8 fieldp(3,*) real*8, allocatable :: fieldt(:,:) real*8, allocatable :: fieldtp(:,:) character*6 mode c c c set the switching function coefficients c mode = 'MPOLE' call switch (mode) c c perform dynamic allocation of some local arrays c allocate (uscale(n)) allocate (wscale(n)) allocate (fieldt(3,n)) allocate (fieldtp(3,n)) c c set array needed to scale connected atom interactions c do i = 1, n uscale(i) = 1.0d0 wscale(i) = 1.0d0 end do c c initialize local variables for OpenMP calculation c do i = 1, n do j = 1, 3 fieldt(j,i) = 0.0d0 fieldtp(j,i) = 0.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(npole,ipole,uind,uinp,x,y,z,pcore,pval,palpha,n12,i12, !$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14, !$OMP& u1scale,u2scale,u3scale,u4scale,w2scale,w3scale,w4scale,w5scale, !$OMP& nelst,elst,use_thole,use_chgpen,use_bounds,off2,field,fieldp) !$OMP& firstprivate(uscale,wscale) shared (fieldt,fieldtp) !$OMP DO reduction(+:fieldt,fieldtp) schedule(guided) c c find the electrostatic field due to mutual induced dipoles c do ii = 1, npole i = ipole(ii) dix = uind(1,i) diy = uind(2,i) diz = uind(3,i) pix = uinp(1,i) piy = uinp(2,i) piz = uinp(3,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do do j = 1, n12(i) wscale(i12(j,i)) = w2scale end do do j = 1, n13(i) wscale(i13(j,i)) = w3scale end do do j = 1, n14(i) wscale(i14(j,i)) = w4scale end do do j = 1, n15(i) wscale(i15(j,i)) = w5scale end do c c evaluate all sites within the cutoff distance c do kk = 1, nelst(i) k = elst(kk,i) xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) if (use_bounds) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) dkx = uind(1,k) dky = uind(2,k) dkz = uind(3,k) pkx = uinp(1,k) pky = uinp(2,k) pkz = uinp(3,k) c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr dkr = dkx*xr + dky*yr + dkz*zr pir = pix*xr + piy*yr + piz*zr pkr = pkx*xr + pky*yr + pkz*zr c c find the scale factors for Thole polarization damping c if (use_thole) then call dampthole (i,k,5,r,dmpik) dmpik(3) = uscale(k) * dmpik(3) dmpik(5) = uscale(k) * dmpik(5) c c find the scale factors for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampmut (r,alphai,alphak,dmpik) dmpik(3) = wscale(k) * dmpik(3) dmpik(5) = wscale(k) * dmpik(5) end if c c increment the mutual electrostatic field components c rr3 = -dmpik(3) / (r*r2) rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) fid(1) = rr3*dkx + rr5*dkr*xr fid(2) = rr3*dky + rr5*dkr*yr fid(3) = rr3*dkz + rr5*dkr*zr fkd(1) = rr3*dix + rr5*dir*xr fkd(2) = rr3*diy + rr5*dir*yr fkd(3) = rr3*diz + rr5*dir*zr fip(1) = rr3*pkx + rr5*pkr*xr fip(2) = rr3*pky + rr5*pkr*yr fip(3) = rr3*pkz + rr5*pkr*zr fkp(1) = rr3*pix + rr5*pir*xr fkp(2) = rr3*piy + rr5*pir*yr fkp(3) = rr3*piz + rr5*pir*zr do j = 1, 3 fieldt(j,i) = fieldt(j,i) + fid(j) fieldt(j,k) = fieldt(j,k) + fkd(j) fieldtp(j,i) = fieldtp(j,i) + fip(j) fieldtp(j,k) = fieldtp(j,k) + fkp(j) end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 end do do j = 1, n12(i) wscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) wscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) wscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) wscale(i15(j,i)) = 1.0d0 end do end do !$OMP END DO c c add local to global variables for OpenMP calculation c !$OMP DO do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = fieldt(j,i) fieldp(j,i) = fieldtp(j,i) end do end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (uscale) deallocate (wscale) deallocate (fieldt) deallocate (fieldtp) return end c c c ############################################################### c ## ## c ## subroutine dfield0c -- direct induction via Ewald sum ## c ## ## c ############################################################### c c c "dfield0c" computes the mutual electrostatic field due to c permanent multipole moments via Ewald summation c c subroutine dfield0c (field,fieldp) use atoms use boxes use ewald use limits use math use mpole use pme use polar implicit none integer i,j,ii real*8 term real*8 ucell(3) real*8 field(3,*) real*8 fieldp(3,*) c c c zero out the value of the field at each site c do i = 1, n do j = 1, 3 field(j,i) = 0.0d0 fieldp(j,i) = 0.0d0 end do end do c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bsporder aewald = apewald c c get the reciprocal space part of the permanent field c call udirect1 (field) do ii = 1, npole i = ipole(ii) do j = 1, 3 fieldp(j,i) = field(j,i) end do end do c c get the real space portion of the permanent field c if (use_mlist) then call udirect2b (field,fieldp) else call udirect2a (field,fieldp) end if c c get the self-energy portion of the permanent field c term = (4.0d0/3.0d0) * aewald**3 / rootpi do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) + term*rpole(j+1,i) fieldp(j,i) = fieldp(j,i) + term*rpole(j+1,i) end do end do c c compute the cell dipole boundary correction to field c if (boundary .eq. 'VACUUM') then do i = 1, 3 ucell(i) = 0.0d0 end do do ii = 1, npole i = ipole(ii) ucell(1) = ucell(1) + rpole(2,i) + rpole(1,i)*x(i) ucell(2) = ucell(2) + rpole(3,i) + rpole(1,i)*y(i) ucell(3) = ucell(3) + rpole(4,i) + rpole(1,i)*z(i) end do term = (4.0d0/3.0d0) * pi/volbox do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) - term*ucell(j) fieldp(j,i) = fieldp(j,i) - term*ucell(j) end do end do end if return end c c c ################################################################# c ## ## c ## subroutine udirect1 -- Ewald recip direct induced field ## c ## ## c ################################################################# c c c "udirect1" computes the reciprocal space contribution of the c permanent atomic multipole moments to the field c c note that cmp, fmp, cphi and fphi should not be made global c since corresponding values in empole and epolar are different c c subroutine udirect1 (field) use atoms use bound use boxes use ewald use math use mpole use pme use polpot implicit none integer i,j,ii integer k1,k2,k3 integer m1,m2,m3 integer ntot,nff integer nf1,nf2,nf3 real*8 r1,r2,r3 real*8 h1,h2,h3 real*8 volterm,denom real*8 hsq,expterm real*8 term,pterm real*8 field(3,*) real*8, allocatable :: cmp(:,:) real*8, allocatable :: fmp(:,:) real*8, allocatable :: cphi(:,:) real*8, allocatable :: fphi(:,:) c c c return if the Ewald coefficient is zero c if (aewald .lt. 1.0d-6) return c c perform dynamic allocation of some local arrays c allocate (cmp(10,n)) allocate (fmp(10,n)) allocate (cphi(10,n)) allocate (fphi(20,n)) 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 if (allocated(qfac)) then if (size(qfac) .ne. ntot) deallocate (qfac) end if if (.not. allocated(qfac)) allocate (qfac(nfft1,nfft2,nfft3)) c c setup spatial decomposition and B-spline coefficients c call getchunk call moduli call bspline_fill call table_fill c c copy the multipole moments into local storage areas c do ii = 1, npole i = ipole(ii) cmp(1,i) = rpole(1,i) cmp(2,i) = rpole(2,i) cmp(3,i) = rpole(3,i) cmp(4,i) = rpole(4,i) cmp(5,i) = rpole(5,i) cmp(6,i) = rpole(9,i) cmp(7,i) = rpole(13,i) cmp(8,i) = 2.0d0 * rpole(6,i) cmp(9,i) = 2.0d0 * rpole(7,i) cmp(10,i) = 2.0d0 * rpole(10,i) end do c c convert Cartesian multipoles to fractional coordinates c call cmp_to_fmp (cmp,fmp) c c assign PME grid and perform 3-D FFT forward transform c call grid_mpole (fmp) call fftfront c c make the scalar summation over reciprocal lattice 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 qfac(k1,k2,k3) = expterm 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 qfac(1,1,1) = 0.0d0 qgrid(1,1,1,1) = 0.0d0 qgrid(2,1,1,1) = 0.0d0 if (.not. use_bounds) then expterm = 0.5d0 * pi / xbox qfac(1,1,1) = expterm 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 3-D FFT backward transform and get field c call fftback call fphi_mpole (fphi) c c convert the field from fractional to Cartesian c call fphi_to_cphi (fphi,cphi) c c increment the field at each multipole site c do ii = 1, npole i = ipole(ii) field(1,i) = field(1,i) - cphi(2,i) field(2,i) = field(2,i) - cphi(3,i) field(3,i) = field(3,i) - cphi(4,i) end do c c perform deallocation of some local arrays c deallocate (cmp) deallocate (fmp) deallocate (cphi) deallocate (fphi) return end c c c ################################################################## c ## ## c ## subroutine udirect2a -- Ewald real direct field via loop ## c ## ## c ################################################################## c c c "udirect2a" computes the real space contribution of the permanent c atomic multipole moments to the field via a double loop c c subroutine udirect2a (field,fieldp) use atoms use boxes use bound use cell use chgpen use couple use math use mplpot use mpole use polar use polgrp use polpot use shunt use units implicit none integer i,j,k,m integer ii,kk real*8 xr,yr,zr real*8 r,r2,rr1,rr2 real*8 rr3,rr5,rr7 real*8 rr3i,rr5i,rr7i real*8 rr3k,rr5k,rr7k real*8 ci,dix,diy,diz real*8 qixx,qiyy,qizz real*8 qixy,qixz,qiyz real*8 ck,dkx,dky,dkz real*8 qkxx,qkyy,qkzz real*8 qkxy,qkxz,qkyz real*8 dir,dkr real*8 qix,qiy,qiz,qir real*8 qkx,qky,qkz,qkr real*8 corei,corek real*8 vali,valk real*8 alphai,alphak real*8 scalek real*8 dmp3,dmp5,dmp7 real*8 dsc3,dsc5,dsc7 real*8 psc3,psc5,psc7 real*8 fid(3),fkd(3) real*8 fip(3),fkp(3) real*8 dmpi(7),dmpk(7) real*8 dmpik(7),dmpe(7) real*8, allocatable :: pscale(:) real*8, allocatable :: dscale(:) real*8 field(3,*) real*8 fieldp(3,*) character*6 mode c c c check for multipoles and set cutoff coefficients c if (npole .eq. 0) return mode = 'EWALD' call switch (mode) c c perform dynamic allocation of some local arrays c allocate (pscale(n)) allocate (dscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n pscale(i) = 1.0d0 dscale(i) = 1.0d0 end do c c compute real space Ewald field due to permanent multipoles c do ii = 1, npole-1 i = ipole(ii) ci = rpole(1,i) dix = rpole(2,i) diy = rpole(3,i) diz = rpole(4,i) qixx = rpole(5,i) qixy = rpole(6,i) qixz = rpole(7,i) qiyy = rpole(9,i) qiyz = rpole(10,i) qizz = rpole(13,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c if (dpequal) then 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 dscale(i12(j,i)) = pscale(i12(j,i)) 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 dscale(i13(j,i)) = pscale(i13(j,i)) 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 dscale(i14(j,i)) = pscale(i14(j,i)) 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 dscale(i15(j,i)) = pscale(i15(j,i)) end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = d1scale end do do j = 1, np12(i) dscale(ip12(j,i)) = d2scale end do do j = 1, np13(i) dscale(ip13(j,i)) = d3scale end do do j = 1, np14(i) dscale(ip14(j,i)) = d4scale end do end if c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rr1 = 1.0d0 / r rr2 = rr1 * rr1 rr3 = rr2 * rr1 rr5 = 3.0d0 * rr2 * rr3 rr7 = 5.0d0 * rr2 * rr5 ck = rpole(1,k) dkx = rpole(2,k) dky = rpole(3,k) dkz = rpole(4,k) qkxx = rpole(5,k) qkxy = rpole(6,k) qkxz = rpole(7,k) qkyy = rpole(9,k) qkyz = rpole(10,k) qkzz = rpole(13,k) c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr qix = qixx*xr + qixy*yr + qixz*zr qiy = qixy*xr + qiyy*yr + qiyz*zr qiz = qixz*xr + qiyz*yr + qizz*zr qir = qix*xr + qiy*yr + qiz*zr dkr = dkx*xr + dky*yr + dkz*zr qkx = qkxx*xr + qkxy*yr + qkxz*zr qky = qkxy*xr + qkyy*yr + qkyz*zr qkz = qkxz*xr + qkyz*yr + qkzz*zr qkr = qkx*xr + qky*yr + qkz*zr c c calculate real space Ewald error function damping c call dampewald (7,r,r2,1.0d0,dmpe) c c find the field components for Thole polarization damping c if (use_thole) then call damptholed (i,k,7,r,dmpik) scalek = dscale(k) dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7 fid(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkx + 2.0d0*dmp5*qkx fid(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dky + 2.0d0*dmp5*qky fid(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkz + 2.0d0*dmp5*qkz fkd(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*dix - 2.0d0*dmp5*qix fkd(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diy - 2.0d0*dmp5*qiy fkd(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diz - 2.0d0*dmp5*qiz scalek = pscale(k) dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7 fip(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkx + 2.0d0*dmp5*qkx fip(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dky + 2.0d0*dmp5*qky fip(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkz + 2.0d0*dmp5*qkz fkp(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*dix - 2.0d0*dmp5*qix fkp(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diy - 2.0d0*dmp5*qiy fkp(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diz - 2.0d0*dmp5*qiz c c find the field components for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampdir (r,alphai,alphak,dmpi,dmpk) scalek = dscale(k) rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 fid(1) = -xr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkx + 2.0d0*rr5k*qkx fid(2) = -yr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dky + 2.0d0*rr5k*qky fid(3) = -zr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkz + 2.0d0*rr5k*qkz fkd(1) = xr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*dix - 2.0d0*rr5i*qix fkd(2) = yr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diy - 2.0d0*rr5i*qiy fkd(3) = zr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diz - 2.0d0*rr5i*qiz scalek = pscale(k) rr3 = rr2 * rr1 rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 fip(1) = -xr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkx + 2.0d0*rr5k*qkx fip(2) = -yr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dky + 2.0d0*rr5k*qky fip(3) = -zr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkz + 2.0d0*rr5k*qkz fkp(1) = xr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*dix - 2.0d0*rr5i*qix fkp(2) = yr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diy - 2.0d0*rr5i*qiy fkp(3) = zr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diz - 2.0d0*rr5i*qiz end if c c increment the field at each site due to this interaction c do j = 1, 3 field(j,i) = field(j,i) + fid(j) field(j,k) = field(j,k) + fkd(j) fieldp(j,i) = fieldp(j,i) + fip(j) fieldp(j,k) = fieldp(j,k) + fkp(j) end do end if end do c c reset exclusion coefficients for connected atoms c if (dpequal) then do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 dscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 dscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 dscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 dscale(i15(j,i)) = 1.0d0 end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) dscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) dscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) dscale(ip14(j,i)) = 1.0d0 end do end if end do c c periodic boundary for large cutoffs via replicates method c if (use_replica) then do ii = 1, npole i = ipole(ii) ci = rpole(1,i) dix = rpole(2,i) diy = rpole(3,i) diz = rpole(4,i) qixx = rpole(5,i) qixy = rpole(6,i) qixz = rpole(7,i) qiyy = rpole(9,i) qiyz = rpole(10,i) qizz = rpole(13,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c if (dpequal) then 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 dscale(i12(j,i)) = pscale(i12(j,i)) 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 dscale(i13(j,i)) = pscale(i13(j,i)) 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 dscale(i14(j,i)) = pscale(i14(j,i)) 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 dscale(i15(j,i)) = pscale(i15(j,i)) end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = d1scale end do do j = 1, np12(i) dscale(ip12(j,i)) = d2scale end do do j = 1, np13(i) dscale(ip13(j,i)) = d3scale end do do j = 1, np14(i) dscale(ip14(j,i)) = d4scale end do end if c c evaluate all sites within the cutoff distance c do kk = ii, npole k = ipole(kk) ck = rpole(1,k) dkx = rpole(2,k) dky = rpole(3,k) dkz = rpole(4,k) qkxx = rpole(5,k) qkxy = rpole(6,k) qkxz = rpole(7,k) qkyy = rpole(9,k) qkyz = rpole(10,k) qkzz = rpole(13,k) do m = 2, ncell xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) call imager (xr,yr,zr,m) r2 = xr*xr + yr* yr + zr*zr c c calculate the error function damping factors c if (r2 .le. off2) then r = sqrt(r2) rr1 = 1.0d0 / r rr2 = rr1 * rr1 rr3 = rr2 * rr1 rr5 = 3.0d0 * rr2 * rr3 rr7 = 5.0d0 * rr2 * rr5 c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr qix = qixx*xr + qixy*yr + qixz*zr qiy = qixy*xr + qiyy*yr + qiyz*zr qiz = qixz*xr + qiyz*yr + qizz*zr qir = qix*xr + qiy*yr + qiz*zr dkr = dkx*xr + dky*yr + dkz*zr qkx = qkxx*xr + qkxy*yr + qkxz*zr qky = qkxy*xr + qkyy*yr + qkyz*zr qkz = qkxz*xr + qkyz*yr + qkzz*zr qkr = qkx*xr + qky*yr + qkz*zr c c calculate real space Ewald error function damping c call dampewald (7,r,r2,1.0d0,dmpe) c c find the field components for Thole polarization damping c if (use_thole) then call damptholed (i,k,7,r,dmpik) dsc3 = dmpik(3) dsc5 = dmpik(5) dsc7 = dmpik(7) psc3 = dmpik(3) psc5 = dmpik(5) psc7 = dmpik(7) if (use_polymer) then if (r2 .le. polycut2) then dsc3 = dmpik(3) * dscale(k) dsc5 = dmpik(5) * dscale(k) dsc7 = dmpik(7) * dscale(k) psc3 = dmpik(3) * pscale(k) psc5 = dmpik(5) * pscale(k) psc7 = dmpik(7) * pscale(k) end if end if dmp3 = dmpe(3) - (1.0d0-dsc3)*rr3 dmp5 = dmpe(5) - (1.0d0-dsc5)*rr5 dmp7 = dmpe(7) - (1.0d0-dsc7)*rr7 fid(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkx + 2.0d0*dmp5*qkx fid(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dky + 2.0d0*dmp5*qky fid(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkz + 2.0d0*dmp5*qkz fkd(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*dix - 2.0d0*dmp5*qix fkd(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diy - 2.0d0*dmp5*qiy fkd(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diz - 2.0d0*dmp5*qiz dmp3 = dmpe(3) - (1.0d0-psc3)*rr3 dmp5 = dmpe(5) - (1.0d0-psc5)*rr5 dmp7 = dmpe(7) - (1.0d0-psc7)*rr7 fip(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkx + 2.0d0*dmp5*qkx fip(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dky + 2.0d0*dmp5*qky fip(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkz + 2.0d0*dmp5*qkz fkp(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*dix - 2.0d0*dmp5*qix fkp(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diy - 2.0d0*dmp5*qiy fkp(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diz - 2.0d0*dmp5*qiz c c find the field components for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampdir (r,alphai,alphak,dmpi,dmpk) scalek = 1.0d0 if (use_polymer) then if (r2 .le. polycut2) then scalek = dscale(k) end if end if rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 fid(1) = -xr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkx + 2.0d0*rr5k*qkx fid(2) = -yr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dky + 2.0d0*rr5k*qky fid(3) = -zr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkz + 2.0d0*rr5k*qkz fkd(1) = xr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*dix - 2.0d0*rr5i*qix fkd(2) = yr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diy - 2.0d0*rr5i*qiy fkd(3) = zr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diz - 2.0d0*rr5i*qiz scalek = 1.0d0 if (use_polymer) then if (r2 .le. polycut2) then scalek = pscale(k) end if end if rr3 = rr2 * rr1 rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 fip(1) = -xr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkx + 2.0d0*rr5k*qkx fip(2) = -yr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dky + 2.0d0*rr5k*qky fip(3) = -zr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkz + 2.0d0*rr5k*qkz fkp(1) = xr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*dix - 2.0d0*rr5i*qix fkp(2) = yr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diy - 2.0d0*rr5i*qiy fkp(3) = zr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diz - 2.0d0*rr5i*qiz end if c c increment the field at each site due to this interaction c do j = 1, 3 field(j,i) = field(j,i) + fid(j) fieldp(j,i) = fieldp(j,i) + fid(j) if (i .ne. k) then field(j,k) = field(j,k) + fkp(j) fieldp(j,k) = fieldp(j,k) + fkp(j) end if end do end if end do end do c c reset exclusion coefficients for connected atoms c if (dpequal) then do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 dscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 dscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 dscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 dscale(i15(j,i)) = 1.0d0 end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) dscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) dscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) dscale(ip14(j,i)) = 1.0d0 end do end if end do end if c c perform deallocation of some local arrays c deallocate (dscale) deallocate (pscale) return end c c c ################################################################## c ## ## c ## subroutine udirect2b -- Ewald real direct field via list ## c ## ## c ################################################################## c c c "udirect2b" computes the real space contribution of the permanent c atomic multipole moments to the field via a neighbor list c c subroutine udirect2b (field,fieldp) use atoms use boxes use bound use chgpen use couple use math use mplpot use mpole use neigh use openmp use polar use polgrp use polpot use shunt use tarray use units implicit none integer i,j,k,m integer ii,kk integer nlocal,nchunk integer tid,maxlocal !$ integer omp_get_thread_num integer, allocatable :: toffset(:) integer, allocatable :: ilocal(:,:) real*8 xr,yr,zr real*8 r,r2,rr1,rr2 real*8 rr3,rr5,rr7 real*8 rr3i,rr5i,rr7i real*8 rr3k,rr5k,rr7k real*8 rr3ik,rr5ik real*8 ci,dix,diy,diz real*8 qixx,qiyy,qizz real*8 qixy,qixz,qiyz real*8 ck,dkx,dky,dkz real*8 qkxx,qkyy,qkzz real*8 qkxy,qkxz,qkyz real*8 dir,dkr real*8 qix,qiy,qiz,qir real*8 qkx,qky,qkz,qkr real*8 corei,corek real*8 vali,valk real*8 alphai,alphak real*8 scalek real*8 dmp3,dmp5,dmp7 real*8 fid(3),fkd(3) real*8 fip(3),fkp(3) real*8 dmpi(7),dmpk(7) real*8 dmpik(7),dmpe(7) real*8, allocatable :: pscale(:) real*8, allocatable :: dscale(:) real*8, allocatable :: uscale(:) real*8, allocatable :: wscale(:) real*8 field(3,*) real*8 fieldp(3,*) real*8, allocatable :: fieldt(:,:) real*8, allocatable :: fieldtp(:,:) real*8, allocatable :: dlocal(:,:) character*6 mode c c c check for multipoles and set cutoff coefficients c if (npole .eq. 0) return mode = 'EWALD' call switch (mode) c c values for storage of mutual polarization intermediates c nchunk = int(0.5d0*dble(n)/dble(nthread)) + 1 maxlocal = int(dble(n)*dble(maxelst)/dble(nthread)) nlocal = 0 ntpair = 0 c c perform dynamic allocation of some local arrays c allocate (pscale(n)) allocate (dscale(n)) allocate (uscale(n)) allocate (wscale(n)) allocate (fieldt(3,n)) allocate (fieldtp(3,n)) allocate (toffset(0:nthread-1)) if (poltyp .ne. 'DIRECT') then allocate (ilocal(2,maxlocal)) allocate (dlocal(6,maxlocal)) end if c c set arrays needed to scale connected atom interactions c do i = 1, n pscale(i) = 1.0d0 wscale(i) = 1.0d0 dscale(i) = 1.0d0 uscale(i) = 1.0d0 end do c c initialize local variables for OpenMP calculation c do i = 1, n do j = 1, 3 fieldt(j,i) = 0.0d0 fieldtp(j,i) = 0.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(npole,ipole,rpole,x,y,z,pcore, !$OMP& pval,palpha,p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale, !$OMP& p4iscale,p5iscale,w2scale,w3scale,w4scale,w5scale,d1scale, !$OMP& d2scale,d3scale,d4scale,u1scale,u2scale,u3scale,u4scale,n12,i12, !$OMP& n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12,np13,ip13,np14,ip14, !$OMP& nelst,elst,dpequal,use_thole,use_chgpen,use_bounds,off2,poltyp, !$OMP& nchunk,ntpair,tindex,tdipdip,toffset,field,fieldp,fieldt,fieldtp) !$OMP& firstprivate(pscale,dscale,uscale,wscale,nlocal) !$OMP DO reduction(+:fieldt,fieldtp) schedule(static,nchunk) c c compute the real space portion of the Ewald summation c do ii = 1, npole i = ipole(ii) ci = rpole(1,i) dix = rpole(2,i) diy = rpole(3,i) diz = rpole(4,i) qixx = rpole(5,i) qixy = rpole(6,i) qixz = rpole(7,i) qiyy = rpole(9,i) qiyz = rpole(10,i) qizz = rpole(13,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c if (dpequal) then 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 dscale(i12(j,i)) = pscale(i12(j,i)) wscale(i12(j,i)) = w2scale 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 dscale(i13(j,i)) = pscale(i13(j,i)) wscale(i13(j,i)) = w3scale 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 dscale(i14(j,i)) = pscale(i14(j,i)) wscale(i14(j,i)) = w4scale 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 dscale(i15(j,i)) = pscale(i15(j,i)) wscale(i15(j,i)) = w5scale end do do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do else 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 wscale(i12(j,i)) = w2scale 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 wscale(i13(j,i)) = w3scale 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 wscale(i14(j,i)) = w4scale 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 wscale(i15(j,i)) = w5scale end do do j = 1, np11(i) dscale(ip11(j,i)) = d1scale uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) dscale(ip12(j,i)) = d2scale uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) dscale(ip13(j,i)) = d3scale uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) dscale(ip14(j,i)) = d4scale uscale(ip14(j,i)) = u4scale end do end if c c evaluate all sites within the cutoff distance c do kk = 1, nelst(i) k = elst(kk,i) xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) 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 rr2 = rr1 * rr1 rr3 = rr2 * rr1 rr5 = 3.0d0 * rr2 * rr3 rr7 = 5.0d0 * rr2 * rr5 ck = rpole(1,k) dkx = rpole(2,k) dky = rpole(3,k) dkz = rpole(4,k) qkxx = rpole(5,k) qkxy = rpole(6,k) qkxz = rpole(7,k) qkyy = rpole(9,k) qkyz = rpole(10,k) qkzz = rpole(13,k) c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr qix = qixx*xr + qixy*yr + qixz*zr qiy = qixy*xr + qiyy*yr + qiyz*zr qiz = qixz*xr + qiyz*yr + qizz*zr qir = qix*xr + qiy*yr + qiz*zr dkr = dkx*xr + dky*yr + dkz*zr qkx = qkxx*xr + qkxy*yr + qkxz*zr qky = qkxy*xr + qkyy*yr + qkyz*zr qkz = qkxz*xr + qkyz*yr + qkzz*zr qkr = qkx*xr + qky*yr + qkz*zr c c calculate real space Ewald error function damping c call dampewald (7,r,r2,1.0d0,dmpe) c c find the field components for Thole polarization damping c if (use_thole) then call damptholed (i,k,7,r,dmpik) scalek = dscale(k) dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7 fid(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkx + 2.0d0*dmp5*qkx fid(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dky + 2.0d0*dmp5*qky fid(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkz + 2.0d0*dmp5*qkz fkd(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*dix - 2.0d0*dmp5*qix fkd(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diy - 2.0d0*dmp5*qiy fkd(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diz - 2.0d0*dmp5*qiz scalek = pscale(k) dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 dmp7 = dmpe(7) - (1.0d0-scalek*dmpik(7))*rr7 fip(1) = -xr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkx + 2.0d0*dmp5*qkx fip(2) = -yr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dky + 2.0d0*dmp5*qky fip(3) = -zr*(dmp3*ck-dmp5*dkr+dmp7*qkr) & - dmp3*dkz + 2.0d0*dmp5*qkz fkp(1) = xr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*dix - 2.0d0*dmp5*qix fkp(2) = yr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diy - 2.0d0*dmp5*qiy fkp(3) = zr*(dmp3*ci+dmp5*dir+dmp7*qir) & - dmp3*diz - 2.0d0*dmp5*qiz c c find terms needed later to compute mutual polarization c if (poltyp .ne. 'DIRECT') then call dampthole (i,k,5,r,dmpik) scalek = uscale(k) dmp3 = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 dmp5 = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 nlocal = nlocal + 1 ilocal(1,nlocal) = i ilocal(2,nlocal) = k dlocal(1,nlocal) = -dmp3 + dmp5*xr*xr dlocal(2,nlocal) = dmp5*xr*yr dlocal(3,nlocal) = dmp5*xr*zr dlocal(4,nlocal) = -dmp3 + dmp5*yr*yr dlocal(5,nlocal) = dmp5*yr*zr dlocal(6,nlocal) = -dmp3 + dmp5*zr*zr end if c c find the field components for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampdir (r,alphai,alphak,dmpi,dmpk) scalek = dscale(k) rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 fid(1) = -xr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkx + 2.0d0*rr5k*qkx fid(2) = -yr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dky + 2.0d0*rr5k*qky fid(3) = -zr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkz + 2.0d0*rr5k*qkz fkd(1) = xr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*dix - 2.0d0*rr5i*qix fkd(2) = yr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diy - 2.0d0*rr5i*qiy fkd(3) = zr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diz - 2.0d0*rr5i*qiz scalek = pscale(k) rr3 = rr2 * rr1 rr3i = dmpe(3) - (1.0d0-scalek*dmpi(3))*rr3 rr5i = dmpe(5) - (1.0d0-scalek*dmpi(5))*rr5 rr7i = dmpe(7) - (1.0d0-scalek*dmpi(7))*rr7 rr3k = dmpe(3) - (1.0d0-scalek*dmpk(3))*rr3 rr5k = dmpe(5) - (1.0d0-scalek*dmpk(5))*rr5 rr7k = dmpe(7) - (1.0d0-scalek*dmpk(7))*rr7 rr3 = dmpe(3) - (1.0d0-scalek)*rr3 fip(1) = -xr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkx + 2.0d0*rr5k*qkx fip(2) = -yr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dky + 2.0d0*rr5k*qky fip(3) = -zr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkz + 2.0d0*rr5k*qkz fkp(1) = xr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*dix - 2.0d0*rr5i*qix fkp(2) = yr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diy - 2.0d0*rr5i*qiy fkp(3) = zr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diz - 2.0d0*rr5i*qiz c c find terms needed later to compute mutual polarization c if (poltyp .ne. 'DIRECT') then call dampmut (r,alphai,alphak,dmpik) scalek = wscale(k) rr3 = rr2 * rr1 rr3ik = dmpe(3) - (1.0d0-scalek*dmpik(3))*rr3 rr5ik = dmpe(5) - (1.0d0-scalek*dmpik(5))*rr5 nlocal = nlocal + 1 ilocal(1,nlocal) = i ilocal(2,nlocal) = k dlocal(1,nlocal) = -rr3ik + rr5ik*xr*xr dlocal(2,nlocal) = rr5ik*xr*yr dlocal(3,nlocal) = rr5ik*xr*zr dlocal(4,nlocal) = -rr3ik + rr5ik*yr*yr dlocal(5,nlocal) = rr5ik*yr*zr dlocal(6,nlocal) = -rr3ik + rr5ik*zr*zr end if end if c c increment the field at each site due to this interaction c do j = 1, 3 fieldt(j,i) = fieldt(j,i) + fid(j) fieldt(j,k) = fieldt(j,k) + fkd(j) fieldtp(j,i) = fieldtp(j,i) + fip(j) fieldtp(j,k) = fieldtp(j,k) + fkp(j) end do end if end do c c reset exclusion coefficients for connected atoms c if (dpequal) then do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 dscale(i12(j,i)) = 1.0d0 wscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 dscale(i13(j,i)) = 1.0d0 wscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 dscale(i14(j,i)) = 1.0d0 wscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 dscale(i15(j,i)) = 1.0d0 wscale(i15(j,i)) = 1.0d0 end do do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 end do else do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 wscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 wscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 wscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 wscale(i15(j,i)) = 1.0d0 end do do j = 1, np11(i) dscale(ip11(j,i)) = 1.0d0 uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) dscale(ip12(j,i)) = 1.0d0 uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) dscale(ip13(j,i)) = 1.0d0 uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) dscale(ip14(j,i)) = 1.0d0 uscale(ip14(j,i)) = 1.0d0 end do end if end do !$OMP END DO c c find offset into global arrays for the current thread c !$OMP CRITICAL tid = 0 !$ tid = omp_get_thread_num () toffset(tid) = ntpair ntpair = ntpair + nlocal !$OMP END CRITICAL c c store terms used later to compute mutual polarization c if (poltyp .ne. 'DIRECT') then k = toffset(tid) do i = 1, nlocal m = k + i tindex(1,m) = ilocal(1,i) tindex(2,m) = ilocal(2,i) do j = 1, 6 tdipdip(j,m) = dlocal(j,i) end do end do end if c c add local to global variables for OpenMP calculation c !$OMP DO do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) + fieldt(j,i) fieldp(j,i) = fieldp(j,i) + fieldtp(j,i) end do end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (pscale) deallocate (wscale) deallocate (dscale) deallocate (uscale) deallocate (fieldt) deallocate (fieldtp) deallocate (toffset) if (allocated(ilocal)) deallocate (ilocal) if (allocated(dlocal)) deallocate (dlocal) return end c c c ############################################################### c ## ## c ## subroutine ufield0c -- mutual induction via Ewald sum ## c ## ## c ############################################################### c c c "ufield0c" computes the mutual electrostatic field due to c induced dipole moments via Ewald summation c c subroutine ufield0c (field,fieldp) use atoms use boxes use ewald use limits use math use mpole use pme use polar implicit none integer i,j,ii real*8 term real*8 ucell(3) real*8 ucellp(3) real*8 field(3,*) real*8 fieldp(3,*) c c c zero out the electrostatic field at each site c do i = 1, n do j = 1, 3 field(j,i) = 0.0d0 fieldp(j,i) = 0.0d0 end do end do c c set grid size, spline order and Ewald coefficient c nfft1 = nefft1 nfft2 = nefft2 nfft3 = nefft3 bsorder = bsporder aewald = apewald c c get the reciprocal space part of the mutual field c call umutual1 (field,fieldp) c c get the real space portion of the mutual field c if (use_mlist) then call umutual2b (field,fieldp) else call umutual2a (field,fieldp) end if c c get the self-energy portion of the mutual field c term = (4.0d0/3.0d0) * aewald**3 / rootpi do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) + term*uind(j,i) fieldp(j,i) = fieldp(j,i) + term*uinp(j,i) end do end do c c compute the cell dipole boundary correction to the field c if (boundary .eq. 'VACUUM') then do j = 1, 3 ucell(j) = 0.0d0 ucellp(j) = 0.0d0 end do do ii = 1, npole i = ipole(ii) do j = 1, 3 ucell(j) = ucell(j) + uind(j,i) ucellp(j) = ucellp(j) + uinp(j,i) end do end do term = (4.0d0/3.0d0) * pi/volbox do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) - term*ucell(j) fieldp(j,i) = fieldp(j,i) - term*ucellp(j) end do end do end if return end c c c ################################################################# c ## ## c ## subroutine umutual1 -- Ewald recip mutual induced field ## c ## ## c ################################################################# c c c "umutual1" computes the reciprocal space contribution of the c induced atomic dipole moments to the field c c subroutine umutual1 (field,fieldp) use atoms use boxes use ewald use math use mpole use pme use polar use polopt use polpot implicit none integer i,j,k,ii real*8 term real*8 a(3,3) real*8 field(3,*) real*8 fieldp(3,*) real*8, allocatable :: fuind(:,:) real*8, allocatable :: fuinp(:,:) real*8, allocatable :: fdip_phi1(:,:) real*8, allocatable :: fdip_phi2(:,:) real*8, allocatable :: fdip_sum_phi(:,:) real*8, allocatable :: dipfield1(:,:) real*8, allocatable :: dipfield2(:,:) c c c return if the Ewald coefficient is zero c if (aewald .lt. 1.0d-6) return c c perform dynamic allocation of some local arrays c allocate (fuind(3,n)) allocate (fuinp(3,n)) allocate (fdip_phi1(10,n)) allocate (fdip_phi2(10,n)) allocate (fdip_sum_phi(20,n)) allocate (dipfield1(3,n)) allocate (dipfield2(3,n)) c c convert Cartesian dipoles to fractional coordinates c do i = 1, 3 a(1,i) = dble(nfft1) * recip(i,1) a(2,i) = dble(nfft2) * recip(i,2) a(3,i) = dble(nfft3) * recip(i,3) end do do ii = 1, npole i = ipole(ii) do j = 1, 3 fuind(j,i) = a(j,1)*uind(1,i) + a(j,2)*uind(2,i) & + a(j,3)*uind(3,i) fuinp(j,i) = a(j,1)*uinp(1,i) + a(j,2)*uinp(2,i) & + a(j,3)*uinp(3,i) end do end do c c assign PME grid and perform 3-D FFT forward transform c call grid_uind (fuind,fuinp) call fftfront c c complete the transformation of the PME grid c do k = 1, nfft3 do j = 1, nfft2 do i = 1, nfft1 term = qfac(i,j,k) qgrid(1,i,j,k) = term * qgrid(1,i,j,k) qgrid(2,i,j,k) = term * qgrid(2,i,j,k) end do end do end do c c perform 3-D FFT backward transform and get field c call fftback call fphi_uind (fdip_phi1,fdip_phi2,fdip_sum_phi) c c store fractional reciprocal potentials for OPT method c if (poltyp .eq. 'OPT') then do ii = 1, npole i = ipole(ii) do j = 1, 10 fopt(optlevel,j,i) = fdip_phi1(j,i) foptp(optlevel,j,i) = fdip_phi2(j,i) end do end do end if c c convert the dipole fields from fractional to Cartesian c do i = 1, 3 a(i,1) = dble(nfft1) * recip(i,1) a(i,2) = dble(nfft2) * recip(i,2) a(i,3) = dble(nfft3) * recip(i,3) end do do ii = 1, npole i = ipole(ii) do j = 1, 3 dipfield1(j,i) = a(j,1)*fdip_phi1(2,i) & + a(j,2)*fdip_phi1(3,i) & + a(j,3)*fdip_phi1(4,i) dipfield2(j,i) = a(j,1)*fdip_phi2(2,i) & + a(j,2)*fdip_phi2(3,i) & + a(j,3)*fdip_phi2(4,i) end do end do c c increment the field at each multipole site c do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) - dipfield1(j,i) fieldp(j,i) = fieldp(j,i) - dipfield2(j,i) end do end do c c perform deallocation of some local arrays c deallocate (fuind) deallocate (fuinp) deallocate (fdip_phi1) deallocate (fdip_phi2) deallocate (fdip_sum_phi) deallocate (dipfield1) deallocate (dipfield2) return end c c c ################################################################## c ## ## c ## subroutine umutual2a -- Ewald real mutual field via loop ## c ## ## c ################################################################## c c c "umutual2a" computes the real space contribution of the induced c atomic dipole moments to the field via a double loop c c subroutine umutual2a (field,fieldp) use atoms use boxes use bound use cell use chgpen use couple use math use mplpot use mpole use polar use polgrp use polpot use shunt use units implicit none integer i,j,k,m integer ii,kk real*8 xr,yr,zr real*8 r,r2,rr1 real*8 rr2,rr3,rr5 real*8 dix,diy,diz real*8 pix,piy,piz real*8 dkx,dky,dkz real*8 pkx,pky,pkz real*8 dir,dkr real*8 pir,pkr real*8 corei,corek real*8 vali,valk real*8 alphai,alphak real*8 fid(3),fkd(3) real*8 fip(3),fkp(3) real*8 dmpik(5),dmpe(5) real*8, allocatable :: uscale(:) real*8, allocatable :: wscale(:) real*8 field(3,*) real*8 fieldp(3,*) character*6 mode c c c check for multipoles and set cutoff coefficients c if (npole .eq. 0) return mode = 'EWALD' call switch (mode) c c perform dynamic allocation of some local arrays c allocate (uscale(n)) allocate (wscale(n)) c c set array needed to scale connected atom interactions c do i = 1, n uscale(i) = 1.0d0 wscale(i) = 1.0d0 end do c c compute the real space portion of the Ewald summation c do ii = 1, npole-1 i = ipole(ii) dix = uind(1,i) diy = uind(2,i) diz = uind(3,i) pix = uinp(1,i) piy = uinp(2,i) piz = uinp(3,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do do j = 1, n12(i) wscale(i12(j,i)) = w2scale end do do j = 1, n13(i) wscale(i13(j,i)) = w3scale end do do j = 1, n14(i) wscale(i14(j,i)) = w4scale end do do j = 1, n15(i) wscale(i15(j,i)) = w5scale end do c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rr1 = 1.0d0 / r rr2 = rr1 * rr1 rr3 = rr2 * rr1 rr5 = rr2 * rr3 dkx = uind(1,k) dky = uind(2,k) dkz = uind(3,k) pkx = uinp(1,k) pky = uinp(2,k) pkz = uinp(3,k) c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr dkr = dkx*xr + dky*yr + dkz*zr pir = pix*xr + piy*yr + piz*zr pkr = pkx*xr + pky*yr + pkz*zr c c calculate real space Ewald error function damping c call dampewald (5,r,r2,1.0d0,dmpe) c c find the field components for Thole polarization damping c if (use_thole) then call dampthole (i,k,5,r,dmpik) dmpik(3) = uscale(k) * dmpik(3) dmpik(5) = uscale(k) * dmpik(5) c c find the field components for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampmut (r,alphai,alphak,dmpik) dmpik(3) = wscale(k) * dmpik(3) dmpik(5) = wscale(k) * dmpik(5) end if c c find the field terms for the current interaction c rr3 = -dmpe(3) + (1.0d0-dmpik(3))*rr3 rr5 = dmpe(5) - 3.0d0*(1.0d0-dmpik(5))*rr5 fid(1) = rr3*dkx + rr5*dkr*xr fid(2) = rr3*dky + rr5*dkr*yr fid(3) = rr3*dkz + rr5*dkr*zr fkd(1) = rr3*dix + rr5*dir*xr fkd(2) = rr3*diy + rr5*dir*yr fkd(3) = rr3*diz + rr5*dir*zr fip(1) = rr3*pkx + rr5*pkr*xr fip(2) = rr3*pky + rr5*pkr*yr fip(3) = rr3*pkz + rr5*pkr*zr fkp(1) = rr3*pix + rr5*pir*xr fkp(2) = rr3*piy + rr5*pir*yr fkp(3) = rr3*piz + rr5*pir*zr c c increment the field at each site due to this interaction c do j = 1, 3 field(j,i) = field(j,i) + fid(j) field(j,k) = field(j,k) + fkd(j) fieldp(j,i) = fieldp(j,i) + fip(j) fieldp(j,k) = fieldp(j,k) + fkp(j) end do end if end do c c reset exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 end do do j = 1, n12(i) wscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) wscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) wscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) wscale(i15(j,i)) = 1.0d0 end do end do c c periodic boundary for large cutoffs via replicates method c if (use_replica) then do ii = 1, npole i = ipole(ii) dix = uind(1,i) diy = uind(2,i) diz = uind(3,i) pix = uinp(1,i) piy = uinp(2,i) piz = uinp(3,i) if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do do j = 1, n12(i) wscale(i12(j,i)) = w2scale end do do j = 1, n13(i) wscale(i13(j,i)) = w3scale end do do j = 1, n14(i) wscale(i14(j,i)) = w4scale end do do j = 1, n15(i) wscale(i15(j,i)) = w5scale end do c c evaluate all sites within the cutoff distance c do kk = ii, npole k = ipole(kk) dkx = uind(1,k) dky = uind(2,k) dkz = uind(3,k) pkx = uinp(1,k) pky = uinp(2,k) pkz = uinp(3,k) do m = 2, ncell xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) call imager (xr,yr,zr,m) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) rr1 = 1.0d0 / r rr2 = rr1 * rr1 rr3 = rr2 * rr1 rr5 = rr2 * rr3 c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr dkr = dkx*xr + dky*yr + dkz*zr pir = pix*xr + piy*yr + piz*zr pkr = pkx*xr + pky*yr + pkz*zr c c calculate real space Ewald error function damping c call dampewald (5,r,r2,1.0d0,dmpe) c c find the field components for Thole polarization damping c if (use_thole) then call dampthole (i,k,5,r,dmpik) dmpik(3) = uscale(k) * dmpik(3) dmpik(5) = uscale(k) * dmpik(5) c c find the field components for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampmut (r,alphai,alphak,dmpik) dmpik(3) = wscale(k) * dmpik(3) dmpik(5) = wscale(k) * dmpik(5) end if c c find the field terms for the current interaction c rr3 = -dmpe(3) + (1.0d0-dmpik(3))*rr3 rr5 = dmpe(5) - 3.0d0*(1.0d0-dmpik(5))*rr5 fid(1) = rr3*dkx + rr5*dkr*xr fid(2) = rr3*dky + rr5*dkr*yr fid(3) = rr3*dkz + rr5*dkr*zr fkd(1) = rr3*dix + rr5*dir*xr fkd(2) = rr3*diy + rr5*dir*yr fkd(3) = rr3*diz + rr5*dir*zr fip(1) = rr3*pkx + rr5*pkr*xr fip(2) = rr3*pky + rr5*pkr*yr fip(3) = rr3*pkz + rr5*pkr*zr fkp(1) = rr3*pix + rr5*pir*xr fkp(2) = rr3*piy + rr5*pir*yr fkp(3) = rr3*piz + rr5*pir*zr c c increment the field at each site due to this interaction c do j = 1, 3 field(j,i) = field(j,i) + fid(j) fieldp(j,i) = fieldp(j,i) + fip(j) if (i .ne. k) then field(j,k) = field(j,k) + fkd(j) fieldp(j,k) = fieldp(j,k) + fkp(j) end if end do end if end do end do c c reset exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 end do do j = 1, n12(i) wscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) wscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) wscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) wscale(i15(j,i)) = 1.0d0 end do end do end if c c perform deallocation of some local arrays c deallocate (uscale) deallocate (wscale) return end c c c ################################################################## c ## ## c ## subroutine umutual2b -- Ewald real mutual field via list ## c ## ## c ################################################################## c c c "umutual2b" computes the real space contribution of the induced c atomic dipole moments to the field via a neighbor list c c subroutine umutual2b (field,fieldp) use atoms use mpole use polar use tarray implicit none integer i,j,k,m,ii real*8 fid(3),fkd(3) real*8 fip(3),fkp(3) real*8 field(3,*) real*8 fieldp(3,*) real*8, allocatable :: fieldt(:,:) real*8, allocatable :: fieldtp(:,:) c c c check for multipoles and set cutoff coefficients c if (npole .eq. 0) return c c perform dynamic allocation of some local arrays c allocate (fieldt(3,n)) allocate (fieldtp(3,n)) c c initialize local variables for OpenMP calculation c do i = 1, n do j = 1, 3 fieldt(j,i) = 0.0d0 fieldtp(j,i) = 0.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(npole,ipole,uind,uinp, !$OMP& ntpair,tindex,tdipdip,field,fieldp,fieldt,fieldtp) !$OMP DO reduction(+:fieldt,fieldtp) schedule(guided) c c find the field terms for each pairwise interaction c do m = 1, ntpair i = tindex(1,m) k = tindex(2,m) fid(1) = tdipdip(1,m)*uind(1,k) + tdipdip(2,m)*uind(2,k) & + tdipdip(3,m)*uind(3,k) fid(2) = tdipdip(2,m)*uind(1,k) + tdipdip(4,m)*uind(2,k) & + tdipdip(5,m)*uind(3,k) fid(3) = tdipdip(3,m)*uind(1,k) + tdipdip(5,m)*uind(2,k) & + tdipdip(6,m)*uind(3,k) fkd(1) = tdipdip(1,m)*uind(1,i) + tdipdip(2,m)*uind(2,i) & + tdipdip(3,m)*uind(3,i) fkd(2) = tdipdip(2,m)*uind(1,i) + tdipdip(4,m)*uind(2,i) & + tdipdip(5,m)*uind(3,i) fkd(3) = tdipdip(3,m)*uind(1,i) + tdipdip(5,m)*uind(2,i) & + tdipdip(6,m)*uind(3,i) fip(1) = tdipdip(1,m)*uinp(1,k) + tdipdip(2,m)*uinp(2,k) & + tdipdip(3,m)*uinp(3,k) fip(2) = tdipdip(2,m)*uinp(1,k) + tdipdip(4,m)*uinp(2,k) & + tdipdip(5,m)*uinp(3,k) fip(3) = tdipdip(3,m)*uinp(1,k) + tdipdip(5,m)*uinp(2,k) & + tdipdip(6,m)*uinp(3,k) fkp(1) = tdipdip(1,m)*uinp(1,i) + tdipdip(2,m)*uinp(2,i) & + tdipdip(3,m)*uinp(3,i) fkp(2) = tdipdip(2,m)*uinp(1,i) + tdipdip(4,m)*uinp(2,i) & + tdipdip(5,m)*uinp(3,i) fkp(3) = tdipdip(3,m)*uinp(1,i) + tdipdip(5,m)*uinp(2,i) & + tdipdip(6,m)*uinp(3,i) c c increment the field at each site due to this interaction c do j = 1, 3 fieldt(j,i) = fieldt(j,i) + fid(j) fieldt(j,k) = fieldt(j,k) + fkd(j) fieldtp(j,i) = fieldtp(j,i) + fip(j) fieldtp(j,k) = fieldtp(j,k) + fkp(j) end do end do !$OMP END DO c c add local to global variables for OpenMP calculation c !$OMP DO do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) + fieldt(j,i) fieldp(j,i) = fieldp(j,i) + fieldtp(j,i) end do end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (fieldt) deallocate (fieldtp) return end c c c ############################################################## c ## ## c ## subroutine induce0c -- Kirkwood SCRF induced dipoles ## c ## ## c ############################################################## c c c "induce0c" computes the induced dipole moments at polarizable c sites for generalized Kirkwood SCRF and vacuum environments c c subroutine induce0c use atoms use extfld use inform use iounit use limits use mpole use polar use polopt use polpot use potent use units use uprior implicit none integer i,j,k integer ii,iter integer miniter integer maxiter real*8 polmin real*8 eps,epsold real*8 epsd,epsp real*8 epsds,epsps real*8 udsum,upsum real*8 ussum,upssum real*8 a,ap,as,aps real*8 b,bp,bs,bps real*8 sum,sump real*8 sums,sumps real*8, allocatable :: poli(:) real*8, allocatable :: field(:,:) real*8, allocatable :: fieldp(:,:) real*8, allocatable :: fields(:,:) real*8, allocatable :: fieldps(:,:) real*8, allocatable :: rsd(:,:) real*8, allocatable :: rsdp(:,:) real*8, allocatable :: rsds(:,:) real*8, allocatable :: rsdps(:,:) real*8, allocatable :: zrsd(:,:) real*8, allocatable :: zrsdp(:,:) real*8, allocatable :: zrsds(:,:) real*8, allocatable :: zrsdps(:,:) real*8, allocatable :: conj(:,:) real*8, allocatable :: conjp(:,:) real*8, allocatable :: conjs(:,:) real*8, allocatable :: conjps(:,:) real*8, allocatable :: vec(:,:) real*8, allocatable :: vecp(:,:) real*8, allocatable :: vecs(:,:) real*8, allocatable :: vecps(:,:) real*8, allocatable :: usum(:,:) real*8, allocatable :: usump(:,:) real*8, allocatable :: usums(:,:) real*8, allocatable :: usumps(:,:) logical done character*6 mode c c c zero out the induced dipoles at each site; uind and uinp are c vacuum dipoles, uinds and uinps are SCRF dipoles c do i = 1, n do j = 1, 3 uind(j,i) = 0.0d0 uinp(j,i) = 0.0d0 uinds(j,i) = 0.0d0 uinps(j,i) = 0.0d0 end do end do if (.not.use_polar .and. .not.use_solv) return c c set the switching function coefficients c mode = 'MPOLE' call switch (mode) c c perform dynamic allocation of some local arrays c allocate (field(3,n)) allocate (fieldp(3,n)) allocate (fields(3,n)) allocate (fieldps(3,n)) c c compute induced dipoles based on direct and mutual fields c 10 continue c c compute the direct induced dipole moment at each atom, and c another set that also includes RF due to permanent multipoles c call dfield0d (field,fieldp,fields,fieldps) c c add external electric field to the direct field values c if (use_exfld) then do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) + exfld(j) fieldp(j,i) = fieldp(j,i) + exfld(j) fields(j,i) = fields(j,i) + exfld(j) fieldps(j,i) = fieldps(j,i) + exfld(j) end do end do end if c c set vacuum induced dipoles to polarizability times direct field; c set SCRF induced dipoles to polarizability times direct field c plus the GK reaction field due to permanent multipoles c do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 udir(j,i) = polarity(i) * field(j,i) udirp(j,i) = polarity(i) * fieldp(j,i) udirs(j,i) = polarity(i) * fields(j,i) udirps(j,i) = polarity(i) * fieldps(j,i) uind(j,i) = udir(j,i) uinp(j,i) = udirp(j,i) uinds(j,i) = udirs(j,i) uinps(j,i) = udirps(j,i) end do end if end do c c get induced dipoles via the OPT extrapolation method c if (poltyp .eq. 'OPT') then do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uopt(0,j,i) = udir(j,i) uoptp(0,j,i) = udirp(j,i) uopts(0,j,i) = udirs(j,i) uoptps(0,j,i) = udirps(j,i) end do end if end do do k = 1, optorder call ufield0d (field,fieldp,fields,fieldps) do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uopt(k,j,i) = polarity(i) * field(j,i) uoptp(k,j,i) = polarity(i) * fieldp(j,i) uopts(k,j,i) = polarity(i) * fields(j,i) uoptps(k,j,i) = polarity(i) * fieldps(j,i) uind(j,i) = uopt(k,j,i) uinp(j,i) = uoptp(k,j,i) uinds(j,i) = uopts(k,j,i) uinps(j,i) = uoptps(k,j,i) end do end if end do end do allocate (usum(3,n)) allocate (usump(3,n)) allocate (usums(3,n)) allocate (usumps(3,n)) do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = 0.0d0 uinp(j,i) = 0.0d0 uinds(j,i) = 0.0d0 uinps(j,i) = 0.0d0 usum(j,i) = 0.0d0 usump(j,i) = 0.0d0 usums(j,i) = 0.0d0 usumps(j,i) = 0.0d0 do k = 0, optorder usum(j,i) = usum(j,i) + uopt(k,j,i) usump(j,i) = usump(j,i) + uoptp(k,j,i) usums(j,i) = usums(j,i) + uopts(k,j,i) usumps(j,i) = usumps(j,i) + uoptps(k,j,i) uind(j,i) = uind(j,i) + copt(k)*usum(j,i) uinp(j,i) = uinp(j,i) + copt(k)*usump(j,i) uinds(j,i) = uinds(j,i) + copt(k)*usums(j,i) uinps(j,i) = uinps(j,i) + copt(k)*usumps(j,i) end do end do end if end do deallocate (usum) deallocate (usump) deallocate (usums) deallocate (usumps) end if c c set tolerances for computation of mutual induced dipoles c if (poltyp .eq. 'MUTUAL') then done = .false. miniter = min(3,npole) maxiter = 100 iter = 0 polmin = 0.00000001d0 eps = 100.0d0 c c estimated induced dipoles from polynomial predictor c if (use_pred .and. nualt.eq.maxualt) then do ii = 1, npole i = ipole(ii) do j = 1, 3 udsum = 0.0d0 upsum = 0.0d0 ussum = 0.0d0 upssum = 0.0d0 do k = 1, nualt-1 udsum = udsum + bpred(k)*udalt(k,j,i) upsum = upsum + bpredp(k)*upalt(k,j,i) ussum = ussum + bpreds(k)*usalt(k,j,i) upssum = upssum + bpredps(k)*upsalt(k,j,i) end do uind(j,i) = udsum uinp(j,i) = upsum uinds(j,i) = ussum uinps(j,i) = upssum end do end do end if c c perform dynamic allocation of some local arrays c allocate (poli(n)) allocate (rsd(3,n)) allocate (rsdp(3,n)) allocate (rsds(3,n)) allocate (rsdps(3,n)) allocate (zrsd(3,n)) allocate (zrsdp(3,n)) allocate (zrsds(3,n)) allocate (zrsdps(3,n)) allocate (conj(3,n)) allocate (conjp(3,n)) allocate (conjs(3,n)) allocate (conjps(3,n)) allocate (vec(3,n)) allocate (vecp(3,n)) allocate (vecs(3,n)) allocate (vecps(3,n)) c c set initial conjugate gradient residual and conjugate vector c call ufield0d (field,fieldp,fields,fieldps) do ii = 1, npole i = ipole(ii) if (douind(i)) then poli(i) = max(polmin,polarity(i)) do j = 1, 3 rsd(j,i) = (udir(j,i)-uind(j,i))/poli(i) & + field(j,i) rsdp(j,i) = (udirp(j,i)-uinp(j,i))/poli(i) & + fieldp(j,i) rsds(j,i) = (udirs(j,i)-uinds(j,i))/poli(i) & + fields(j,i) rsdps(j,i) = (udirps(j,i)-uinps(j,i))/poli(i) & + fieldps(j,i) zrsd(j,i) = rsd(j,i) * poli(i) zrsdp(j,i) = rsdp(j,i) * poli(i) zrsds(j,i) = rsds(j,i) * poli(i) zrsdps(j,i) = rsdps(j,i) * poli(i) conj(j,i) = zrsd(j,i) conjp(j,i) = zrsdp(j,i) conjs(j,i) = zrsds(j,i) conjps(j,i) = zrsdps(j,i) end do end if end do c c conjugate gradient iteration of the mutual induced dipoles c do while (.not. done) iter = iter + 1 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 vec(j,i) = uind(j,i) vecp(j,i) = uinp(j,i) vecs(j,i) = uinds(j,i) vecps(j,i) = uinps(j,i) uind(j,i) = conj(j,i) uinp(j,i) = conjp(j,i) uinds(j,i) = conjs(j,i) uinps(j,i) = conjps(j,i) end do end if end do call ufield0d (field,fieldp,fields,fieldps) do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = vec(j,i) uinp(j,i) = vecp(j,i) uinds(j,i) = vecs(j,i) uinps(j,i) = vecps(j,i) vec(j,i) = conj(j,i)/poli(i) - field(j,i) vecp(j,i) = conjp(j,i)/poli(i) - fieldp(j,i) vecs(j,i) = conjs(j,i)/poli(i) - fields(j,i) vecps(j,i) = conjps(j,i)/poli(i) - fieldps(j,i) end do end if end do a = 0.0d0 ap = 0.0d0 as = 0.0d0 aps = 0.0d0 sum = 0.0d0 sump = 0.0d0 sums = 0.0d0 sumps = 0.0d0 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 a = a + conj(j,i)*vec(j,i) ap = ap + conjp(j,i)*vecp(j,i) as = as + conjs(j,i)*vecs(j,i) aps = aps + conjps(j,i)*vecps(j,i) sum = sum + rsd(j,i)*zrsd(j,i) sump = sump + rsdp(j,i)*zrsdp(j,i) sums = sums + rsds(j,i)*zrsds(j,i) sumps = sumps + rsdps(j,i)*zrsdps(j,i) end do end if end do if (a .ne. 0.0d0) a = sum / a if (ap .ne. 0.0d0) ap = sump / ap if (as .ne. 0.0d0) as = sums / as if (aps .ne. 0.0d0) aps = sumps / aps do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = uind(j,i) + a*conj(j,i) uinp(j,i) = uinp(j,i) + ap*conjp(j,i) uinds(j,i) = uinds(j,i) + as*conjs(j,i) uinps(j,i) = uinps(j,i) + aps*conjps(j,i) rsd(j,i) = rsd(j,i) - a*vec(j,i) rsdp(j,i) = rsdp(j,i) - ap*vecp(j,i) rsds(j,i) = rsds(j,i) - as*vecs(j,i) rsdps(j,i) = rsdps(j,i) - aps*vecps(j,i) end do end if end do b = 0.0d0 bp = 0.0d0 bs = 0.0d0 bps = 0.0d0 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 zrsd(j,i) = rsd(j,i) * poli(i) zrsdp(j,i) = rsdp(j,i) * poli(i) zrsds(j,i) = rsds(j,i) * poli(i) zrsdps(j,i) = rsdps(j,i) * poli(i) b = b + rsd(j,i)*zrsd(j,i) bp = bp + rsdp(j,i)*zrsdp(j,i) bs = bs + rsds(j,i)*zrsds(j,i) bps = bps + rsdps(j,i)*zrsdps(j,i) end do end if end do if (sum .ne. 0.0d0) b = b / sum if (sump .ne. 0.0d0) bp = bp / sump if (sums .ne. 0.0d0) bs = bs / sums if (sumps .ne. 0.0d0) bps = bps / sumps epsd = 0.0d0 epsp = 0.0d0 epsds = 0.0d0 epsps = 0.0d0 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 conj(j,i) = zrsd(j,i) + b*conj(j,i) conjp(j,i) = zrsdp(j,i) + bp*conjp(j,i) conjs(j,i) = zrsds(j,i) + bs*conjs(j,i) conjps(j,i) = zrsdps(j,i) + bps*conjps(j,i) epsd = epsd + rsd(j,i)*rsd(j,i) epsp = epsp + rsdp(j,i)*rsdp(j,i) epsds = epsds + rsds(j,i)*rsds(j,i) epsps = epsps + rsdps(j,i)*rsdps(j,i) end do end if end do c c check the convergence of the mutual induced dipoles c epsold = eps eps = max(epsd,epsp,epsds,epsps) eps = debye * sqrt(eps/dble(npolar)) if (debug) then if (iter .eq. 1) then write (iout,20) 20 format (/,' Determination of Induced Dipole', & ' Moments :', & //,4x,'Iter',8x,'RMS Change (Debye)',/) end if write (iout,30) iter,eps 30 format (i8,7x,f16.10) end if if (eps .lt. poleps) done = .true. if (eps .gt. epsold) done = .true. if (iter .lt. miniter) done = .false. if (iter .ge. politer) done = .true. c c apply a "peek" iteration to the mutual induced dipoles c if (done) then do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = uind(j,i) + poli(i)*rsd(j,i) uinp(j,i) = uinp(j,i) + poli(i)*rsdp(j,i) uinds(j,i) = uinds(j,i) + poli(i)*rsds(j,i) uinps(j,i) = uinps(j,i) + poli(i)*rsdps(j,i) end do end if end do end if end do c c perform deallocation of some local arrays c deallocate (poli) deallocate (rsd) deallocate (rsdp) deallocate (rsds) deallocate (rsdps) deallocate (zrsd) deallocate (zrsdp) deallocate (zrsds) deallocate (zrsdps) deallocate (conj) deallocate (conjp) deallocate (conjs) deallocate (conjps) deallocate (vec) deallocate (vecp) deallocate (vecs) deallocate (vecps) c c print the results from the conjugate gradient iteration c if (debug) then write (iout,40) iter,eps 40 format (/,' Induced Dipoles :',6x,'Iterations',i5, & 6x,'RMS Change',f15.10) end if c c terminate the calculation if dipoles failed to converge c if (iter.ge.maxiter .or. eps.gt.epsold) then if (use_ulist) then use_ulist = .false. usolvcut = 0.0d0 if (verbose) then write (iout,50) 50 format (/,' INDUCE -- Switching to Diagonal', & ' PCG Preconditioner') end if goto 10 else write (iout,60) 60 format (/,' INDUCE -- Warning, Induced Dipoles', & ' are not Converged') call prterr call fatal end if end if end if c c perform deallocation of some local arrays c deallocate (field) deallocate (fieldp) deallocate (fields) deallocate (fieldps) return end c c c ################################################################## c ## ## c ## subroutine dfield0d -- generalized Kirkwood direct field ## c ## ## c ################################################################## c c c "dfield0d" computes the direct electrostatic field due to c permanent multipole moments for use with with generalized c Kirkwood implicit solvation c c subroutine dfield0d (field,fieldp,fields,fieldps) use atoms use couple use gkstuf use group use mpole use polar use polgrp use polpot use shunt use solute implicit none integer i,j,k integer ii,kk real*8 xr,yr,zr real*8 xr2,yr2,zr2 real*8 fgrp,r,r2 real*8 rr3,rr5,rr7 real*8 ci,uxi,uyi,uzi real*8 qxxi,qxyi,qxzi real*8 qyyi,qyzi,qzzi real*8 ck,uxk,uyk,uzk real*8 qxxk,qxyk,qxzk real*8 qyyk,qyzk,qzzk real*8 dir,dkr real*8 qix,qiy,qiz,qir real*8 qkx,qky,qkz,qkr real*8 rb2,rbi,rbk real*8 dwater,fc,fd,fq real*8 gf,gf2,gf3,gf5,gf7 real*8 expterm,expc,expc1 real*8 dexpc,expcdexpc real*8 a(0:3,0:2) real*8 gc(4),gux(10) real*8 guy(10),guz(10) real*8 gqxx(4),gqxy(4) real*8 gqxz(4),gqyy(4) real*8 gqyz(4),gqzz(4) real*8 fid(3),fkd(3) real*8 dmpik(7) real*8, allocatable :: dscale(:) real*8, allocatable :: pscale(:) real*8 field(3,*) real*8 fieldp(3,*) real*8 fields(3,*) real*8 fieldps(3,*) real*8, allocatable :: fieldt(:,:) real*8, allocatable :: fieldtp(:,:) real*8, allocatable :: fieldts(:,:) real*8, allocatable :: fieldtps(:,:) logical proceed c c c zero out the value of the field at each site c do i = 1, n do j = 1, 3 field(j,i) = 0.0d0 fieldp(j,i) = 0.0d0 fields(j,i) = 0.0d0 fieldps(j,i) = 0.0d0 end do end do c c set dielectric constant and scaling factors for water c dwater = 78.3d0 fc = 1.0d0 * (1.0d0-dwater) / (1.0d0*dwater) fd = 2.0d0 * (1.0d0-dwater) / (1.0d0+2.0d0*dwater) fq = 3.0d0 * (1.0d0-dwater) / (2.0d0+3.0d0*dwater) c c perform dynamic allocation of some local arrays c allocate (dscale(n)) allocate (pscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n dscale(i) = 1.0d0 pscale(i) = 1.0d0 end do c c perform dynamic allocation of some local arrays c allocate (fieldt(3,n)) allocate (fieldtp(3,n)) allocate (fieldts(3,n)) allocate (fieldtps(3,n)) c c initialize local variables for OpenMP calculation c do i = 1, n do j = 1, 3 fieldt(j,i) = 0.0d0 fieldtp(j,i) = 0.0d0 fieldts(j,i) = 0.0d0 fieldtps(j,i) = 0.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(npole,ipole,rpole,rborn,n12,n13, !$OMP& n14,n15,np11,np12,np13,np14,i12,i13,i14,i15,ip11,ip12,ip13,ip14, !$OMP& p2scale,p3scale,p4scale,p5scale,p2iscale,p3iscale,p4iscale, !$OMP& p5iscale,d1scale,d2scale,d3scale,d4scale,dpequal,use_intra, !$OMP& x,y,z,off2,fc,fd,fq,gkc,field,fieldp,fields,fieldps) !$OMP& firstprivate(dscale,pscale) !$OMP& shared(fieldt,fieldtp,fieldts,fieldtps) !$OMP DO reduction(+:fieldt,fieldtp,fieldts,fieldtps) schedule(guided) c c find the field terms for each pairwise interaction c do ii = 1, npole i = ipole(ii) ci = rpole(1,i) uxi = rpole(2,i) uyi = rpole(3,i) uzi = rpole(4,i) qxxi = rpole(5,i) qxyi = rpole(6,i) qxzi = rpole(7,i) qyyi = rpole(9,i) qyzi = rpole(10,i) qzzi = rpole(13,i) rbi = rborn(i) c c set exclusion coefficients for connected atoms c if (dpequal) then 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 dscale(i12(j,i)) = pscale(i12(j,i)) 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 dscale(i13(j,i)) = pscale(i13(j,i)) 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 dscale(i14(j,i)) = pscale(i14(j,i)) 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 dscale(i15(j,i)) = pscale(i15(j,i)) end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = d1scale end do do j = 1, np12(i) dscale(ip12(j,i)) = d2scale end do do j = 1, np13(i) dscale(ip13(j,i)) = d3scale end do do j = 1, np14(i) dscale(ip14(j,i)) = d4scale end do end if c c evaluate all sites within the cutoff distance c do kk = ii, npole k = ipole(kk) proceed = .true. if (use_intra) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) then xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) xr2 = xr * xr yr2 = yr * yr zr2 = zr * zr r2 = xr2 + yr2 + zr2 if (r2 .le. off2) then r = sqrt(r2) ck = rpole(1,k) uxk = rpole(2,k) uyk = rpole(3,k) uzk = rpole(4,k) qxxk = rpole(5,k) qxyk = rpole(6,k) qxzk = rpole(7,k) qyyk = rpole(9,k) qyzk = rpole(10,k) qzzk = rpole(13,k) rbk = rborn(k) c c self-interactions for the solute field are skipped c if (i .ne. k) then call damptholed (i,k,7,r,dmpik) rr3 = dmpik(3) / (r*r2) rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2) dir = uxi*xr + uyi*yr + uzi*zr qix = qxxi*xr + qxyi*yr + qxzi*zr qiy = qxyi*xr + qyyi*yr + qyzi*zr qiz = qxzi*xr + qyzi*yr + qzzi*zr qir = qix*xr + qiy*yr + qiz*zr dkr = uxk*xr + uyk*yr + uzk*zr qkx = qxxk*xr + qxyk*yr + qxzk*zr qky = qxyk*xr + qyyk*yr + qyzk*zr qkz = qxzk*xr + qyzk*yr + qzzk*zr qkr = qkx*xr + qky*yr + qkz*zr fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*uxk + 2.0d0*rr5*qkx fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*uyk + 2.0d0*rr5*qky fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*uzk + 2.0d0*rr5*qkz fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*uxi - 2.0d0*rr5*qix fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*uyi - 2.0d0*rr5*qiy fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*uzi - 2.0d0*rr5*qiz do j = 1, 3 fieldt(j,i) = fieldt(j,i) + fid(j)*dscale(k) fieldt(j,k) = fieldt(j,k) + fkd(j)*dscale(k) fieldtp(j,i) = fieldtp(j,i) + fid(j)*pscale(k) fieldtp(j,k) = fieldtp(j,k) + fkd(j)*pscale(k) end do end if c c set the reaction potential auxiliary terms c rb2 = rbi * rbk expterm = exp(-r2/(gkc*rb2)) expc = expterm / gkc dexpc = -2.0d0 / (gkc*rb2) gf2 = 1.0d0 / (r2+rb2*expterm) gf = sqrt(gf2) gf3 = gf2 * gf gf5 = gf3 * gf2 gf7 = gf5 * gf2 a(0,0) = gf a(1,0) = -gf3 a(2,0) = 3.0d0 * gf5 a(3,0) = -15.0d0 * gf7 c c set the reaction potential gradient auxiliary terms c expc1 = 1.0d0 - expc a(0,1) = expc1 * a(1,0) a(1,1) = expc1 * a(2,0) a(2,1) = expc1 * a(3,0) c c dipole second reaction potential gradient auxiliary term c expcdexpc = -expc * dexpc a(1,2) = expc1*a(2,1) + expcdexpc*a(2,0) c c multiply the auxiliary terms by dielectric functions c a(0,1) = fc * a(0,1) a(1,0) = fd * a(1,0) a(1,1) = fd * a(1,1) a(1,2) = fd * a(1,2) a(2,0) = fq * a(2,0) a(2,1) = fq * a(2,1) c c unweighted dipole reaction potential tensor c gux(1) = xr * a(1,0) guy(1) = yr * a(1,0) guz(1) = zr * a(1,0) c c unweighted reaction potential gradient tensor c gc(2) = xr * a(0,1) gc(3) = yr * a(0,1) gc(4) = zr * a(0,1) gux(2) = a(1,0) + xr2*a(1,1) gux(3) = xr * yr * a(1,1) gux(4) = xr * zr * a(1,1) guy(2) = gux(3) guy(3) = a(1,0) + yr2*a(1,1) guy(4) = yr * zr * a(1,1) guz(2) = gux(4) guz(3) = guy(4) guz(4) = a(1,0) + zr2*a(1,1) gqxx(2) = xr * (2.0d0*a(2,0)+xr2*a(2,1)) gqxx(3) = yr * xr2*a(2,1) gqxx(4) = zr * xr2*a(2,1) gqyy(2) = xr * yr2*a(2,1) gqyy(3) = yr * (2.0d0*a(2,0)+yr2*a(2,1)) gqyy(4) = zr * yr2 * a(2,1) gqzz(2) = xr * zr2 * a(2,1) gqzz(3) = yr * zr2 * a(2,1) gqzz(4) = zr * (2.0d0*a(2,0)+zr2*a(2,1)) gqxy(2) = yr * (a(2,0)+xr2*a(2,1)) gqxy(3) = xr * (a(2,0)+yr2*a(2,1)) gqxy(4) = zr * xr * yr * a(2,1) gqxz(2) = zr * (a(2,0)+xr2*a(2,1)) gqxz(3) = gqxy(4) gqxz(4) = xr * (a(2,0)+zr2*a(2,1)) gqyz(2) = gqxy(4) gqyz(3) = zr * (a(2,0)+yr2*a(2,1)) gqyz(4) = yr * (a(2,0)+zr2*a(2,1)) c c unweighted dipole second reaction potential gradient tensor c gux(5) = xr * (3.0d0*a(1,1)+xr2*a(1,2)) gux(6) = yr * (a(1,1)+xr2*a(1,2)) gux(7) = zr * (a(1,1)+xr2*a(1,2)) gux(8) = xr * (a(1,1)+yr2*a(1,2)) gux(9) = zr * xr * yr * a(1,2) gux(10) = xr * (a(1,1)+zr2*a(1,2)) guy(5) = yr * (a(1,1)+xr2*a(1,2)) guy(6) = xr * (a(1,1)+yr2*a(1,2)) guy(7) = gux(9) guy(8) = yr * (3.0d0*a(1,1)+yr2*a(1,2)) guy(9) = zr * (a(1,1)+yr2*a(1,2)) guy(10) = yr * (a(1,1)+zr2*a(1,2)) guz(5) = zr * (a(1,1)+xr2*a(1,2)) guz(6) = gux(9) guz(7) = xr * (a(1,1)+zr2*a(1,2)) guz(8) = zr * (a(1,1)+yr2*a(1,2)) guz(9) = yr * (a(1,1)+zr2*a(1,2)) guz(10) = zr * (3.0d0*a(1,1)+zr2*a(1,2)) c c generalized Kirkwood permanent reaction field c fid(1) = uxk*gux(2) + uyk*gux(3) + uzk*gux(4) & + 0.5d0 * (ck*gux(1) + qxxk*gux(5) & + qyyk*gux(8) + qzzk*gux(10) & + 2.0d0*(qxyk*gux(6)+qxzk*gux(7) & +qyzk*gux(9))) & + 0.5d0 * (ck*gc(2) + qxxk*gqxx(2) & + qyyk*gqyy(2) + qzzk*gqzz(2) & + 2.0d0*(qxyk*gqxy(2)+qxzk*gqxz(2) & +qyzk*gqyz(2))) fid(2) = uxk*guy(2) + uyk*guy(3) + uzk*guy(4) & + 0.5d0 * (ck*guy(1) + qxxk*guy(5) & + qyyk*guy(8) + qzzk*guy(10) & + 2.0d0*(qxyk*guy(6)+qxzk*guy(7) & +qyzk*guy(9))) & + 0.5d0 * (ck*gc(3) + qxxk*gqxx(3) & + qyyk*gqyy(3) + qzzk*gqzz(3) & + 2.0d0*(qxyk*gqxy(3)+qxzk*gqxz(3) & +qyzk*gqyz(3))) fid(3) = uxk*guz(2) + uyk*guz(3) + uzk*guz(4) & + 0.5d0 * (ck*guz(1) + qxxk*guz(5) & + qyyk*guz(8) + qzzk*guz(10) & + 2.0d0*(qxyk*guz(6)+qxzk*guz(7) & +qyzk*guz(9))) & + 0.5d0 * (ck*gc(4) + qxxk*gqxx(4) & + qyyk*gqyy(4) + qzzk*gqzz(4) & + 2.0d0*(qxyk*gqxy(4)+qxzk*gqxz(4) & +qyzk*gqyz(4))) fkd(1) = uxi*gux(2) + uyi*gux(3) + uzi*gux(4) & - 0.5d0 * (ci*gux(1) + qxxi*gux(5) & + qyyi*gux(8) + qzzi*gux(10) & + 2.0d0*(qxyi*gux(6)+qxzi*gux(7) & +qyzi*gux(9))) & - 0.5d0 * (ci*gc(2) + qxxi*gqxx(2) & + qyyi*gqyy(2) + qzzi*gqzz(2) & + 2.0d0*(qxyi*gqxy(2)+qxzi*gqxz(2) & +qyzi*gqyz(2))) fkd(2) = uxi*guy(2) + uyi*guy(3) + uzi*guy(4) & - 0.5d0 * (ci*guy(1) + qxxi*guy(5) & + qyyi*guy(8) + qzzi*guy(10) & + 2.0d0*(qxyi*guy(6)+qxzi*guy(7) & +qyzi*guy(9))) & - 0.5d0 * (ci*gc(3) + qxxi*gqxx(3) & + qyyi*gqyy(3) + qzzi*gqzz(3) & + 2.0d0*(qxyi*gqxy(3)+qxzi*gqxz(3) & +qyzi*gqyz(3))) fkd(3) = uxi*guz(2) + uyi*guz(3) + uzi*guz(4) & - 0.5d0 * (ci*guz(1) + qxxi*guz(5) & + qyyi*guz(8) + qzzi*guz(10) & + 2.0d0*(qxyi*guz(6)+qxzi*guz(7) & +qyzi*guz(9))) & - 0.5d0 * (ci*gc(4) + qxxi*gqxx(4) & + qyyi*gqyy(4) + qzzi*gqzz(4) & + 2.0d0*(qxyi*gqxy(4)+qxzi*gqxz(4) & +qyzi*gqyz(4))) c c scale the self-field by half, such that it sums to one below c if (i .eq. k) then do j = 1, 3 fid(j) = 0.5d0 * fid(j) fkd(j) = 0.5d0 * fkd(j) end do end if do j = 1, 3 fieldts(j,i) = fieldts(j,i) + fid(j) fieldts(j,k) = fieldts(j,k) + fkd(j) fieldtps(j,i) = fieldtps(j,i) + fid(j) fieldtps(j,k) = fieldtps(j,k) + fkd(j) end do end if end if end do c c reset exclusion coefficients for connected atoms c if (dpequal) then do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 dscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 dscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 dscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 dscale(i15(j,i)) = 1.0d0 end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) dscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) dscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) dscale(ip14(j,i)) = 1.0d0 end do end if end do !$OMP END DO c c add local to global variables for OpenMP calculation c !$OMP DO do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) + fieldt(j,i) fieldp(j,i) = fieldp(j,i) + fieldtp(j,i) fields(j,i) = fields(j,i) + fieldts(j,i) fieldps(j,i) = fieldps(j,i) + fieldtps(j,i) end do end do !$OMP END DO c c combine permanent multipole field and GK reaction field c !$OMP DO do ii = 1, npole i = ipole(ii) do j = 1, 3 fields(j,i) = field(j,i) + fields(j,i) fieldps(j,i) = fieldp(j,i) + fieldps(j,i) end do end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (dscale) deallocate (pscale) deallocate (fieldt) deallocate (fieldtp) deallocate (fieldts) deallocate (fieldtps) return end c c c ################################################################## c ## ## c ## subroutine ufield0d -- generalized Kirkwood mutual field ## c ## ## c ################################################################## c c c "ufield0d" computes the mutual electrostatic field due to c induced dipole moments for use with with generalized Kirkwood c implicit solvation c c subroutine ufield0d (field,fieldp,fields,fieldps) use atoms use gkstuf use group use mpole use polar use polgrp use polpot use shunt use solute implicit none integer i,j,k integer ii,kk real*8 xr,yr,zr real*8 xr2,yr2,zr2 real*8 fgrp,r,r2 real*8 rr3,rr5 real*8 duix,duiy,duiz real*8 puix,puiy,puiz real*8 dukx,duky,dukz real*8 pukx,puky,pukz real*8 duir,dukr real*8 puir,pukr real*8 duixs,duiys,duizs real*8 puixs,puiys,puizs real*8 dukxs,dukys,dukzs real*8 pukxs,pukys,pukzs real*8 duirs,puirs real*8 dukrs,pukrs real*8 rb2,rbi,rbk real*8 dwater,fd real*8 gf,gf2,gf3,gf5 real*8 expterm,expc real*8 expc1,dexpc real*8 a(0:3,0:2) real*8 gux(10),guy(10) real*8 guz(10) real*8 fid(3),fkd(3) real*8 fip(3),fkp(3) real*8 fids(3),fkds(3) real*8 fips(3),fkps(3) real*8 dmpik(5) real*8, allocatable :: uscale(:) real*8 field(3,*) real*8 fieldp(3,*) real*8 fields(3,*) real*8 fieldps(3,*) real*8, allocatable :: fieldt(:,:) real*8, allocatable :: fieldtp(:,:) real*8, allocatable :: fieldts(:,:) real*8, allocatable :: fieldtps(:,:) logical proceed c c c zero out the value of the field at each site c do i = 1, npole do j = 1, 3 field(j,i) = 0.0d0 fieldp(j,i) = 0.0d0 fields(j,i) = 0.0d0 fieldps(j,i) = 0.0d0 end do end do c c set dielectric constant and scaling factor for water c dwater = 78.3d0 fd = 2.0d0 * (1.0d0-dwater) / (1.0d0+2.0d0*dwater) c c perform dynamic allocation of some local arrays c allocate (uscale(n)) c c set array needed to scale connected atom interactions c do i = 1, n uscale(i) = 1.0d0 end do c c perform dynamic allocation of some local arrays c allocate (fieldt(3,n)) allocate (fieldtp(3,n)) allocate (fieldts(3,n)) allocate (fieldtps(3,n)) c c initialize local variables for OpenMP calculation c do i = 1, n do j = 1, 3 fieldt(j,i) = 0.0d0 fieldtp(j,i) = 0.0d0 fieldts(j,i) = 0.0d0 fieldtps(j,i) = 0.0d0 end do end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(npole,ipole,rborn,uind,uinp, !$OMP& uinds,uinps,np11,np12,np13,np14,ip11,ip12,ip13,ip14,u1scale, !$OMP& u2scale,u3scale,u4scale,use_intra,x,y,z,off2,fd,gkc,field, !$OMP& fieldp,fields,fieldps) !$OMP& firstprivate(uscale) shared(fieldt,fieldtp,fieldts,fieldtps) !$OMP DO reduction(+:fieldt,fieldtp,fieldts,fieldtps) schedule(guided) c c find the field terms for each pairwise interaction c do ii = 1, npole i = ipole(ii) duix = uind(1,i) duiy = uind(2,i) duiz = uind(3,i) puix = uinp(1,i) puiy = uinp(2,i) puiz = uinp(3,i) duixs = uinds(1,i) duiys = uinds(2,i) duizs = uinds(3,i) puixs = uinps(1,i) puiys = uinps(2,i) puizs = uinps(3,i) rbi = rborn(i) c c set exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do c c evaluate all sites within the cutoff distance c do kk = ii, npole k = ipole(kk) proceed = .true. if (use_intra) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) then xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) xr2 = xr * xr yr2 = yr * yr zr2 = zr * zr r2 = xr2 + yr2 + zr2 if (r2 .le. off2) then r = sqrt(r2) dukx = uind(1,k) duky = uind(2,k) dukz = uind(3,k) pukx = uinp(1,k) puky = uinp(2,k) pukz = uinp(3,k) dukxs = uinds(1,k) dukys = uinds(2,k) dukzs = uinds(3,k) pukxs = uinps(1,k) pukys = uinps(2,k) pukzs = uinps(3,k) rbk = rborn(k) if (i .ne. k) then call dampthole (i,k,5,r,dmpik) dmpik(3) = uscale(k) * dmpik(3) dmpik(5) = uscale(k) * dmpik(5) rr3 = -dmpik(3) / (r*r2) rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) duir = xr*duix + yr*duiy + zr*duiz dukr = xr*dukx + yr*duky + zr*dukz puir = xr*puix + yr*puiy + zr*puiz pukr = xr*pukx + yr*puky + zr*pukz duirs = xr*duixs + yr*duiys + zr*duizs dukrs = xr*dukxs + yr*dukys + zr*dukzs puirs = xr*puixs + yr*puiys + zr*puizs pukrs = xr*pukxs + yr*pukys + zr*pukzs fid(1) = rr3*dukx + rr5*dukr*xr fid(2) = rr3*duky + rr5*dukr*yr fid(3) = rr3*dukz + rr5*dukr*zr fkd(1) = rr3*duix + rr5*duir*xr fkd(2) = rr3*duiy + rr5*duir*yr fkd(3) = rr3*duiz + rr5*duir*zr fip(1) = rr3*pukx + rr5*pukr*xr fip(2) = rr3*puky + rr5*pukr*yr fip(3) = rr3*pukz + rr5*pukr*zr fkp(1) = rr3*puix + rr5*puir*xr fkp(2) = rr3*puiy + rr5*puir*yr fkp(3) = rr3*puiz + rr5*puir*zr fids(1) = rr3*dukxs + rr5*dukrs*xr fids(2) = rr3*dukys + rr5*dukrs*yr fids(3) = rr3*dukzs + rr5*dukrs*zr fkds(1) = rr3*duixs + rr5*duirs*xr fkds(2) = rr3*duiys + rr5*duirs*yr fkds(3) = rr3*duizs + rr5*duirs*zr fips(1) = rr3*pukxs + rr5*pukrs*xr fips(2) = rr3*pukys + rr5*pukrs*yr fips(3) = rr3*pukzs + rr5*pukrs*zr fkps(1) = rr3*puixs + rr5*puirs*xr fkps(2) = rr3*puiys + rr5*puirs*yr fkps(3) = rr3*puizs + rr5*puirs*zr do j = 1, 3 fieldt(j,i) = fieldt(j,i) + fid(j) fieldt(j,k) = fieldt(j,k) + fkd(j) fieldtp(j,i) = fieldtp(j,i) + fip(j) fieldtp(j,k) = fieldtp(j,k) + fkp(j) fieldts(j,i) = fieldts(j,i) + fids(j) fieldts(j,k) = fieldts(j,k) + fkds(j) fieldtps(j,i) = fieldtps(j,i) + fips(j) fieldtps(j,k) = fieldtps(j,k) + fkps(j) end do end if c c unweighted dipole reaction potential gradient tensor c rb2 = rbi * rbk expterm = exp(-r2/(gkc*rb2)) expc = expterm / gkc dexpc = -2.0d0 / (gkc*rbi*rbk) gf2 = 1.0d0 / (r2+rb2*expterm) gf = sqrt(gf2) gf3 = gf2 * gf gf5 = gf3 * gf2 a(1,0) = -gf3 a(2,0) = 3.0d0 * gf5 expc1 = 1.0d0 - expc a(1,1) = expc1 * a(2,0) gux(2) = fd * (a(1,0) + xr2*a(1,1)) gux(3) = fd * xr*yr*a(1,1) gux(4) = fd * xr*zr*a(1,1) guy(2) = gux(3) guy(3) = fd * (a(1,0) + yr2*a(1,1)) guy(4) = fd * yr*zr*a(1,1) guz(2) = gux(4) guz(3) = guy(4) guz(4) = fd * (a(1,0) + zr2*a(1,1)) fids(1) = dukxs*gux(2) + dukys*guy(2) + dukzs*guz(2) fids(2) = dukxs*gux(3) + dukys*guy(3) + dukzs*guz(3) fids(3) = dukxs*gux(4) + dukys*guy(4) + dukzs*guz(4) fkds(1) = duixs*gux(2) + duiys*guy(2) + duizs*guz(2) fkds(2) = duixs*gux(3) + duiys*guy(3) + duizs*guz(3) fkds(3) = duixs*gux(4) + duiys*guy(4) + duizs*guz(4) fips(1) = pukxs*gux(2) + pukys*guy(2) + pukzs*guz(2) fips(2) = pukxs*gux(3) + pukys*guy(3) + pukzs*guz(3) fips(3) = pukxs*gux(4) + pukys*guy(4) + pukzs*guz(4) fkps(1) = puixs*gux(2) + puiys*guy(2) + puizs*guz(2) fkps(2) = puixs*gux(3) + puiys*guy(3) + puizs*guz(3) fkps(3) = puixs*gux(4) + puiys*guy(4) + puizs*guz(4) if (i .eq. k) then do j = 1, 3 fids(j) = 0.5d0 * fids(j) fkds(j) = 0.5d0 * fkds(j) fips(j) = 0.5d0 * fips(j) fkps(j) = 0.5d0 * fkps(j) end do end if do j = 1, 3 fieldts(j,i) = fieldts(j,i) + fids(j) fieldts(j,k) = fieldts(j,k) + fkds(j) fieldtps(j,i) = fieldtps(j,i) + fips(j) fieldtps(j,k) = fieldtps(j,k) + fkps(j) end do end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 end do end do !$OMP END DO c c add local to global variables for OpenMP calculation c !$OMP DO do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) + fieldt(j,i) fieldp(j,i) = fieldp(j,i) + fieldtp(j,i) fields(j,i) = fields(j,i) + fieldts(j,i) fieldps(j,i) = fieldps(j,i) + fieldtps(j,i) end do end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (uscale) deallocate (fieldt) deallocate (fieldtp) deallocate (fieldts) deallocate (fieldtps) return end c c c ################################################################## c ## ## c ## subroutine induce0d -- Poisson-Boltzmann induced dipoles ## c ## ## c ################################################################## c c c "induce0d" computes the induced dipole moments at polarizable c sites for Poisson-Boltzmann SCRF and vacuum environments c c subroutine induce0d use atoms use extfld use inform use iounit use limits use mpole use polar use polopt use polpot use potent use units use uprior implicit none integer i,j,k integer ii,iter integer miniter integer maxiter real*8 polmin real*8 eps,epsold real*8 epsd,epsp real*8 epsds,epsps real*8 udsum,upsum real*8 ussum,upssum real*8 a,ap,as,aps real*8 b,bp,bs,bps real*8 sum,sump real*8 sums,sumps real*8, allocatable :: poli(:) real*8, allocatable :: field(:,:) real*8, allocatable :: fieldp(:,:) real*8, allocatable :: fields(:,:) real*8, allocatable :: fieldps(:,:) real*8, allocatable :: rsd(:,:) real*8, allocatable :: rsdp(:,:) real*8, allocatable :: rsds(:,:) real*8, allocatable :: rsdps(:,:) real*8, allocatable :: zrsd(:,:) real*8, allocatable :: zrsdp(:,:) real*8, allocatable :: zrsds(:,:) real*8, allocatable :: zrsdps(:,:) real*8, allocatable :: conj(:,:) real*8, allocatable :: conjp(:,:) real*8, allocatable :: conjs(:,:) real*8, allocatable :: conjps(:,:) real*8, allocatable :: vec(:,:) real*8, allocatable :: vecp(:,:) real*8, allocatable :: vecs(:,:) real*8, allocatable :: vecps(:,:) real*8, allocatable :: usum(:,:) real*8, allocatable :: usump(:,:) real*8, allocatable :: usums(:,:) real*8, allocatable :: usumps(:,:) logical done character*6 mode c c c zero out the induced dipoles; uind and uinp are vacuum dipoles, c uinds and uinps are Poisson-Boltzmann SCRF dipoles c do i = 1, n do j = 1, 3 uind(j,i) = 0.0d0 uinp(j,i) = 0.0d0 uinds(j,i) = 0.0d0 uinps(j,i) = 0.0d0 end do end do if (.not.use_polar .or. .not.use_solv) return c c set the switching function coefficients c mode = 'MPOLE' call switch (mode) c c perform dynamic allocation of some local arrays c allocate (field(3,n)) allocate (fieldp(3,n)) allocate (fields(3,n)) allocate (fieldps(3,n)) c c compute induced dipoles based on direct and mutual fields c 10 continue c c compute the direct induced dipole moment at each atom, and c another set that also includes RF due to permanent multipoles c call dfield0e (field,fieldp,fields,fieldps) c c add external electric field to the direct field values c if (use_exfld) then do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = field(j,i) + exfld(j) fieldp(j,i) = fieldp(j,i) + exfld(j) fields(j,i) = fields(j,i) + exfld(j) fieldps(j,i) = fieldps(j,i) + exfld(j) end do end do end if c c set vacuum induced dipoles to polarizability times direct field; c SCRF induced dipoles are polarizability times direct field c plus the reaction field due to permanent multipoles c do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 udir(j,i) = polarity(i) * field(j,i) udirp(j,i) = polarity(i) * fieldp(j,i) udirs(j,i) = polarity(i) * fields(j,i) udirps(j,i) = polarity(i) * fieldps(j,i) uind(j,i) = udir(j,i) uinp(j,i) = udirp(j,i) uinds(j,i) = udirs(j,i) uinps(j,i) = udirps(j,i) end do end if end do c c get induced dipoles via the OPT extrapolation method c if (poltyp .eq. 'OPT') then do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uopt(0,j,i) = udir(j,i) uoptp(0,j,i) = udirp(j,i) uopts(0,j,i) = udirs(j,i) uoptps(0,j,i) = udirps(j,i) end do end if end do do k = 1, optorder call ufield0e (field,fieldp,fields,fieldps) do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uopt(k,j,i) = polarity(i) * field(j,i) uoptp(k,j,i) = polarity(i) * fieldp(j,i) uopts(k,j,i) = polarity(i) * fields(j,i) uoptps(k,j,i) = polarity(i) * fieldps(j,i) uind(j,i) = uopt(k,j,i) uinp(j,i) = uoptp(k,j,i) uinds(j,i) = uopts(k,j,i) uinps(j,i) = uoptps(k,j,i) end do end if end do end do allocate (usum(3,n)) allocate (usump(3,n)) allocate (usums(3,n)) allocate (usumps(3,n)) do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = 0.0d0 uinp(j,i) = 0.0d0 uinds(j,i) = 0.0d0 uinps(j,i) = 0.0d0 usum(j,i) = 0.0d0 usump(j,i) = 0.0d0 usums(j,i) = 0.0d0 usumps(j,i) = 0.0d0 do k = 0, optorder usum(j,i) = usum(j,i) + uopt(k,j,i) usump(j,i) = usump(j,i) + uoptp(k,j,i) usums(j,i) = usums(j,i) + uopts(k,j,i) usumps(j,i) = usumps(j,i) + uoptps(k,j,i) uind(j,i) = uind(j,i) + copt(k)*usum(j,i) uinp(j,i) = uinp(j,i) + copt(k)*usump(j,i) uinds(j,i) = uinds(j,i) + copt(k)*usums(j,i) uinps(j,i) = uinps(j,i) + copt(k)*usumps(j,i) end do end do end if end do deallocate (usum) deallocate (usump) deallocate (usums) deallocate (usumps) end if c c set tolerances for computation of mutual induced dipoles c if (poltyp .eq. 'MUTUAL') then done = .false. miniter = min(3,npole) maxiter = 100 iter = 0 polmin = 0.00000001d0 eps = 100.0d0 c c estimated induced dipoles from polynomial predictor c if (use_pred .and. nualt.eq.maxualt) then do ii = 1, npole i = ipole(ii) do j = 1, 3 udsum = 0.0d0 upsum = 0.0d0 ussum = 0.0d0 upssum = 0.0d0 do k = 1, nualt-1 udsum = udsum + bpred(k)*udalt(k,j,i) upsum = upsum + bpredp(k)*upalt(k,j,i) ussum = ussum + bpreds(k)*usalt(k,j,i) upssum = upssum + bpredps(k)*upsalt(k,j,i) end do uind(j,i) = udsum uinp(j,i) = upsum uinds(j,i) = ussum uinps(j,i) = upssum end do end do end if c c perform dynamic allocation of some local arrays c allocate (poli(n)) allocate (rsd(3,n)) allocate (rsdp(3,n)) allocate (rsds(3,n)) allocate (rsdps(3,n)) allocate (zrsd(3,n)) allocate (zrsdp(3,n)) allocate (zrsds(3,n)) allocate (zrsdps(3,n)) allocate (conj(3,n)) allocate (conjp(3,n)) allocate (conjs(3,n)) allocate (conjps(3,n)) allocate (vec(3,n)) allocate (vecp(3,n)) allocate (vecs(3,n)) allocate (vecps(3,n)) c c set initial conjugate gradient residual and conjugate vector c call ufield0e (field,fieldp,fields,fieldps) do ii = 1, npole i = ipole(ii) if (douind(i)) then poli(i) = max(polmin,polarity(i)) do j = 1, 3 rsd(j,i) = (udir(j,i)-uind(j,i))/poli(i) & + field(j,i) rsdp(j,i) = (udirp(j,i)-uinp(j,i))/poli(i) & + fieldp(j,i) rsds(j,i) = (udirs(j,i)-uinds(j,i))/poli(i) & + fields(j,i) rsdps(j,i) = (udirps(j,i)-uinps(j,i))/poli(i) & + fieldps(j,i) zrsd(j,i) = rsd(j,i) * poli(i) zrsdp(j,i) = rsdp(j,i) * poli(i) zrsds(j,i) = rsds(j,i) * poli(i) zrsdps(j,i) = rsdps(j,i) * poli(i) conj(j,i) = zrsd(j,i) conjp(j,i) = zrsdp(j,i) conjs(j,i) = zrsds(j,i) conjps(j,i) = zrsdps(j,i) end do end if end do c c conjugate gradient iteration of the mutual induced dipoles c do while (.not. done) iter = iter + 1 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 vec(j,i) = uind(j,i) vecp(j,i) = uinp(j,i) vecs(j,i) = uinds(j,i) vecps(j,i) = uinps(j,i) uind(j,i) = conj(j,i) uinp(j,i) = conjp(j,i) uinds(j,i) = conjs(j,i) uinps(j,i) = conjps(j,i) end do end if end do call ufield0e (field,fieldp,fields,fieldps) do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = vec(j,i) uinp(j,i) = vecp(j,i) uinds(j,i) = vecs(j,i) uinps(j,i) = vecps(j,i) vec(j,i) = conj(j,i)/poli(i) - field(j,i) vecp(j,i) = conjp(j,i)/poli(i) - fieldp(j,i) vecs(j,i) = conjs(j,i)/poli(i) - fields(j,i) vecps(j,i) = conjps(j,i)/poli(i) - fieldps(j,i) end do end if end do a = 0.0d0 ap = 0.0d0 as = 0.0d0 aps = 0.0d0 sum = 0.0d0 sump = 0.0d0 sums = 0.0d0 sumps = 0.0d0 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 a = a + conj(j,i)*vec(j,i) ap = ap + conjp(j,i)*vecp(j,i) as = as + conjs(j,i)*vecs(j,i) aps = aps + conjps(j,i)*vecps(j,i) sum = sum + rsd(j,i)*zrsd(j,i) sump = sump + rsdp(j,i)*zrsdp(j,i) sums = sums + rsds(j,i)*zrsds(j,i) sumps = sumps + rsdps(j,i)*zrsdps(j,i) end do end if end do if (a .ne. 0.0d0) a = sum / a if (ap .ne. 0.0d0) ap = sump / ap if (as .ne. 0.0d0) as = sums / as if (aps .ne. 0.0d0) aps = sumps / aps do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = uind(j,i) + a*conj(j,i) uinp(j,i) = uinp(j,i) + ap*conjp(j,i) uinds(j,i) = uinds(j,i) + as*conjs(j,i) uinps(j,i) = uinps(j,i) + aps*conjps(j,i) rsd(j,i) = rsd(j,i) - a*vec(j,i) rsdp(j,i) = rsdp(j,i) - ap*vecp(j,i) rsds(j,i) = rsds(j,i) - as*vecs(j,i) rsdps(j,i) = rsdps(j,i) - aps*vecps(j,i) end do end if end do b = 0.0d0 bp = 0.0d0 bs = 0.0d0 bps = 0.0d0 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 zrsd(j,i) = rsd(j,i) * poli(i) zrsdp(j,i) = rsdp(j,i) * poli(i) zrsds(j,i) = rsds(j,i) * poli(i) zrsdps(j,i) = rsdps(j,i) * poli(i) b = b + rsd(j,i)*zrsd(j,i) bp = bp + rsdp(j,i)*zrsdp(j,i) bs = bs + rsds(j,i)*zrsds(j,i) bps = bps + rsdps(j,i)*zrsdps(j,i) end do end if end do if (sum .ne. 0.0d0) b = b / sum if (sump .ne. 0.0d0) bp = bp / sump if (sums .ne. 0.0d0) bs = bs / sums if (sumps .ne. 0.0d0) bps = bps / sumps epsd = 0.0d0 epsp = 0.0d0 epsds = 0.0d0 epsps = 0.0d0 do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 conj(j,i) = zrsd(j,i) + b*conj(j,i) conjp(j,i) = zrsdp(j,i) + bp*conjp(j,i) conjs(j,i) = zrsds(j,i) + bs*conjs(j,i) conjps(j,i) = zrsdps(j,i) + bps*conjps(j,i) epsd = epsd + rsd(j,i)*rsd(j,i) epsp = epsp + rsdp(j,i)*rsdp(j,i) epsds = epsds + rsds(j,i)*rsds(j,i) epsps = epsps + rsdps(j,i)*rsdps(j,i) end do end if end do c c check the convergence of the mutual induced dipoles c epsold = eps eps = max(epsd,epsp,epsds,epsps) eps = debye * sqrt(eps/dble(npolar)) if (debug) then if (iter .eq. 1) then write (iout,20) 20 format (/,' Determination of Induced Dipole', & ' Moments :', & //,4x,'Iter',8x,'RMS Change (Debye)',/) end if write (iout,30) iter,eps 30 format (i8,7x,f16.10) end if if (eps .lt. poleps) done = .true. if (eps .gt. epsold) done = .true. if (iter .lt. miniter) done = .false. if (iter .ge. politer) done = .true. c c apply a "peek" iteration to the mutual induced dipoles c if (done) then do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = uind(j,i) + poli(i)*rsd(j,i) uinp(j,i) = uinp(j,i) + poli(i)*rsdp(j,i) uinds(j,i) = uinds(j,i) + poli(i)*rsds(j,i) uinps(j,i) = uinps(j,i) + poli(i)*rsdps(j,i) end do end if end do end if end do c c perform deallocation of some local arrays c deallocate (poli) deallocate (rsd) deallocate (rsdp) deallocate (rsds) deallocate (rsdps) deallocate (zrsd) deallocate (zrsdp) deallocate (zrsds) deallocate (zrsdps) deallocate (conj) deallocate (conjp) deallocate (conjs) deallocate (conjps) deallocate (vec) deallocate (vecp) deallocate (vecs) deallocate (vecps) c c print the results from the conjugate gradient iteration c if (debug) then write (iout,40) iter,eps 40 format (/,' Induced Dipoles :',6x,'Iterations',i5, & 6x,'RMS Change',f15.10) end if c c terminate the calculation if dipoles failed to converge c if (iter.ge.maxiter .or. eps.gt.epsold) then if (use_ulist) then use_ulist = .false. usolvcut = 0.0d0 if (verbose) then write (iout,50) 50 format (/,' INDUCE -- Switching to Diagonal', & ' PCG Preconditioner') end if goto 10 else write (iout,60) 60 format (/,' INDUCE -- Warning, Induced Dipoles', & ' are not Converged') call prterr call fatal end if end if end if c c perform deallocation of some local arrays c deallocate (field) deallocate (fieldp) deallocate (fields) deallocate (fieldps) return end c c c ############################################################### c ## ## c ## subroutine dfield0e -- Poisson-Boltzmann direct field ## c ## ## c ############################################################### c c c "dfield0e" computes the direct electrostatic field due to c permanent multipole moments for use with in Poisson-Boltzmann c c subroutine dfield0e (field,fieldp,fields,fieldps) use atoms use couple use group use mpole use pbstuf use polar use polgrp use polpot use shunt use solpot implicit none integer i,j,k integer ii,kk real*8 xr,yr,zr real*8 xr2,yr2,zr2 real*8 fgrp,r,r2 real*8 rr3,rr5,rr7 real*8 ci,dix,diy,diz real*8 qixx,qixy,qixz real*8 qiyy,qiyz,qizz real*8 ck,dkx,dky,dkz real*8 qkxx,qkxy,qkxz real*8 qkyy,qkyz,qkzz real*8 dir,dkr real*8 qix,qiy,qiz,qir real*8 qkx,qky,qkz,qkr real*8 fid(3),fkd(3) real*8 dmpik(7) real*8 field(3,*) real*8 fieldp(3,*) real*8 fields(3,*) real*8 fieldps(3,*) real*8, allocatable :: dscale(:) real*8, allocatable :: pscale(:) logical proceed c c c zero out the value of the field at each site c do i = 1, n do j = 1, 3 field(j,i) = 0.0d0 fieldp(j,i) = 0.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (dscale(n)) allocate (pscale(n)) c c set arrays needed to scale connected atom interactions c do i = 1, n pscale(i) = 1.0d0 dscale(i) = 1.0d0 end do c c compute the direct electrostatic field at each atom, and c another field including RF due to permanent multipoles; c note self-interactions for the solute field are skipped c do ii = 1, npole i = ipole(ii) ci = rpole(1,i) dix = rpole(2,i) diy = rpole(3,i) diz = rpole(4,i) qixx = rpole(5,i) qixy = rpole(6,i) qixz = rpole(7,i) qiyy = rpole(9,i) qiyz = rpole(10,i) qizz = rpole(13,i) c c set exclusion coefficients for connected atoms c if (dpequal) then 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 dscale(i12(j,i)) = pscale(i12(j,i)) 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 dscale(i13(j,i)) = pscale(i13(j,i)) 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 dscale(i14(j,i)) = pscale(i14(j,i)) 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 dscale(i15(j,i)) = pscale(i15(j,i)) end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = d1scale end do do j = 1, np12(i) dscale(ip12(j,i)) = d2scale end do do j = 1, np13(i) dscale(ip13(j,i)) = d3scale end do do j = 1, np14(i) dscale(ip14(j,i)) = d4scale end do end if c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) proceed = .true. if (use_intra) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) then xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) xr2 = xr * xr yr2 = yr * yr zr2 = zr * zr r2 = xr2 + yr2 + zr2 if (r2 .le. off2) then r = sqrt(r2) ck = rpole(1,k) dkx = rpole(2,k) dky = rpole(3,k) dkz = rpole(4,k) qkxx = rpole(5,k) qkxy = rpole(6,k) qkxz = rpole(7,k) qkyy = rpole(9,k) qkyz = rpole(10,k) qkzz = rpole(13,k) call damptholed (i,k,7,r,dmpik) rr3 = dmpik(3) / (r*r2) rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) rr7 = 15.0d0 * dmpik(7) / (r*r2*r2*r2) dir = dix*xr + diy*yr + diz*zr qix = qixx*xr + qixy*yr + qixz*zr qiy = qixy*xr + qiyy*yr + qiyz*zr qiz = qixz*xr + qiyz*yr + qizz*zr qir = qix*xr + qiy*yr + qiz*zr dkr = dkx*xr + dky*yr + dkz*zr qkx = qkxx*xr + qkxy*yr + qkxz*zr qky = qkxy*xr + qkyy*yr + qkyz*zr qkz = qkxz*xr + qkyz*yr + qkzz*zr qkr = qkx*xr + qky*yr + qkz*zr fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dkx + 2.0d0*rr5*qkx fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dky + 2.0d0*rr5*qky fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dkz + 2.0d0*rr5*qkz fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*dix - 2.0d0*rr5*qix fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*diy - 2.0d0*rr5*qiy fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*diz - 2.0d0*rr5*qiz do j = 1, 3 field(j,i) = field(j,i) + fid(j)*dscale(k) field(j,k) = field(j,k) + fkd(j)*dscale(k) fieldp(j,i) = fieldp(j,i) + fid(j)*pscale(k) fieldp(j,k) = fieldp(j,k) + fkd(j)*pscale(k) end do end if end if end do c c reset exclusion coefficients for connected atoms c if (dpequal) then do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 dscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 dscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 dscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 dscale(i15(j,i)) = 1.0d0 end do else 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 do j = 1, np11(i) dscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) dscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) dscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) dscale(ip14(j,i)) = 1.0d0 end do end if end do c c perform deallocation of some local arrays c deallocate (dscale) deallocate (pscale) c c find the Poisson-Boltzmann reaction field at each site c call pbempole c c combine permanent multipole field and PB reaction field c do ii = 1, npole i = ipole(ii) do j = 1, 3 fields(j,i) = field(j,i) + pbep(j,i) fieldps(j,i) = fieldp(j,i) + pbep(j,i) end do end do return end c c c ############################################################### c ## ## c ## subroutine ufield0e -- Poisson-Boltzmann mutual field ## c ## ## c ############################################################### c c c "ufield0e" computes the mutual electrostatic field due to c induced dipole moments via a Poisson-Boltzmann solver c c subroutine ufield0e (field,fieldp,fields,fieldps) use atoms use group use mpole use pbstuf use polar use polgrp use polpot use shunt use solpot implicit none integer i,j,k integer ii,kk real*8 xr,yr,zr real*8 xr2,yr2,zr2 real*8 fgrp,r,r2 real*8 rr3,rr5 real*8 duix,duiy,duiz real*8 puix,puiy,puiz real*8 dukx,duky,dukz real*8 pukx,puky,pukz real*8 duir,puir real*8 dukr,pukr real*8 duixs,duiys,duizs real*8 puixs,puiys,puizs real*8 dukxs,dukys,dukzs real*8 pukxs,pukys,pukzs real*8 duirs,puirs real*8 dukrs,pukrs real*8 fid(3),fkd(3) real*8 fip(3),fkp(3) real*8 fids(3),fkds(3) real*8 fips(3),fkps(3) real*8 dmpik(5) real*8 field(3,*) real*8 fieldp(3,*) real*8 fields(3,*) real*8 fieldps(3,*) real*8, allocatable :: uscale(:) real*8, allocatable :: indpole(:,:) real*8, allocatable :: inppole(:,:) logical proceed c c c zero out the value of the field at each site c do i = 1, n do j = 1, 3 field(j,i) = 0.0d0 fieldp(j,i) = 0.0d0 fields(j,i) = 0.0d0 fieldps(j,i) = 0.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (uscale(n)) c c set array needed to scale connected atom interactions c do i = 1, n uscale(i) = 1.0d0 end do c c compute the mutual electrostatic field at each atom, c and another field including RF due to induced dipoles c do ii = 1, npole i = ipole(ii) duix = uind(1,i) duiy = uind(2,i) duiz = uind(3,i) puix = uinp(1,i) puiy = uinp(2,i) puiz = uinp(3,i) duixs = uinds(1,i) duiys = uinds(2,i) duizs = uinds(3,i) puixs = uinps(1,i) puiys = uinps(2,i) puizs = uinps(3,i) c c set exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) proceed = .true. if (use_intra) call groups (proceed,fgrp,i,k,0,0,0,0) if (proceed) then xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) xr2 = xr * xr yr2 = yr * yr zr2 = zr * zr r2 = xr2 + yr2 + zr2 if (r2 .le. off2) then r = sqrt(r2) dukx = uind(1,k) duky = uind(2,k) dukz = uind(3,k) pukx = uinp(1,k) puky = uinp(2,k) pukz = uinp(3,k) dukxs = uinds(1,k) dukys = uinds(2,k) dukzs = uinds(3,k) pukxs = uinps(1,k) pukys = uinps(2,k) pukzs = uinps(3,k) call dampthole (i,k,5,r,dmpik) dmpik(3) = uscale(k) * dmpik(3) dmpik(5) = uscale(k) * dmpik(5) rr3 = -dmpik(3) / (r*r2) rr5 = 3.0d0 * dmpik(5) / (r*r2*r2) duir = xr*duix + yr*duiy + zr*duiz dukr = xr*dukx + yr*duky + zr*dukz puir = xr*puix + yr*puiy + zr*puiz pukr = xr*pukx + yr*puky + zr*pukz duirs = xr*duixs + yr*duiys + zr*duizs dukrs = xr*dukxs + yr*dukys + zr*dukzs puirs = xr*puixs + yr*puiys + zr*puizs pukrs = xr*pukxs + yr*pukys + zr*pukzs fid(1) = rr3*dukx + rr5*dukr*xr fid(2) = rr3*duky + rr5*dukr*yr fid(3) = rr3*dukz + rr5*dukr*zr fkd(1) = rr3*duix + rr5*duir*xr fkd(2) = rr3*duiy + rr5*duir*yr fkd(3) = rr3*duiz + rr5*duir*zr fip(1) = rr3*pukx + rr5*pukr*xr fip(2) = rr3*puky + rr5*pukr*yr fip(3) = rr3*pukz + rr5*pukr*zr fkp(1) = rr3*puix + rr5*puir*xr fkp(2) = rr3*puiy + rr5*puir*yr fkp(3) = rr3*puiz + rr5*puir*zr fids(1) = rr3*dukxs + rr5*dukrs*xr fids(2) = rr3*dukys + rr5*dukrs*yr fids(3) = rr3*dukzs + rr5*dukrs*zr fkds(1) = rr3*duixs + rr5*duirs*xr fkds(2) = rr3*duiys + rr5*duirs*yr fkds(3) = rr3*duizs + rr5*duirs*zr fips(1) = rr3*pukxs + rr5*pukrs*xr fips(2) = rr3*pukys + rr5*pukrs*yr fips(3) = rr3*pukzs + rr5*pukrs*zr fkps(1) = rr3*puixs + rr5*puirs*xr fkps(2) = rr3*puiys + rr5*puirs*yr fkps(3) = rr3*puizs + rr5*puirs*zr do j = 1, 3 field(j,i) = field(j,i) + fid(j) field(j,k) = field(j,k) + fkd(j) fieldp(j,i) = fieldp(j,i) + fip(j) fieldp(j,k) = fieldp(j,k) + fkp(j) fields(j,i) = fields(j,i) + fids(j) fields(j,k) = fields(j,k) + fkds(j) fieldps(j,i) = fieldps(j,i) + fips(j) fieldps(j,k) = fieldps(j,k) + fkps(j) end do end if end if end do c c reset exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (uscale) c c perform dynamic allocation of some global arrays c if (.not. allocated(pbeuind)) allocate (pbeuind(3,n)) if (.not. allocated(pbeuinp)) allocate (pbeuinp(3,n)) c c perform dynamic allocation of some local arrays c allocate (indpole(3,n)) allocate (inppole(3,n)) c c zero out the PB reaction field at each atomic site c do i = 1, n do j = 1, 3 indpole(j,i) = 0.0d0 inppole(j,i) = 0.0d0 pbeuind(j,i) = 0.0d0 pbeuinp(j,i) = 0.0d0 end do end do c c find the Poisson-Boltzmann reaction field at each site c do ii = 1, npole i = ipole(ii) do j = 1, 3 indpole(j,i) = uinds(j,i) inppole(j,i) = uinps(j,i) end do end do call apbsinduce (indpole,pbeuind) call apbsnlinduce (inppole,pbeuinp) c c perform deallocation of some local arrays c deallocate (indpole) deallocate (inppole) c c combine mutual induced dipole field and PB reaction field c do ii = 1, npole i = ipole(ii) do j = 1, 3 fields(j,i) = fields(j,i) + pbeuind(j,i) fieldps(j,i) = fieldps(j,i) + pbeuinp(j,i) end do end do return end c c c ################################################################ c ## ## c ## subroutine ulspred -- induced dipole prediction coeffs ## c ## ## c ################################################################ c c c "ulspred" uses an ASPC or Gear extrapolation method, or a least c squares fit, to set coefficients of an induced dipole predictor c polynomial c c literature references: c c J. Kolafa, "Time-Reversible Always Stable Predictor-Corrector c Method for Molecular Dynamics of Polarizable Molecules", Journal c of Computational Chemistry, 25, 335-342 (2004) c c D. Nocito and G. J. O. Beran, Reduced Computational Cost c of Polarizable Force Fields by a Modification of the Always c Stable Predictor-Corrector, Journal of Chemical Physics, 150, c 151103 (2019) c c W. Wang and R. D. Skeel, "Fast Evaluation of Polarizable Forces", c Journal of Chemical Physics, 123, 164107 (2005) c c subroutine ulspred use mpole use uprior implicit none integer i,j,k,m,ii real*8 coeff,udk,upk real*8 amax,apmax real*8 b(maxualt) real*8 bp(maxualt) real*8 a(maxualt*(maxualt+1)/2) real*8 ap(maxualt*(maxualt+1)/2) real*8 c(maxualt,maxualt) real*8 cp(maxualt,maxualt) c c c set always stable predictor-corrector (ASPC) coefficients c if (polpred .eq. 'ASPC') then do i = 1, nualt coeff = aspc(i) bpred(i) = coeff bpredp(i) = coeff bpreds(i) = coeff bpredps(i) = coeff end do c c set the Gear predictor binomial coefficients c else if (polpred .eq. 'GEAR') then do i = 1, nualt coeff = gear(i) bpred(i) = coeff bpredp(i) = coeff bpreds(i) = coeff bpredps(i) = coeff end do c c derive normal equations corresponding to least squares fit c else if (polpred .eq. 'LSQR') then do k = 1, nualt b(k) = 0.0d0 bp(k) = 0.0d0 do m = k, nualt c(k,m) = 0.0d0 cp(k,m) = 0.0d0 end do end do do ii = 1, npole i = ipole(ii) do j = 1, 3 do k = 1, nualt udk = udalt(k,j,i) upk = upalt(k,j,i) do m = k, nualt c(k,m) = c(k,m) + udk*udalt(m,j,i) cp(k,m) = cp(k,m) + upk*upalt(m,j,i) end do end do end do end do i = 0 do k = 2, nualt b(k-1) = c(1,k) bp(k-1) = cp(1,k) do m = k, nualt i = i + 1 a(i) = c(k,m) ap(i) = cp(k,m) end do end do c c check for nonzero coefficients of the normal equations c k = nualt - 1 amax = 0.0d0 apmax = 0.0d0 do i = 1, k*(k+1)/2 amax = max(amax,a(i)) apmax = max(apmax,ap(i)) end do c c solve the normal equations via LU matrix factorization c if (amax .ne. 0.0d0) call lusolve (k,a,b) if (apmax .ne. 0.0d0) call lusolve (k,ap,bp) c c transfer the final solution to the coefficient vector c do k = 1, nualt-1 bpred(k) = b(k) bpredp(k) = bp(k) bpreds(k) = b(k) bpredps(k) = bp(k) end do bpred(nualt) = 0.0d0 bpredp(nualt) = 0.0d0 bpreds(nualt) = 0.0d0 bpredps(nualt) = 0.0d0 end if return end c c c ############################################################### c ## ## c ## subroutine uscale0a -- dipole preconditioner via loop ## c ## ## c ############################################################### c c c "uscale0a" builds and applies a preconditioner for the conjugate c gradient induced dipole solver using a double loop c c subroutine uscale0a (mode,rsd,rsdp,zrsd,zrsdp) use atoms use chgpen use couple use limits use mplpot use mpole use polar use polgrp use polpcg use polpot implicit none integer i,j,k,m integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 r,r2,rr3,rr5 real*8 polmin real*8 poli,polik real*8 alphai,alphak real*8 off2 real*8 m1,m2,m3 real*8 m4,m5,m6 real*8 dmpik(5) real*8, allocatable :: uscale(:) real*8, allocatable :: wscale(:) real*8 rsd(3,*) real*8 rsdp(3,*) real*8 zrsd(3,*) real*8 zrsdp(3,*) character*6 mode c c c apply the preconditioning matrix to the current residual c if (mode .eq. 'APPLY') then c c use diagonal preconditioner elements as first approximation c polmin = 0.00000001d0 do ii = 1, npole i = ipole(ii) poli = uaccel * max(polmin,polarity(i)) do j = 1, 3 zrsd(j,i) = poli * rsd(j,i) zrsdp(j,i) = poli * rsdp(j,i) end do end do c c use the off-diagonal preconditioner elements in second phase c off2 = usolvcut * usolvcut m = 0 do ii = 1, npole-1 i = ipole(ii) do kk = ii+1, npole k = ipole(kk) xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then m1 = minv(m+1) m2 = minv(m+2) m3 = minv(m+3) m4 = minv(m+4) m5 = minv(m+5) m6 = minv(m+6) m = m + 6 zrsd(1,i) = zrsd(1,i) + m1*rsd(1,k) & + m2*rsd(2,k) + m3*rsd(3,k) zrsd(2,i) = zrsd(2,i) + m2*rsd(1,k) & + m4*rsd(2,k) + m5*rsd(3,k) zrsd(3,i) = zrsd(3,i) + m3*rsd(1,k) & + m5*rsd(2,k) + m6*rsd(3,k) zrsd(1,k) = zrsd(1,k) + m1*rsd(1,i) & + m2*rsd(2,i) + m3*rsd(3,i) zrsd(2,k) = zrsd(2,k) + m2*rsd(1,i) & + m4*rsd(2,i) + m5*rsd(3,i) zrsd(3,k) = zrsd(3,k) + m3*rsd(1,i) & + m5*rsd(2,i) + m6*rsd(3,i) zrsdp(1,i) = zrsdp(1,i) + m1*rsdp(1,k) & + m2*rsdp(2,k) + m3*rsdp(3,k) zrsdp(2,i) = zrsdp(2,i) + m2*rsdp(1,k) & + m4*rsdp(2,k) + m5*rsdp(3,k) zrsdp(3,i) = zrsdp(3,i) + m3*rsdp(1,k) & + m5*rsdp(2,k) + m6*rsdp(3,k) zrsdp(1,k) = zrsdp(1,k) + m1*rsdp(1,i) & + m2*rsdp(2,i) + m3*rsdp(3,i) zrsdp(2,k) = zrsdp(2,k) + m2*rsdp(1,i) & + m4*rsdp(2,i) + m5*rsdp(3,i) zrsdp(3,k) = zrsdp(3,k) + m3*rsdp(1,i) & + m5*rsdp(2,i) + m6*rsdp(3,i) end if end do end do c c construct off-diagonal elements of preconditioning matrix c else if (mode .eq. 'BUILD') then c c perform dynamic allocation of some local arrays c allocate (uscale(n)) allocate (wscale(n)) c c set array needed to scale connected atom interactions c do i = 1, n uscale(i) = 1.0d0 wscale(i) = 1.0d0 end do c c determine the off-diagonal elements of the preconditioner c off2 = usolvcut * usolvcut m = 0 do ii = 1, npole-1 i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) poli = polarity(i) if (use_chgpen) alphai = palpha(i) c c set exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do do j = 1, n12(i) wscale(i12(j,i)) = w2scale end do do j = 1, n13(i) wscale(i13(j,i)) = w3scale end do do j = 1, n14(i) wscale(i14(j,i)) = w4scale end do do j = 1, n15(i) wscale(i15(j,i)) = w5scale end do c c evaluate all sites within the cutoff distance c do kk = ii+1, npole k = ipole(kk) xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr if (r2 .le. off2) then r = sqrt(r2) if (use_thole) then call dampthole (i,k,5,r,dmpik) dmpik(3) = uscale(k) * dmpik(3) dmpik(5) = uscale(k) * dmpik(5) else if (use_chgpen) then alphak = palpha(k) call dampmut (r,alphai,alphak,dmpik) dmpik(3) = wscale(k) * dmpik(3) dmpik(5) = wscale(k) * dmpik(5) end if polik = poli * polarity(k) rr3 = dmpik(3) * polik / (r*r2) rr5 = 3.0d0 * dmpik(5) * polik / (r*r2*r2) minv(m+1) = rr5*xr*xr - rr3 minv(m+2) = rr5*xr*yr minv(m+3) = rr5*xr*zr minv(m+4) = rr5*yr*yr - rr3 minv(m+5) = rr5*yr*zr minv(m+6) = rr5*zr*zr - rr3 m = m + 6 end if end do c c reset exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 end do do j = 1, n12(i) wscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) wscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) wscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) wscale(i15(j,i)) = 1.0d0 end do end do c c perform deallocation of some local arrays c deallocate (uscale) deallocate (wscale) end if return end c c c ############################################################### c ## ## c ## subroutine uscale0b -- dipole preconditioner via list ## c ## ## c ############################################################### c c c "uscale0b" builds and applies a preconditioner for the conjugate c gradient induced dipole solver using a neighbor pair list c c subroutine uscale0b (mode,rsd,rsdp,zrsd,zrsdp) use atoms use chgpen use couple use limits use mplpot use mpole use neigh use polar use polgrp use polpcg use polpot implicit none integer i,j,k,m integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 r,r2,rr3,rr5 real*8 polmin real*8 poli,polik real*8 alphai,alphak real*8 m1,m2,m3 real*8 m4,m5,m6 real*8 dmpik(5) real*8, allocatable :: uscale(:) real*8, allocatable :: wscale(:) real*8 rsd(3,*) real*8 rsdp(3,*) real*8 zrsd(3,*) real*8 zrsdp(3,*) real*8, allocatable :: zrsdt(:,:) real*8, allocatable :: zrsdtp(:,:) character*6 mode c c c apply the preconditioning matrix to the current residual c if (mode .eq. 'APPLY') then c c perform dynamic allocation of some local arrays c allocate (zrsdt(3,n)) allocate (zrsdtp(3,n)) c c use diagonal preconditioner elements as first approximation c polmin = 0.00000001d0 do ii = 1, npole i = ipole(ii) poli = uaccel * max(polmin,polarity(i)) do j = 1, 3 zrsd(j,i) = poli * rsd(j,i) zrsdp(j,i) = poli * rsdp(j,i) zrsdt(j,i) = 0.0d0 zrsdtp(j,i) = 0.0d0 end do end do c c use the off-diagonal preconditioner elements in second phase c if (use_ulist) then !$OMP PARALLEL default(private) shared(npole,ipole,mindex, !$OMP& minv,nulst,ulst,rsd,rsdp,zrsd,zrsdp,zrsdt,zrsdtp) !$OMP DO reduction(+:zrsdt,zrsdtp) schedule(guided) do ii = 1, npole i = ipole(ii) m = mindex(i) do kk = 1, nulst(i) k = ulst(kk,i) m1 = minv(m+1) m2 = minv(m+2) m3 = minv(m+3) m4 = minv(m+4) m5 = minv(m+5) m6 = minv(m+6) m = m + 6 zrsdt(1,i) = zrsdt(1,i) + m1*rsd(1,k) & + m2*rsd(2,k) + m3*rsd(3,k) zrsdt(2,i) = zrsdt(2,i) + m2*rsd(1,k) & + m4*rsd(2,k) + m5*rsd(3,k) zrsdt(3,i) = zrsdt(3,i) + m3*rsd(1,k) & + m5*rsd(2,k) + m6*rsd(3,k) zrsdt(1,k) = zrsdt(1,k) + m1*rsd(1,i) & + m2*rsd(2,i) + m3*rsd(3,i) zrsdt(2,k) = zrsdt(2,k) + m2*rsd(1,i) & + m4*rsd(2,i) + m5*rsd(3,i) zrsdt(3,k) = zrsdt(3,k) + m3*rsd(1,i) & + m5*rsd(2,i) + m6*rsd(3,i) zrsdtp(1,i) = zrsdtp(1,i) + m1*rsdp(1,k) & + m2*rsdp(2,k) + m3*rsdp(3,k) zrsdtp(2,i) = zrsdtp(2,i) + m2*rsdp(1,k) & + m4*rsdp(2,k) + m5*rsdp(3,k) zrsdtp(3,i) = zrsdtp(3,i) + m3*rsdp(1,k) & + m5*rsdp(2,k) + m6*rsdp(3,k) zrsdtp(1,k) = zrsdtp(1,k) + m1*rsdp(1,i) & + m2*rsdp(2,i) + m3*rsdp(3,i) zrsdtp(2,k) = zrsdtp(2,k) + m2*rsdp(1,i) & + m4*rsdp(2,i) + m5*rsdp(3,i) zrsdtp(3,k) = zrsdtp(3,k) + m3*rsdp(1,i) & + m5*rsdp(2,i) + m6*rsdp(3,i) end do end do !$OMP END DO c c transfer the results from local to global arrays c !$OMP DO do ii = 1, npole i = ipole(ii) do j = 1, 3 zrsd(j,i) = zrsd(j,i) + zrsdt(j,i) zrsdp(j,i) = zrsdp(j,i) + zrsdtp(j,i) end do end do !$OMP END DO !$OMP END PARALLEL end if c c perform deallocation of some local arrays c deallocate (zrsdt) deallocate (zrsdtp) c c build the off-diagonal elements of preconditioning matrix c else if (mode.eq.'BUILD' .and. use_ulist) then m = 0 do ii = 1, npole i = ipole(ii) mindex(i) = m m = m + 6*nulst(i) end do c c perform dynamic allocation of some local arrays c allocate (uscale(n)) allocate (wscale(n)) c c set array needed to scale connected atom interactions c do i = 1, n uscale(i) = 1.0d0 wscale(i) = 1.0d0 end do c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(npole,ipole,x,y,z,polarity, !$OMP& palpha,u1scale,u2scale,u3scale,u4scale,w2scale,w3scale,w4scale, !$OMP& w5scale,n12,i12,n13,i13,n14,i14,n15,i15,np11,ip11,np12,ip12, !$OMP& np13,ip13,np14,ip14,use_thole,use_chgpen,nulst,ulst,mindex,minv) !$OMP& firstprivate (uscale,wscale) c c determine the off-diagonal elements of the preconditioner c !$OMP DO schedule(guided) do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) poli = polarity(i) if (use_chgpen) alphai = palpha(i) c c set exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do do j = 1, n12(i) wscale(i12(j,i)) = w2scale end do do j = 1, n13(i) wscale(i13(j,i)) = w3scale end do do j = 1, n14(i) wscale(i14(j,i)) = w4scale end do do j = 1, n15(i) wscale(i15(j,i)) = w5scale end do c c evaluate all sites within the cutoff distance c m = mindex(i) do kk = 1, nulst(i) k = ulst(kk,i) xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call image (xr,yr,zr) r2 = xr*xr + yr* yr + zr*zr r = sqrt(r2) if (use_thole) then call dampthole (i,k,5,r,dmpik) dmpik(3) = uscale(k) * dmpik(3) dmpik(5) = uscale(k) * dmpik(5) else if (use_chgpen) then alphak = palpha(k) call dampmut (r,alphai,alphak,dmpik) dmpik(3) = wscale(k) * dmpik(3) dmpik(5) = wscale(k) * dmpik(5) end if polik = poli * polarity(k) rr3 = dmpik(3) * polik / (r*r2) rr5 = 3.0d0 * dmpik(5) * polik / (r*r2*r2) minv(m+1) = rr5*xr*xr - rr3 minv(m+2) = rr5*xr*yr minv(m+3) = rr5*xr*zr minv(m+4) = rr5*yr*yr - rr3 minv(m+5) = rr5*yr*zr minv(m+6) = rr5*zr*zr - rr3 m = m + 6 end do c c reset exclusion coefficients for connected atoms c do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 end do do j = 1, n12(i) wscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) wscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) wscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) wscale(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 (uscale) deallocate (wscale) end if return end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine inertia -- principal moments of inertia ## c ## ## c ############################################################ c c c "inertia" computes the principal moments of inertia for the c system, and optionally translates the center of mass to the c origin and rotates the principal axes onto the global axes c c mode = 1 print the moments and principal axes c mode = 2 move coordinates to standard orientation c mode = 3 perform both of the above operations c c literature reference: c c Herbert Goldstein, "Classical Mechanics, 2nd Edition", c Addison-Wesley, Reading, MA, 1980; see the Euler angle c xyz convention in Appendix B c c subroutine inertia (mode) use atoms use atomid use iounit use math implicit none integer i,j,k,mode real*8 weigh,total,dot real*8 xcm,ycm,zcm real*8 xx,xy,xz,yy,yz,zz real*8 xterm,yterm,zterm real*8 phi,theta,psi real*8 moment(3),vec(3,3) real*8 tensor(3,3),a(3,3) logical print,moved c c c decide upon the type of output desired c print = .false. moved = .false. if (mode.eq.1 .or. mode.eq.3) print = .true. if (mode.eq.2 .or. mode.eq.3) moved = .true. c c compute the position of the center of mass c total = 0.0d0 xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 do i = 1, n weigh = mass(i) total = total + weigh xcm = xcm + x(i)*weigh ycm = ycm + y(i)*weigh zcm = zcm + z(i)*weigh end do xcm = xcm / total ycm = ycm / total zcm = zcm / total c c compute and then diagonalize the inertia tensor c xx = 0.0d0 xy = 0.0d0 xz = 0.0d0 yy = 0.0d0 yz = 0.0d0 zz = 0.0d0 do i = 1, n weigh = mass(i) xterm = x(i) - xcm yterm = y(i) - ycm zterm = z(i) - zcm xx = xx + xterm*xterm*weigh xy = xy + xterm*yterm*weigh xz = xz + xterm*zterm*weigh yy = yy + yterm*yterm*weigh yz = yz + yterm*zterm*weigh zz = zz + zterm*zterm*weigh end do tensor(1,1) = yy + zz tensor(2,1) = -xy tensor(3,1) = -xz tensor(1,2) = -xy tensor(2,2) = xx + zz tensor(3,2) = -yz tensor(1,3) = -xz tensor(2,3) = -yz tensor(3,3) = xx + yy call jacobi (3,tensor,moment,vec) c c select the direction for each principal moment axis c do i = 1, 2 do j = 1, n xterm = vec(1,i) * (x(j)-xcm) yterm = vec(2,i) * (y(j)-ycm) zterm = vec(3,i) * (z(j)-zcm) dot = xterm + yterm + zterm if (dot .lt. 0.0d0) then do k = 1, 3 vec(k,i) = -vec(k,i) end do end if if (dot .ne. 0.0d0) goto 10 end do 10 continue end do c c moment axes must give a right-handed coordinate system c xterm = vec(1,1) * (vec(2,2)*vec(3,3)-vec(2,3)*vec(3,2)) yterm = vec(2,1) * (vec(1,3)*vec(3,2)-vec(1,2)*vec(3,3)) zterm = vec(3,1) * (vec(1,2)*vec(2,3)-vec(1,3)*vec(2,2)) dot = xterm + yterm + zterm if (dot .lt. 0.0d0) then do j = 1, 3 vec(j,3) = -vec(j,3) end do end if c c principal moment axes form rows of Euler rotation matrix c if (moved) then do i = 1, 3 do j = 1, 3 a(i,j) = vec(j,i) end do end do c c translate to origin, then apply Euler rotation matrix c do i = 1, n xterm = x(i) - xcm yterm = y(i) - ycm zterm = z(i) - zcm x(i) = a(1,1)*xterm + a(1,2)*yterm + a(1,3)*zterm y(i) = a(2,1)*xterm + a(2,2)*yterm + a(2,3)*zterm z(i) = a(3,1)*xterm + a(3,2)*yterm + a(3,3)*zterm end do end if c c print the center of mass and Euler angle values c if (print) then write (iout,20) xcm,ycm,zcm 20 format (/,' Center of Mass Coordinates :',7x,3f13.6) call invert (3,vec) call roteuler (vec,phi,theta,psi) phi = radian * phi theta = radian * theta psi = radian * psi write (iout,30) phi,theta,psi 30 format (' Euler Angles (Phi/Theta/Psi) : ',4x,3f13.3) c c print the moments of inertia and the principal axes c write (iout,40) 40 format (/,' Moments of Inertia and Principal Axes :', & //,13x,'Moments (amu Ang^2)', & 12x,'X-, Y- and Z-Components of Axes') write (iout,50) (moment(i),vec(1,i),vec(2,i),vec(3,i),i=1,3) 50 format (3(/,11x,f16.3,9x,3f13.6)) 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 inform -- program I/O and flow control values ## c ## ## c ############################################################## c c c maxask maximum number of queries for interactive input c c gpucard integer flag for GPU use (0=no GPU, 1=GPU present) c digits decimal places output for energy and coordinates c iprint steps between status printing (0=no printing) c iwrite steps between coordinate saves (0=no saves) c isend steps between socket communication (0=no sockets) c verbose logical flag to turn on extra information printing c debug logical flag to turn on extensive debug printing c silent logical flag to turn off all information printing c holdup logical flag to wait for carriage return on exit c abort logical flag to stop execution at next chance c c module inform implicit none integer maxask parameter (maxask=5) integer gpucard,digits integer iprint,iwrite integer isend logical verbose,debug logical silent,holdup logical abort save end c c c ################################################### c ## COPYRIGHT (C) 2012 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine initatom -- setup atoms in periodic table ## c ## ## c ############################################################## c c c "initatom" sets the atomic symbol, standard atomic weight, c van der Waals radius and covalent radius for each element in c the periodic table c c literature references: c c J. Emsley, The Elements, 3rd Edition, Oxford University Press, c (1999) [relative atomic masses] c c J. Meija, T. B. Coplen, M. Berglund, W. A. Brand, P. De Bievre, c M. Groning, N. E. Holden, J. Irrgeher, R. D. Loss, T. Walczyk and c R. Prohaska, Atomic Weights of the Elements 2013, Pure and Applied c Chemistry, 88, 265-291 (2016) [standard atomic weights] c c A. Bondi, van der Waals Volumes and Radii, Journal of Physical c Chemistry, 68, 441-451 (1964) [original vdw radii; not used] c c S. Alvarez, "A Cartography of the van der Waals Territories", c Dalton Transactions, 42, 8617-8636 (2013) [vdw radii for most c elements 1-99] c c B. Cordero, V. Gomez. A. E. Platero-Prats, M. Reves, c J. Echeverria, E. Cremades, F. Barragan and S. Alverez, c "Covalent Radii Revisited", Dalton Transactions, 2832-2838 (2008) c [covalent radii for elements 1-96] c c P. Pyykko and M. Atsumi, "Molecular Single-Bond Covalent Radii c for Elements 1-118", Chemistry- A European Journal, 15, 187-197 c (2009) [covalent radii for elements 97-112] c c subroutine initatom use ptable implicit none integer i real*8 amas(maxele) real*8 vrad(maxele) real*8 crad(maxele) character*3 asym(maxele) c c atomic symbol for each element c data asym / 'H ', 'He ', 'Li ', 'Be ', 'B ', 'C ', 'N ', & 'O ', 'F ', 'Ne ', 'Na ', 'Mg ', 'Al ', 'Si ', & 'P ', 'S ', 'Cl ', 'Ar ', 'K ', 'Ca ', 'Sc ', & 'Ti ', 'V ', 'Cr ', 'Mn ', 'Fe ', 'Co ', 'Ni ', & 'Cu ', 'Zn ', 'Ga ', 'Ge ', 'As ', 'Se ', 'Br ', & 'Kr ', 'Rb ', 'Sr ', 'Y ', 'Zr ', 'Nb ', 'Mo ', & 'Tc ', 'Ru ', 'Rh ', 'Pd ', 'Ag ', 'Cd ', 'In ', & 'Sn ', 'Sb ', 'Te ', 'I ', 'Xe ', 'Cs ', 'Ba ', & 'La ', 'Ce ', 'Pr ', 'Nd ', 'Pm ', 'Sm ', 'Eu ', & 'Gd ', 'Tb ', 'Dy ', 'Ho ', 'Er ', 'Tm ', 'Yb ', & 'Lu ', 'Hf ', 'Ta ', 'W ', 'Re ', 'Os ', 'Ir ', & 'Pt ', 'Au ', 'Hg ', 'Tl ', 'Pb ', 'Bi ', 'Po ', & 'At ', 'Rn ', 'Fr ', 'Ra ', 'Ac ', 'Th ', 'Pa ', & 'U ', 'Np ', 'Pu ', 'Am ', 'Cm ', 'Bk ', 'Cf ', & 'Es ', 'Fm ', 'Md ', 'No ', 'Lr ', 'Rf ', 'Db ', & 'Sg ', 'Bh ', 'Hs ', 'Mt ', 'Ds ', 'Rg ', 'Cn ' / c c standard atomic weight for each element c data amas / 1.008d0, 4.003d0, 6.941d0, 9.012d0, 10.811d0, & 12.011d0, 14.007d0, 15.999d0, 18.998d0, 20.180d0, & 22.990d0, 24.305d0, 26.982d0, 28.086d0, 30.974d0, & 32.066d0, 35.453d0, 39.948d0, 39.098d0, 40.078d0, & 44.956d0, 47.867d0, 50.942d0, 51.996d0, 54.938d0, & 55.845d0, 58.933d0, 58.693d0, 63.546d0, 65.380d0, & 69.723d0, 72.630d0, 74.922d0, 78.971d0, 79.904d0, & 83.798d0, 85.468d0, 87.620d0, 88.906d0, 91.224d0, & 92.906d0, 95.950d0, 98.906d0, 101.070d0, 102.910d0, & 106.420d0, 107.870d0, 112.410d0, 114.820d0, 118.710d0, & 121.760d0, 127.600d0, 126.900d0, 131.290d0, 132.910d0, & 137.330d0, 138.910d0, 140.120d0, 140.910d0, 144.240d0, & 144.913d0, 150.360d0, 151.960d0, 157.250d0, 158.930d0, & 162.500d0, 164.930d0, 167.260d0, 168.930d0, 173.050d0, & 174.970d0, 178.490d0, 180.950d0, 183.840d0, 186.210d0, & 190.230d0, 192.220d0, 195.080d0, 196.970d0, 200.590d0, & 204.383d0, 207.200d0, 208.980d0, 208.982d0, 209.987d0, & 222.017d0, 223.020d0, 226.025d0, 227.027d0, 232.038d0, & 231.036d0, 238.029d0, 237.048d0, 244.064d0, 243.061d0, & 247.070d0, 247.070d0, 251.080d0, 252.083d0, 257.095d0, & 258.098d0, 259.101d0, 262.110d0, 267.122d0, 270.131d0, & 269.129d0, 270.133d0, 270.134d0, 278.156d0, 281.165d0, & 281.166d0, 285.177d0 / c c van der Waals radius for each element (Angstroms) c data vrad / 1.20d0, 1.43d0, 2.12d0, 1.98d0, 1.91d0, 1.77d0, & 1.66d0, 1.50d0, 1.46d0, 1.58d0, 2.50d0, 2.51d0, & 2.25d0, 2.19d0, 1.90d0, 1.89d0, 1.82d0, 1.83d0, & 2.73d0, 2.62d0, 2.58d0, 2.46d0, 2.42d0, 2.45d0, & 2.45d0, 2.44d0, 2.40d0, 2.40d0, 2.38d0, 2.39d0, & 2.32d0, 2.29d0, 1.88d0, 1.82d0, 1.86d0, 2.25d0, & 3.21d0, 2.84d0, 2.75d0, 2.52d0, 2.56d0, 2.45d0, & 2.44d0, 2.46d0, 2.44d0, 2.15d0, 2.53d0, 2.49d0, & 2.43d0, 2.42d0, 2.47d0, 1.99d0, 2.04d0, 2.06d0, & 3.48d0, 3.03d0, 2.98d0, 2.88d0, 2.92d0, 2.95d0, & 2.90d0, 2.90d0, 2.87d0, 2.83d0, 2.79d0, 2.87d0, & 2.81d0, 2.83d0, 2.79d0, 2.80d0, 2.74d0, 2.63d0, & 2.53d0, 2.57d0, 2.49d0, 2.48d0, 2.41d0, 2.29d0, & 2.32d0, 2.45d0, 2.47d0, 2.60d0, 2.54d0, 2.93d0, & 2.88d0, 2.71d0, 2.82d0, 2.81d0, 2.80d0, 2.93d0, & 2.88d0, 2.71d0, 2.82d0, 2.81d0, 2.83d0, 3.05d0, & 3.40d0, 3.05d0, 2.70d0, 0.00d0, 0.00d0, 0.00d0, & 0.00d0, 0.00d0, 0.00d0, 0.00d0, 0.00d0, 0.00d0, & 0.00d0, 0.00d0, 0.00d0, 0.00d0 / c c covalent radius for each element (Angstroms) c data crad / 0.31d0, 0.28d0, 1.28d0, 0.96d0, 0.84d0, 0.76d0, & 0.71d0, 0.66d0, 0.57d0, 0.58d0, 1.66d0, 1.41d0, & 1.21d0, 1.11d0, 1.07d0, 1.05d0, 1.02d0, 1.06d0, & 2.03d0, 1.76d0, 1.70d0, 1.60d0, 1.53d0, 1.39d0, & 1.39d0, 1.32d0, 1.26d0, 1.24d0, 1.32d0, 1.22d0, & 1.22d0, 1.20d0, 1.19d0, 1.20d0, 1.20d0, 1.16d0, & 2.20d0, 1.95d0, 1.90d0, 1.75d0, 1.64d0, 1.54d0, & 1.47d0, 1.46d0, 1.42d0, 1.39d0, 1.45d0, 1.44d0, & 1.42d0, 1.39d0, 1.39d0, 1.38d0, 1.39d0, 1.40d0, & 2.44d0, 2.15d0, 2.07d0, 2.04d0, 2.03d0, 2.01d0, & 1.99d0, 1.98d0, 1.98d0, 1.96d0, 1.94d0, 1.92d0, & 1.92d0, 1.89d0, 1.90d0, 1.87d0, 1.87d0, 1.75d0, & 1.70d0, 1.62d0, 1.51d0, 1.44d0, 1.41d0, 1.36d0, & 1.36d0, 1.32d0, 1.45d0, 1.46d0, 1.48d0, 1.40d0, & 1.50d0, 1.50d0, 2.60d0, 2.21d0, 2.15d0, 2.06d0, & 2.00d0, 1.96d0, 1.90d0, 1.87d0, 1.80d0, 1.69d0, & 1.68d0, 1.68d0, 1.65d0, 1.67d0, 1.73d0, 1.76d0, & 1.61d0, 1.57d0, 1.49d0, 1.43d0, 1.41d0, 1.34d0, & 1.29d0, 1.28d0, 1.21d0, 1.22d0 / c c c set the symbol, weight and radii for each element c do i = 1, maxele atmass(i) = amas(i) elemnt(i) = asym(i) if (vrad(i) .eq. 0.0d0) vrad(i) = 2.0d0 vdwrad(i) = vrad(i) covrad(i) = crad(i) 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 initial -- initial values and program setup ## c ## ## c ################################################################ c c c "initial" sets up original values for some parameters and c variables that might not otherwise get initialized c c note calls below to the "kmp_set" routines are for use with c the Intel compiler, and must be commented for other compilers; c alternatively, these values can be set via the KMP_STACKSIZE c and KMP_BLOCKTIME environment variables c c subroutine initial use align use atoms use bath use bound use boxes use cell use fft use files use group use inform use iounit use keys use linmin use minima use molcul use mutant use neigh use openmp use output use params use pdb use rigid use scales use sequen use socket use virial use warp use zclose implicit none !$ integer omp_get_num_procs logical first save first data first / .true. / c c c default unit numbers for input and output c input = 5 iout = 6 c c display program banner and copyright notice c if (first) call promo c c command line arguments to the program c if (first) call command if (first) first = .false. c c cores, thread count and options for OpenMP c nproc = 1 nthread = 1 !$ nproc = omp_get_num_procs () !$ nthread = nproc !$ call omp_set_num_threads (nthread) !$ call omp_set_nested (.true.) c c Intel compiler extensions to OpenMP standard, 268435456 bytes is c 2**28 bytes, or 256 MB; comment these lines for other compilers c c!$ call kmp_set_stacksize_s (268435456) c!$ call kmp_set_blocktime (0) c c atomic symbols, weights and radii c call initatom c c names of biopolymer residue types c call initres c c number of lines in the keyfile c nkey = 0 c c number of lines in the parameter file c nprm = 0 c c number of atoms in the system c n = 0 c c number of molecules in the system c nmol = 0 c c number of unit cell and replicates c ncell = 1 c c number of atoms used in superposition c nfit = 0 c c number of mutated atoms in the system c nmut = 0 c c number of bonds added or deleted from Z-matrix c nadd = 0 ndel = 0 c c number of atoms in Protein Data Bank format c npdb = 0 c c number of residues and chains in biopolymer sequence c nseq = 0 nchain = 0 c c highest numbered previous cycle file c nprior = 0 c c pointer initialization for FFTW plans c planf = 0 planb = 0 c c information levels within the program c verbose = .false. debug = .false. silent = .false. abort = .false. c c integer flag for use of GPU coprocessor c gpucard = 0 c c flag for use of atom groups c use_group = .false. c c flags for use of periodic boundaries c use_bounds = .false. use_replica = .false. use_polymer = .false. c c flags for rebuilding of neighbor lists c dovlst = .true. dodlst = .true. doclst = .true. domlst = .true. doulst = .true. c c flags for temperature and pressure baths c isothermal = .false. isobaric = .false. c c flag for use of internal virial c use_virial = .true. c c flag for use of rigid bodies c use_rigid = .false. c c flag to show setting of optimization scale factors c set_scale = .false. c c flags for external Java socket communication c sktstart = .false. use_socket = .false. c c flags for potential energy smoothing c use_smooth = .false. use_dem = .false. use_gda = .false. use_tophat = .false. use_stophat = .false. c c format for output of coordinates c archive = .true. binary = .false. coordtype = 'NONE' c c default values for unit cell dimensions c xbox = 0.0d0 ybox = 0.0d0 zbox = 0.0d0 alpha = 0.0d0 beta = 0.0d0 gamma = 0.0d0 c c default values used by optimizations c fctmin = 0.0d0 maxiter = 0 nextiter = 0 iprint = -1 iwrite = -1 stpmax = 0.0d0 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 initneck -- set implicit solvent neck values ## c ## ## c ################################################################# c c c "initneck" sets the atom radius ranges as well as the neck c correction values for interstitial regions between atom pairs, c as used in implicit solvation models c c literature reference: c c R. A. Corrigan, A. C. Thiel, J. R. Lynn, T. L. Cassavant, c P. Ren, J. W. Ponder and M. J. Schnieders, "A Generalized c Kirkwood Implicit Solvent for the Polarizable AMOEBA Protein c Model", Journal of Chemical Physics, 159, 054102 (2023) c c subroutine initneck use solute implicit none integer i,j real*8 radbin(maxneck) real*8 aij(maxneck,maxneck) real*8 bij(maxneck,maxneck) c c c atom radius size bins (Angstroms) c data radbin / 0.80d0, 0.85d0, 0.90d0, 0.95d0, 1.00d0, 1.05d0, & 1.10d0, 1.15d0, 1.20d0, 1.25d0, 1.30d0, 1.35d0, & 1.40d0, 1.45d0, 1.50d0, 1.55d0, 1.60d0, 1.65d0, & 1.70d0, 1.75d0, 1.80d0, 1.85d0, 1.90d0, 1.95d0, & 2.00d0, 2.05d0, 2.10d0, 2.15d0, 2.20d0, 2.25d0, & 2.30d0, 2.35d0, 2.40d0, 2.45d0, 2.50d0, 2.55d0, & 2.60d0, 2.65d0, 2.70d0, 2.75d0, 2.80d0, 2.85d0, & 2.90d0, 2.95d0, 3.00d0 / c c Aij neck correction constants c data aij(1,:) / 0.0000577616d0, 0.0000584661d0, 0.0000363925d0, & 0.0000395472d0, 0.0000443202d0, 0.0000485507d0, & 0.0000430862d0, 0.0000485067d0, 0.0000244504d0, & 0.0000278293d0, 0.0000329908d0, 0.0000292135d0, & 0.0000343621d0, 0.0000393724d0, 0.0000352501d0, & 0.0000303823d0, 0.0000360595d0, 0.0000418690d0, & 0.0000365804d0, 0.0000248824d0, 0.0000375656d0, & 0.0000428918d0, 0.0000377450d0, 0.0000447160d0, & 0.0000395375d0, 0.0000345934d0, 0.0000536114d0, & 0.0000470958d0, 0.0000542111d0, 0.0000360263d0, & 0.0000553398d0, 0.0000483197d0, 0.0000555466d0, & 0.0000374290d0, 0.0000327412d0, 0.0000386635d0, & 0.0000578345d0, 0.0000513194d0, 0.0000581077d0, & 0.0000394022d0, 0.0000599546d0, 0.0000392112d0, & 0.0000597613d0, 0.0000403186d0, 0.0000615149d0 / data aij(2,:) / 0.0000446374d0, 0.0000460309d0, 0.0000475714d0, & 0.0000225974d0, 0.0000318052d0, 0.0000275537d0, & 0.0000296576d0, 0.0000339157d0, 0.0000295595d0, & 0.0000344661d0, 0.0000395587d0, 0.0000197502d0, & 0.0000300923d0, 0.0000272524d0, 0.0000187561d0, & 0.0000272680d0, 0.0000247659d0, 0.0000214933d0, & 0.0000252850d0, 0.0000223386d0, 0.0000261633d0, & 0.0000398363d0, 0.0000363492d0, 0.0000412599d0, & 0.0000363327d0, 0.0000422768d0, 0.0000367723d0, & 0.0000425282d0, 0.0000374607d0, 0.0000325975d0, & 0.0000383563d0, 0.0000253707d0, 0.0000301193d0, & 0.0000200866d0, 0.0000299808d0, 0.0000263514d0, & 0.0000304240d0, 0.0000349497d0, 0.0000408533d0, & 0.0000268003d0, 0.0000407538d0, 0.0000357651d0, & 0.0000418473d0, 0.0000278226d0, 0.0000419066d0 / data aij(3,:) / 0.0000360721d0, 0.0000365794d0, 0.0000372415d0, & 0.0000303637d0, 0.0000319835d0, 0.0000267215d0, & 0.0000171087d0, 0.0000252702d0, 0.0000221094d0, & 0.0000187747d0, 0.0000212341d0, 0.0000251617d0, & 0.0000215761d0, 0.0000191079d0, 0.0000291389d0, & 0.0000199177d0, 0.0000288958d0, 0.0000260343d0, & 0.0000179669d0, 0.0000210581d0, 0.0000178820d0, & 0.0000215615d0, 0.0000243911d0, 0.0000220007d0, & 0.0000249689d0, 0.0000295075d0, 0.0000260062d0, & 0.0000297050d0, 0.0000203093d0, 0.0000305802d0, & 0.0000202272d0, 0.0000308984d0, 0.0000207930d0, & 0.0000316764d0, 0.0000277135d0, 0.0000316983d0, & 0.0000219362d0, 0.0000326865d0, 0.0000286724d0, & 0.0000332929d0, 0.0000220858d0, 0.0000332871d0, & 0.0000294921d0, 0.0000348374d0, 0.0000230989d0 / data aij(4,:) / 0.0000398429d0, 0.0000223074d0, 0.0000298279d0, & 0.0000315221d0, 0.0000187855d0, 0.0000264807d0, & 0.0000169459d0, 0.0000180824d0, 0.0000162496d0, & 0.0000233148d0, 0.0000157394d0, 0.0000174931d0, & 0.0000152866d0, 0.0000230620d0, 0.0000205539d0, & 0.0000234872d0, 0.0000213273d0, 0.0000181123d0, & 0.0000210938d0, 0.0000186307d0, 0.0000216437d0, & 0.0000146084d0, 0.0000222850d0, 0.0000149429d0, & 0.0000170964d0, 0.0000153536d0, 0.0000177037d0, & 0.0000208958d0, 0.0000237412d0, 0.0000164214d0, & 0.0000239561d0, 0.0000166849d0, 0.0000188702d0, & 0.0000167221d0, 0.0000188448d0, 0.0000172644d0, & 0.0000194706d0, 0.0000174585d0, 0.0000259642d0, & 0.0000177409d0, 0.0000199219d0, 0.0000235990d0, & 0.0000202504d0, 0.0000234495d0, 0.0000156052d0 / data aij(5,:) / 0.0000435754d0, 0.0000245527d0, 0.0000318302d0, & 0.0000188461d0, 0.0000192238d0, 0.0000208396d0, & 0.0000169209d0, 0.0000183816d0, 0.0000204363d0, & 0.0000131412d0, 0.0000193141d0, 0.0000097655d0, & 0.0000110841d0, 0.0000129627d0, 0.0000112003d0, & 0.0000130467d0, 0.0000113669d0, 0.0000168195d0, & 0.0000117549d0, 0.0000134876d0, 0.0000118881d0, & 0.0000180528d0, 0.0000159126d0, 0.0000181928d0, & 0.0000125940d0, 0.0000183351d0, 0.0000125678d0, & 0.0000145035d0, 0.0000131847d0, 0.0000144906d0, & 0.0000129840d0, 0.0000150912d0, 0.0000176485d0, & 0.0000153063d0, 0.0000178114d0, 0.0000157934d0, & 0.0000180763d0, 0.0000157725d0, 0.0000186835d0, & 0.0000121847d0, 0.0000185069d0, 0.0000161900d0, & 0.0000191223d0, 0.0000126643d0, 0.0000192108d0 / data aij(6,:) / 0.0000505580d0, 0.0000264633d0, 0.0000205166d0, & 0.0000195164d0, 0.0000204987d0, 0.0000160556d0, & 0.0000127648d0, 0.0000137952d0, 0.0000155458d0, & 0.0000176400d0, 0.0000146241d0, 0.0000124027d0, & 0.0000103247d0, 0.0000120745d0, 0.0000105222d0, & 0.0000124882d0, 0.0000140152d0, 0.0000095449d0, & 0.0000141168d0, 0.0000074383d0, 0.0000142994d0, & 0.0000098671d0, 0.0000112045d0, 0.0000132832d0, & 0.0000113876d0, 0.0000135139d0, 0.0000116918d0, & 0.0000137152d0, 0.0000118068d0, 0.0000140495d0, & 0.0000093075d0, 0.0000144645d0, 0.0000126001d0, & 0.0000142255d0, 0.0000128571d0, 0.0000148412d0, & 0.0000128819d0, 0.0000152166d0, 0.0000099735d0, & 0.0000151882d0, 0.0000133944d0, 0.0000154829d0, & 0.0000135105d0, 0.0000154771d0, 0.0000106154d0 / data aij(7,:) / 0.0000449657d0, 0.0000230612d0, 0.0000221541d0, & 0.0000166532d0, 0.0000171555d0, 0.0000227174d0, & 0.0000182899d0, 0.0000193198d0, 0.0000118768d0, & 0.0000130396d0, 0.0000113361d0, 0.0000093799d0, & 0.0000108573d0, 0.0000120843d0, 0.0000106342d0, & 0.0000117938d0, 0.0000080569d0, 0.0000091361d0, & 0.0000107718d0, 0.0000123647d0, 0.0000106453d0, & 0.0000123678d0, 0.0000109954d0, 0.0000126151d0, & 0.0000145692d0, 0.0000128038d0, 0.0000146248d0, & 0.0000099091d0, 0.0000114200d0, 0.0000059787d0, & 0.0000117991d0, 0.0000136370d0, 0.0000119830d0, & 0.0000080880d0, 0.0000120147d0, 0.0000108970d0, & 0.0000161522d0, 0.0000083711d0, 0.0000094980d0, & 0.0000112647d0, 0.0000096319d0, 0.0000113677d0, & 0.0000127823d0, 0.0000114549d0, 0.0000100471d0 / data aij(8,:) / 0.0000280510d0, 0.0000266023d0, 0.0000144227d0, & 0.0000188499d0, 0.0000184712d0, 0.0000146008d0, & 0.0000195724d0, 0.0000161268d0, 0.0000073492d0, & 0.0000137704d0, 0.0000111866d0, 0.0000072795d0, & 0.0000081037d0, 0.0000092319d0, 0.0000078144d0, & 0.0000089354d0, 0.0000102556d0, 0.0000090005d0, & 0.0000059425d0, 0.0000090194d0, 0.0000080186d0, & 0.0000069127d0, 0.0000082105d0, 0.0000093797d0, & 0.0000082401d0, 0.0000093675d0, 0.0000082671d0, & 0.0000071727d0, 0.0000064889d0, 0.0000097376d0, & 0.0000087729d0, 0.0000098019d0, 0.0000088064d0, & 0.0000059057d0, 0.0000089896d0, 0.0000077635d0, & 0.0000070336d0, 0.0000047870d0, 0.0000094273d0, & 0.0000080466d0, 0.0000093429d0, 0.0000083051d0, & 0.0000096725d0, 0.0000109657d0, 0.0000097148d0 / data aij(9,:) / 0.0000325317d0, 0.0000295175d0, 0.0000213868d0, & 0.0000208878d0, 0.0000153087d0, 0.0000116695d0, & 0.0000091353d0, 0.0000128753d0, 0.0000102693d0, & 0.0000107086d0, 0.0000088500d0, 0.0000098955d0, & 0.0000081413d0, 0.0000052255d0, 0.0000078083d0, & 0.0000067997d0, 0.0000098737d0, 0.0000066979d0, & 0.0000098507d0, 0.0000051252d0, 0.0000074307d0, & 0.0000067922d0, 0.0000057491d0, 0.0000068223d0, & 0.0000058920d0, 0.0000070420d0, 0.0000060742d0, & 0.0000069635d0, 0.0000062687d0, 0.0000054473d0, & 0.0000061911d0, 0.0000073394d0, 0.0000037836d0, & 0.0000074661d0, 0.0000084983d0, 0.0000073838d0, & 0.0000087027d0, 0.0000076952d0, 0.0000088636d0, & 0.0000102208d0, 0.0000090108d0, 0.0000104452d0, & 0.0000090944d0, 0.0000104765d0, 0.0000070232d0 / data aij(10,:) / 0.0000289111d0, 0.0000198943d0, 0.0000241993d0, & 0.0000238536d0, 0.0000182705d0, 0.0000129878d0, & 0.0000076255d0, 0.0000102719d0, 0.0000112418d0, & 0.0000067659d0, 0.0000071756d0, 0.0000100155d0, & 0.0000065300d0, 0.0000071811d0, 0.0000060818d0, & 0.0000066768d0, 0.0000059369d0, 0.0000065993d0, & 0.0000076971d0, 0.0000063984d0, 0.0000057069d0, & 0.0000086185d0, 0.0000076581d0, 0.0000051018d0, & 0.0000057661d0, 0.0000051292d0, 0.0000058121d0, & 0.0000050955d0, 0.0000079236d0, 0.0000069082d0, & 0.0000060582d0, 0.0000041682d0, 0.0000080245d0, & 0.0000042302d0, 0.0000082046d0, 0.0000056029d0, & 0.0000048280d0, 0.0000057624d0, 0.0000065014d0, & 0.0000058246d0, 0.0000049969d0, 0.0000058491d0, & 0.0000066001d0, 0.0000059999d0, 0.0000088507d0 / data aij(11,:) / 0.0000265006d0, 0.0000302279d0, 0.0000215102d0, & 0.0000203741d0, 0.0000195197d0, 0.0000114271d0, & 0.0000110442d0, 0.0000113577d0, 0.0000067378d0, & 0.0000072687d0, 0.0000074058d0, 0.0000047733d0, & 0.0000067184d0, 0.0000076291d0, 0.0000062951d0, & 0.0000051957d0, 0.0000044871d0, 0.0000050768d0, & 0.0000044211d0, 0.0000049880d0, 0.0000043518d0, & 0.0000048796d0, 0.0000057445d0, 0.0000049576d0, & 0.0000057224d0, 0.0000037798d0, 0.0000043883d0, & 0.0000066161d0, 0.0000044279d0, 0.0000050580d0, & 0.0000045758d0, 0.0000051723d0, 0.0000046936d0, & 0.0000052703d0, 0.0000047182d0, 0.0000041352d0, & 0.0000063088d0, 0.0000041672d0, 0.0000063473d0, & 0.0000055519d0, 0.0000049210d0, 0.0000033576d0, & 0.0000049766d0, 0.0000033829d0, 0.0000051220d0 / data aij(12,:) / 0.0000393068d0, 0.0000205177d0, 0.0000254533d0, & 0.0000229604d0, 0.0000129838d0, 0.0000126427d0, & 0.0000096583d0, 0.0000123670d0, 0.0000100764d0, & 0.0000100625d0, 0.0000047514d0, 0.0000049466d0, & 0.0000041283d0, 0.0000059449d0, 0.0000065208d0, & 0.0000072136d0, 0.0000045347d0, 0.0000039272d0, & 0.0000033654d0, 0.0000038633d0, 0.0000032913d0, & 0.0000038211d0, 0.0000041976d0, 0.0000037860d0, & 0.0000042838d0, 0.0000037697d0, 0.0000043641d0, & 0.0000038556d0, 0.0000033089d0, 0.0000039242d0, & 0.0000043859d0, 0.0000051678d0, 0.0000034265d0, & 0.0000040012d0, 0.0000035224d0, 0.0000053110d0, & 0.0000046531d0, 0.0000053869d0, 0.0000036188d0, & 0.0000054308d0, 0.0000048054d0, 0.0000055242d0, & 0.0000048512d0, 0.0000056159d0, 0.0000037853d0 / data aij(13,:) / 0.0000340677d0, 0.0000307596d0, 0.0000223668d0, & 0.0000152946d0, 0.0000146712d0, 0.0000106255d0, & 0.0000106032d0, 0.0000081832d0, 0.0000086244d0, & 0.0000049411d0, 0.0000067545d0, 0.0000040421d0, & 0.0000044178d0, 0.0000036241d0, 0.0000052208d0, & 0.0000032905d0, 0.0000048780d0, 0.0000053199d0, & 0.0000046459d0, 0.0000039440d0, 0.0000026124d0, & 0.0000050097d0, 0.0000026014d0, 0.0000029505d0, & 0.0000032710d0, 0.0000037980d0, 0.0000043410d0, & 0.0000037740d0, 0.0000033662d0, 0.0000050175d0, & 0.0000033958d0, 0.0000051015d0, 0.0000034086d0, & 0.0000030335d0, 0.0000034235d0, 0.0000039828d0, & 0.0000045344d0, 0.0000031386d0, 0.0000046458d0, & 0.0000041624d0, 0.0000036086d0, 0.0000041947d0, & 0.0000028209d0, 0.0000033460d0, 0.0000028613d0 / data aij(14,:) / 0.0000305973d0, 0.0000272968d0, 0.0000142276d0, & 0.0000179127d0, 0.0000097246d0, 0.0000127507d0, & 0.0000070473d0, 0.0000090593d0, 0.0000092161d0, & 0.0000074076d0, 0.0000074685d0, 0.0000058617d0, & 0.0000047016d0, 0.0000051588d0, 0.0000056952d0, & 0.0000035730d0, 0.0000038387d0, 0.0000042402d0, & 0.0000035579d0, 0.0000018248d0, 0.0000046133d0, & 0.0000039370d0, 0.0000045159d0, 0.0000029244d0, & 0.0000019710d0, 0.0000022822d0, 0.0000025439d0, & 0.0000028944d0, 0.0000025756d0, 0.0000029250d0, & 0.0000034260d0, 0.0000050361d0, 0.0000034605d0, & 0.0000038688d0, 0.0000026949d0, 0.0000014049d0, & 0.0000027321d0, 0.0000023567d0, 0.0000027913d0, & 0.0000031218d0, 0.0000027763d0, 0.0000031969d0, & 0.0000037163d0, 0.0000032316d0, 0.0000037723d0 / data aij(15,:) / 0.0000363524d0, 0.0000185238d0, 0.0000223944d0, & 0.0000156641d0, 0.0000146928d0, 0.0000107770d0, & 0.0000105276d0, 0.0000102180d0, 0.0000079337d0, & 0.0000078580d0, 0.0000062276d0, 0.0000066384d0, & 0.0000039738d0, 0.0000055727d0, 0.0000060414d0, & 0.0000037461d0, 0.0000023444d0, 0.0000033734d0, & 0.0000028739d0, 0.0000032262d0, 0.0000026725d0, & 0.0000030603d0, 0.0000025932d0, 0.0000030096d0, & 0.0000019791d0, 0.0000029386d0, 0.0000033334d0, & 0.0000029324d0, 0.0000025033d0, 0.0000017645d0, & 0.0000014959d0, 0.0000022899d0, 0.0000025847d0, & 0.0000030273d0, 0.0000026349d0, 0.0000039712d0, & 0.0000026279d0, 0.0000040671d0, 0.0000020776d0, & 0.0000023832d0, 0.0000020939d0, 0.0000024085d0, & 0.0000021149d0, 0.0000041807d0, 0.0000016785d0 / data aij(16,:) / 0.0000531068d0, 0.0000206882d0, 0.0000259899d0, & 0.0000178808d0, 0.0000168038d0, 0.0000128055d0, & 0.0000119227d0, 0.0000069103d0, 0.0000090425d0, & 0.0000068286d0, 0.0000069793d0, 0.0000031585d0, & 0.0000042989d0, 0.0000027028d0, 0.0000036738d0, & 0.0000031193d0, 0.0000043434d0, 0.0000035227d0, & 0.0000030391d0, 0.0000024934d0, 0.0000027944d0, & 0.0000024067d0, 0.0000027907d0, 0.0000023644d0, & 0.0000026945d0, 0.0000022659d0, 0.0000020013d0, & 0.0000029627d0, 0.0000026172d0, 0.0000017442d0, & 0.0000025980d0, 0.0000017461d0, 0.0000020037d0, & 0.0000017818d0, 0.0000026313d0, 0.0000023219d0, & 0.0000026522d0, 0.0000023901d0, 0.0000026985d0, & 0.0000014157d0, 0.0000027079d0, 0.0000018522d0, & 0.0000016312d0, 0.0000019179d0, 0.0000016703d0 / data aij(17,:) / 0.0000471466d0, 0.0000321678d0, 0.0000221166d0, & 0.0000210526d0, 0.0000114910d0, 0.0000108287d0, & 0.0000080777d0, 0.0000104203d0, 0.0000101134d0, & 0.0000058443d0, 0.0000045067d0, 0.0000045975d0, & 0.0000027454d0, 0.0000037782d0, 0.0000039918d0, & 0.0000043093d0, 0.0000046405d0, 0.0000029403d0, & 0.0000023896d0, 0.0000020792d0, 0.0000029414d0, & 0.0000014845d0, 0.0000016390d0, 0.0000018155d0, & 0.0000020600d0, 0.0000018173d0, 0.0000020305d0, & 0.0000018045d0, 0.0000020275d0, 0.0000023056d0, & 0.0000026380d0, 0.0000022906d0, 0.0000015633d0, & 0.0000022861d0, 0.0000015702d0, 0.0000022925d0, & 0.0000015926d0, 0.0000017741d0, 0.0000015991d0, & 0.0000017969d0, 0.0000021445d0, 0.0000018491d0, & 0.0000021663d0, 0.0000018937d0, 0.0000021829d0 / data aij(18,:) / 0.0000415033d0, 0.0000375035d0, 0.0000257317d0, & 0.0000181483d0, 0.0000170401d0, 0.0000165719d0, & 0.0000091912d0, 0.0000089667d0, 0.0000066295d0, & 0.0000051660d0, 0.0000051868d0, 0.0000051552d0, & 0.0000041581d0, 0.0000041949d0, 0.0000044142d0, & 0.0000035882d0, 0.0000029449d0, 0.0000031798d0, & 0.0000020273d0, 0.0000021690d0, 0.0000024377d0, & 0.0000026775d0, 0.0000029680d0, 0.0000014909d0, & 0.0000021480d0, 0.0000018690d0, 0.0000027312d0, & 0.0000014150d0, 0.0000020266d0, 0.0000013942d0, & 0.0000015678d0, 0.0000014176d0, 0.0000015601d0, & 0.0000018280d0, 0.0000020424d0, 0.0000023951d0, & 0.0000015782d0, 0.0000024117d0, 0.0000016197d0, & 0.0000014155d0, 0.0000012558d0, 0.0000018686d0, & 0.0000016359d0, 0.0000018949d0, 0.0000010017d0 / data aij(19,:) / 0.0000468296d0, 0.0000330068d0, 0.0000237247d0, & 0.0000165336d0, 0.0000150520d0, 0.0000109676d0, & 0.0000103584d0, 0.0000059806d0, 0.0000075019d0, & 0.0000075639d0, 0.0000075577d0, 0.0000044171d0, & 0.0000035406d0, 0.0000027896d0, 0.0000038483d0, & 0.0000030165d0, 0.0000024502d0, 0.0000020229d0, & 0.0000037725d0, 0.0000023248d0, 0.0000025725d0, & 0.0000016526d0, 0.0000018416d0, 0.0000020307d0, & 0.0000023292d0, 0.0000019462d0, 0.0000022344d0, & 0.0000014452d0, 0.0000016743d0, 0.0000024751d0, & 0.0000021503d0, 0.0000010914d0, 0.0000016308d0, & 0.0000018570d0, 0.0000021221d0, 0.0000010982d0, & 0.0000016425d0, 0.0000011133d0, 0.0000021459d0, & 0.0000018960d0, 0.0000021557d0, 0.0000011360d0, & 0.0000012755d0, 0.0000011503d0, 0.0000012923d0 / data aij(20,:) / 0.0000326803d0, 0.0000295857d0, 0.0000154475d0, & 0.0000195504d0, 0.0000133752d0, 0.0000130826d0, & 0.0000093108d0, 0.0000090846d0, 0.0000051384d0, & 0.0000065258d0, 0.0000049655d0, 0.0000050318d0, & 0.0000039301d0, 0.0000031064d0, 0.0000018937d0, & 0.0000033983d0, 0.0000027192d0, 0.0000021941d0, & 0.0000023262d0, 0.0000011684d0, 0.0000015864d0, & 0.0000017653d0, 0.0000019394d0, 0.0000021477d0, & 0.0000018003d0, 0.0000015654d0, 0.0000017271d0, & 0.0000019541d0, 0.0000012911d0, 0.0000008739d0, & 0.0000016831d0, 0.0000011063d0, 0.0000016687d0, & 0.0000014377d0, 0.0000016576d0, 0.0000010945d0, & 0.0000012820d0, 0.0000010911d0, 0.0000007782d0, & 0.0000014342d0, 0.0000013165d0, 0.0000018913d0, & 0.0000013170d0, 0.0000008899d0, 0.0000013269d0 / data aij(21,:) / 0.0000381583d0, 0.0000264565d0, 0.0000136612d0, & 0.0000212466d0, 0.0000153348d0, 0.0000145316d0, & 0.0000138739d0, 0.0000060648d0, 0.0000076347d0, & 0.0000074893d0, 0.0000043282d0, 0.0000057183d0, & 0.0000033840d0, 0.0000045556d0, 0.0000035441d0, & 0.0000028461d0, 0.0000022853d0, 0.0000031916d0, & 0.0000026005d0, 0.0000021084d0, 0.0000013651d0, & 0.0000024956d0, 0.0000016110d0, 0.0000017750d0, & 0.0000014880d0, 0.0000016813d0, 0.0000010862d0, & 0.0000016184d0, 0.0000013616d0, 0.0000015542d0, & 0.0000017206d0, 0.0000015449d0, 0.0000013086d0, & 0.0000015137d0, 0.0000012941d0, 0.0000011585d0, & 0.0000012793d0, 0.0000008977d0, 0.0000009980d0, & 0.0000011586d0, 0.0000010254d0, 0.0000011655d0, & 0.0000010218d0, 0.0000011671d0, 0.0000010320d0 / data aij(22,:) / 0.0000435206d0, 0.0000394602d0, 0.0000280329d0, & 0.0000143528d0, 0.0000103966d0, 0.0000099195d0, & 0.0000123591d0, 0.0000070629d0, 0.0000087274d0, & 0.0000066090d0, 0.0000048718d0, 0.0000038172d0, & 0.0000050202d0, 0.0000029810d0, 0.0000040378d0, & 0.0000024193d0, 0.0000024874d0, 0.0000015771d0, & 0.0000016403d0, 0.0000017939d0, 0.0000019398d0, & 0.0000012193d0, 0.0000017244d0, 0.0000008475d0, & 0.0000009524d0, 0.0000008041d0, 0.0000011807d0, & 0.0000009651d0, 0.0000011501d0, 0.0000012202d0, & 0.0000010892d0, 0.0000011977d0, 0.0000010599d0, & 0.0000015547d0, 0.0000010348d0, 0.0000011765d0, & 0.0000010241d0, 0.0000009188d0, 0.0000007943d0, & 0.0000009237d0, 0.0000010314d0, 0.0000009055d0, & 0.0000010352d0, 0.0000009196d0, 0.0000013384d0 / data aij(23,:) / 0.0000379248d0, 0.0000353934d0, 0.0000241508d0, & 0.0000168891d0, 0.0000210529d0, 0.0000086678d0, & 0.0000083510d0, 0.0000106765d0, 0.0000058348d0, & 0.0000057662d0, 0.0000074621d0, 0.0000043406d0, & 0.0000033715d0, 0.0000044195d0, 0.0000020552d0, & 0.0000027516d0, 0.0000016638d0, 0.0000022213d0, & 0.0000023581d0, 0.0000019527d0, 0.0000016003d0, & 0.0000017368d0, 0.0000008516d0, 0.0000009200d0, & 0.0000016828d0, 0.0000008623d0, 0.0000009286d0, & 0.0000006197d0, 0.0000011498d0, 0.0000007848d0, & 0.0000006628d0, 0.0000009788d0, 0.0000010822d0, & 0.0000012385d0, 0.0000008152d0, 0.0000009435d0, & 0.0000010686d0, 0.0000012014d0, 0.0000006276d0, & 0.0000007030d0, 0.0000010605d0, 0.0000012119d0, & 0.0000006389d0, 0.0000007195d0, 0.0000006456d0 / data aij(24,:) / 0.0000457913d0, 0.0000308903d0, 0.0000282516d0, & 0.0000197423d0, 0.0000139036d0, 0.0000076554d0, & 0.0000101164d0, 0.0000092286d0, 0.0000068324d0, & 0.0000052054d0, 0.0000050091d0, 0.0000049163d0, & 0.0000039143d0, 0.0000029462d0, 0.0000039499d0, & 0.0000031099d0, 0.0000024405d0, 0.0000014864d0, & 0.0000012048d0, 0.0000021759d0, 0.0000013931d0, & 0.0000014556d0, 0.0000009208d0, 0.0000017108d0, & 0.0000011004d0, 0.0000011923d0, 0.0000007721d0, & 0.0000006708d0, 0.0000005731d0, 0.0000008092d0, & 0.0000009072d0, 0.0000007914d0, 0.0000008763d0, & 0.0000007716d0, 0.0000006536d0, 0.0000007653d0, & 0.0000008561d0, 0.0000009956d0, 0.0000008472d0, & 0.0000007539d0, 0.0000008319d0, 0.0000005765d0, & 0.0000008451d0, 0.0000009713d0, 0.0000008480d0 / data aij(25,:) / 0.0000514751d0, 0.0000274557d0, 0.0000241481d0, & 0.0000174373d0, 0.0000161298d0, 0.0000116871d0, & 0.0000084217d0, 0.0000081004d0, 0.0000058484d0, & 0.0000056938d0, 0.0000057532d0, 0.0000043019d0, & 0.0000032347d0, 0.0000025748d0, 0.0000034234d0, & 0.0000026896d0, 0.0000016029d0, 0.0000016452d0, & 0.0000023736d0, 0.0000013932d0, 0.0000011273d0, & 0.0000009500d0, 0.0000013052d0, 0.0000010750d0, & 0.0000012044d0, 0.0000010077d0, 0.0000011046d0, & 0.0000007011d0, 0.0000010268d0, 0.0000008714d0, & 0.0000012822d0, 0.0000010702d0, 0.0000007283d0, & 0.0000010366d0, 0.0000005479d0, 0.0000007812d0, & 0.0000005332d0, 0.0000007670d0, 0.0000006899d0, & 0.0000007700d0, 0.0000006826d0, 0.0000007637d0, & 0.0000008807d0, 0.0000004626d0, 0.0000006769d0 / data aij(26,:) / 0.0000347279d0, 0.0000326038d0, 0.0000222389d0, & 0.0000203032d0, 0.0000186389d0, 0.0000135396d0, & 0.0000074878d0, 0.0000093982d0, 0.0000069447d0, & 0.0000051305d0, 0.0000038953d0, 0.0000049720d0, & 0.0000038543d0, 0.0000038303d0, 0.0000017387d0, & 0.0000013908d0, 0.0000018492d0, 0.0000018676d0, & 0.0000011554d0, 0.0000016034d0, 0.0000009913d0, & 0.0000010369d0, 0.0000011030d0, 0.0000015670d0, & 0.0000013066d0, 0.0000011031d0, 0.0000009195d0, & 0.0000007778d0, 0.0000010981d0, 0.0000009562d0, & 0.0000010346d0, 0.0000011776d0, 0.0000007583d0, & 0.0000005111d0, 0.0000005726d0, 0.0000011004d0, & 0.0000009317d0, 0.0000004887d0, 0.0000005500d0, & 0.0000008051d0, 0.0000005530d0, 0.0000004756d0, & 0.0000005513d0, 0.0000006031d0, 0.0000005515d0 / data aij(27,:) / 0.0000404627d0, 0.0000279374d0, 0.0000254737d0, & 0.0000173416d0, 0.0000166276d0, 0.0000090743d0, & 0.0000084501d0, 0.0000108659d0, 0.0000080225d0, & 0.0000045088d0, 0.0000044169d0, 0.0000057245d0, & 0.0000033186d0, 0.0000043660d0, 0.0000034171d0, & 0.0000015607d0, 0.0000020522d0, 0.0000012726d0, & 0.0000016999d0, 0.0000013417d0, 0.0000018688d0, & 0.0000015245d0, 0.0000009452d0, 0.0000007794d0, & 0.0000008405d0, 0.0000011825d0, 0.0000007598d0, & 0.0000008210d0, 0.0000007108d0, 0.0000007647d0, & 0.0000006612d0, 0.0000007339d0, 0.0000008145d0, & 0.0000007040d0, 0.0000006095d0, 0.0000008740d0, & 0.0000003513d0, 0.0000006717d0, 0.0000005660d0, & 0.0000004997d0, 0.0000009522d0, 0.0000005060d0, & 0.0000005619d0, 0.0000005063d0, 0.0000004323d0 / data aij(28,:) / 0.0000472063d0, 0.0000323179d0, 0.0000294752d0, & 0.0000207416d0, 0.0000113045d0, 0.0000136112d0, & 0.0000129076d0, 0.0000071735d0, 0.0000091135d0, & 0.0000052733d0, 0.0000039191d0, 0.0000038507d0, & 0.0000022739d0, 0.0000029313d0, 0.0000017476d0, & 0.0000029817d0, 0.0000017682d0, 0.0000014044d0, & 0.0000018903d0, 0.0000011418d0, 0.0000015945d0, & 0.0000009870d0, 0.0000010526d0, 0.0000011160d0, & 0.0000011997d0, 0.0000013110d0, 0.0000010830d0, & 0.0000006980d0, 0.0000009891d0, 0.0000006386d0, & 0.0000005495d0, 0.0000006040d0, 0.0000006782d0, & 0.0000004347d0, 0.0000004971d0, 0.0000004232d0, & 0.0000004838d0, 0.0000006935d0, 0.0000003617d0, & 0.0000004015d0, 0.0000003611d0, 0.0000003155d0, & 0.0000005902d0, 0.0000003968d0, 0.0000004545d0 / data aij(29,:) / 0.0000534708d0, 0.0000373744d0, 0.0000196796d0, & 0.0000137544d0, 0.0000129458d0, 0.0000119235d0, & 0.0000088305d0, 0.0000111632d0, 0.0000062367d0, & 0.0000059625d0, 0.0000034417d0, 0.0000044561d0, & 0.0000033301d0, 0.0000025232d0, 0.0000019586d0, & 0.0000027071d0, 0.0000015804d0, 0.0000012263d0, & 0.0000016555d0, 0.0000017219d0, 0.0000010458d0, & 0.0000008561d0, 0.0000006975d0, 0.0000009600d0, & 0.0000013346d0, 0.0000008501d0, 0.0000004210d0, & 0.0000005776d0, 0.0000008267d0, 0.0000009169d0, & 0.0000004551d0, 0.0000005061d0, 0.0000007113d0, & 0.0000006128d0, 0.0000006790d0, 0.0000004531d0, & 0.0000005155d0, 0.0000005740d0, 0.0000006449d0, & 0.0000002634d0, 0.0000004837d0, 0.0000005547d0, & 0.0000004790d0, 0.0000004165d0, 0.0000004781d0 / data aij(30,:) / 0.0000471509d0, 0.0000331027d0, 0.0000226179d0, & 0.0000161311d0, 0.0000144893d0, 0.0000107687d0, & 0.0000104009d0, 0.0000128476d0, 0.0000071831d0, & 0.0000053734d0, 0.0000030440d0, 0.0000051224d0, & 0.0000039650d0, 0.0000022452d0, 0.0000017674d0, & 0.0000017430d0, 0.0000017813d0, 0.0000014173d0, & 0.0000018887d0, 0.0000008757d0, 0.0000012001d0, & 0.0000016279d0, 0.0000012946d0, 0.0000004971d0, & 0.0000008642d0, 0.0000005591d0, 0.0000006041d0, & 0.0000006461d0, 0.0000005270d0, 0.0000007557d0, & 0.0000004882d0, 0.0000007062d0, 0.0000005940d0, & 0.0000008734d0, 0.0000005615d0, 0.0000004848d0, & 0.0000004202d0, 0.0000004705d0, 0.0000004021d0, & 0.0000004565d0, 0.0000003960d0, 0.0000004488d0, & 0.0000004998d0, 0.0000005792d0, 0.0000003821d0 / data aij(31,:) / 0.0000408712d0, 0.0000290825d0, 0.0000201809d0, & 0.0000184693d0, 0.0000127543d0, 0.0000122856d0, & 0.0000089579d0, 0.0000087349d0, 0.0000048255d0, & 0.0000062188d0, 0.0000059289d0, 0.0000044984d0, & 0.0000019907d0, 0.0000033642d0, 0.0000034197d0, & 0.0000026227d0, 0.0000012039d0, 0.0000015836d0, & 0.0000009945d0, 0.0000013051d0, 0.0000017849d0, & 0.0000010646d0, 0.0000005240d0, 0.0000007062d0, & 0.0000005767d0, 0.0000006087d0, 0.0000008726d0, & 0.0000005467d0, 0.0000007758d0, 0.0000006348d0, & 0.0000007039d0, 0.0000003514d0, 0.0000006567d0, & 0.0000002671d0, 0.0000006217d0, 0.0000006907d0, & 0.0000005847d0, 0.0000001470d0, 0.0000004367d0, & 0.0000003746d0, 0.0000003283d0, 0.0000003639d0, & 0.0000004146d0, 0.0000003630d0, 0.0000004069d0 / data aij(32,:) / 0.0000365867d0, 0.0000334092d0, 0.0000233935d0, & 0.0000211266d0, 0.0000148841d0, 0.0000145388d0, & 0.0000102065d0, 0.0000099718d0, 0.0000095120d0, & 0.0000041586d0, 0.0000052071d0, 0.0000030423d0, & 0.0000030232d0, 0.0000022968d0, 0.0000023000d0, & 0.0000030274d0, 0.0000022943d0, 0.0000010722d0, & 0.0000011058d0, 0.0000014789d0, 0.0000009014d0, & 0.0000009248d0, 0.0000009830d0, 0.0000010354d0, & 0.0000014149d0, 0.0000011942d0, 0.0000005606d0, & 0.0000006027d0, 0.0000005065d0, 0.0000004217d0, & 0.0000005883d0, 0.0000005132d0, 0.0000003302d0, & 0.0000004589d0, 0.0000006648d0, 0.0000003397d0, & 0.0000004773d0, 0.0000003190d0, 0.0000004559d0, & 0.0000003103d0, 0.0000005849d0, 0.0000003016d0, & 0.0000005635d0, 0.0000003806d0, 0.0000002617d0 / data aij(33,:) / 0.0000424740d0, 0.0000299616d0, 0.0000274655d0, & 0.0000188374d0, 0.0000175698d0, 0.0000126091d0, & 0.0000089948d0, 0.0000068101d0, 0.0000083814d0, & 0.0000048968d0, 0.0000060247d0, 0.0000059532d0, & 0.0000020417d0, 0.0000044737d0, 0.0000025919d0, & 0.0000020128d0, 0.0000020369d0, 0.0000012489d0, & 0.0000016173d0, 0.0000012975d0, 0.0000013224d0, & 0.0000010382d0, 0.0000008390d0, 0.0000008790d0, & 0.0000009452d0, 0.0000009921d0, 0.0000006307d0, & 0.0000006689d0, 0.0000003338d0, 0.0000007868d0, & 0.0000005076d0, 0.0000004219d0, 0.0000003654d0, & 0.0000008632d0, 0.0000004278d0, 0.0000003612d0, & 0.0000002445d0, 0.0000005864d0, 0.0000002315d0, & 0.0000004357d0, 0.0000002247d0, 0.0000004156d0, & 0.0000002193d0, 0.0000003178d0, 0.0000002730d0 / data aij(34,:) / 0.0000503599d0, 0.0000451538d0, 0.0000316354d0, & 0.0000217532d0, 0.0000202497d0, 0.0000144337d0, & 0.0000104958d0, 0.0000100705d0, 0.0000074034d0, & 0.0000054909d0, 0.0000041189d0, 0.0000040598d0, & 0.0000030289d0, 0.0000030085d0, 0.0000029895d0, & 0.0000023332d0, 0.0000018003d0, 0.0000013931d0, & 0.0000018829d0, 0.0000014630d0, 0.0000006967d0, & 0.0000009205d0, 0.0000012416d0, 0.0000007812d0, & 0.0000010583d0, 0.0000006536d0, 0.0000009038d0, & 0.0000004477d0, 0.0000010522d0, 0.0000006597d0, & 0.0000005567d0, 0.0000004616d0, 0.0000006575d0, & 0.0000003344d0, 0.0000002766d0, 0.0000003963d0, & 0.0000005688d0, 0.0000001793d0, 0.0000004153d0, & 0.0000004620d0, 0.0000003992d0, 0.0000004404d0, & 0.0000002976d0, 0.0000004364d0, 0.0000003740d0 / data aij(35,:) / 0.0000430595d0, 0.0000397799d0, 0.0000271616d0, & 0.0000143472d0, 0.0000176142d0, 0.0000168235d0, & 0.0000093500d0, 0.0000067329d0, 0.0000066446d0, & 0.0000082213d0, 0.0000061390d0, 0.0000046372d0, & 0.0000034811d0, 0.0000034735d0, 0.0000026730d0, & 0.0000026634d0, 0.0000015581d0, 0.0000021099d0, & 0.0000012381d0, 0.0000016679d0, 0.0000010186d0, & 0.0000010483d0, 0.0000008241d0, 0.0000011290d0, & 0.0000005475d0, 0.0000005724d0, 0.0000004661d0, & 0.0000006409d0, 0.0000004075d0, 0.0000005660d0, & 0.0000004676d0, 0.0000006678d0, 0.0000005536d0, & 0.0000004588d0, 0.0000003086d0, 0.0000002600d0, & 0.0000002221d0, 0.0000004089d0, 0.0000005910d0, & 0.0000002319d0, 0.0000003286d0, 0.0000002849d0, & 0.0000003188d0, 0.0000001718d0, 0.0000003117d0 / data aij(36,:) / 0.0000503956d0, 0.0000262755d0, 0.0000184690d0, & 0.0000169051d0, 0.0000157560d0, 0.0000113206d0, & 0.0000108187d0, 0.0000079141d0, 0.0000075536d0, & 0.0000055140d0, 0.0000054540d0, 0.0000040614d0, & 0.0000039965d0, 0.0000023509d0, 0.0000030468d0, & 0.0000018116d0, 0.0000023451d0, 0.0000013890d0, & 0.0000014094d0, 0.0000011387d0, 0.0000011426d0, & 0.0000007091d0, 0.0000009704d0, 0.0000007647d0, & 0.0000008029d0, 0.0000011008d0, 0.0000003155d0, & 0.0000004312d0, 0.0000004596d0, 0.0000004817d0, & 0.0000005269d0, 0.0000005676d0, 0.0000003706d0, & 0.0000004006d0, 0.0000004315d0, 0.0000004775d0, & 0.0000003098d0, 0.0000003407d0, 0.0000004886d0, & 0.0000004152d0, 0.0000001682d0, 0.0000003093d0, & 0.0000002068d0, 0.0000002292d0, 0.0000002008d0 / data aij(37,:) / 0.0000334173d0, 0.0000309726d0, 0.0000218877d0, & 0.0000196442d0, 0.0000138546d0, 0.0000130794d0, & 0.0000094927d0, 0.0000068714d0, 0.0000086744d0, & 0.0000063898d0, 0.0000037817d0, 0.0000048166d0, & 0.0000046345d0, 0.0000026610d0, 0.0000015855d0, & 0.0000020759d0, 0.0000027141d0, 0.0000020849d0, & 0.0000016433d0, 0.0000012979d0, 0.0000007813d0, & 0.0000010596d0, 0.0000004958d0, 0.0000008546d0, & 0.0000008928d0, 0.0000005593d0, 0.0000009962d0, & 0.0000006205d0, 0.0000006694d0, 0.0000004270d0, & 0.0000004437d0, 0.0000003712d0, 0.0000005299d0, & 0.0000003383d0, 0.0000004823d0, 0.0000002425d0, & 0.0000004443d0, 0.0000004843d0, 0.0000004110d0, & 0.0000001667d0, 0.0000001831d0, 0.0000001992d0, & 0.0000002251d0, 0.0000003165d0, 0.0000001686d0 / data aij(38,:) / 0.0000389225d0, 0.0000356628d0, 0.0000246098d0, & 0.0000234810d0, 0.0000158826d0, 0.0000154517d0, & 0.0000109594d0, 0.0000061715d0, 0.0000077203d0, & 0.0000057494d0, 0.0000072006d0, 0.0000031528d0, & 0.0000032123d0, 0.0000024479d0, 0.0000023896d0, & 0.0000023499d0, 0.0000018589d0, 0.0000010985d0, & 0.0000014288d0, 0.0000011269d0, 0.0000015138d0, & 0.0000011720d0, 0.0000009382d0, 0.0000009879d0, & 0.0000006065d0, 0.0000008389d0, 0.0000005190d0, & 0.0000007012d0, 0.0000005724d0, 0.0000004774d0, & 0.0000003925d0, 0.0000005365d0, 0.0000002703d0, & 0.0000004855d0, 0.0000004093d0, 0.0000003496d0, & 0.0000003709d0, 0.0000002481d0, 0.0000002089d0, & 0.0000001810d0, 0.0000001978d0, 0.0000001719d0, & 0.0000003092d0, 0.0000001622d0, 0.0000002294d0 / data aij(39,:) / 0.0000337803d0, 0.0000404714d0, 0.0000284070d0, & 0.0000198125d0, 0.0000183754d0, 0.0000174965d0, & 0.0000126377d0, 0.0000121499d0, 0.0000086656d0, & 0.0000051637d0, 0.0000063642d0, 0.0000036800d0, & 0.0000027442d0, 0.0000046261d0, 0.0000027739d0, & 0.0000020991d0, 0.0000027411d0, 0.0000015953d0, & 0.0000016454d0, 0.0000010057d0, 0.0000013415d0, & 0.0000010441d0, 0.0000008211d0, 0.0000011139d0, & 0.0000004134d0, 0.0000004295d0, 0.0000005796d0, & 0.0000003604d0, 0.0000004939d0, 0.0000003153d0, & 0.0000004360d0, 0.0000004611d0, 0.0000003900d0, & 0.0000005448d0, 0.0000003467d0, 0.0000004915d0, & 0.0000002450d0, 0.0000002082d0, 0.0000002350d0, & 0.0000002486d0, 0.0000002168d0, 0.0000002377d0, & 0.0000001597d0, 0.0000002236d0, 0.0000001948d0 / data aij(40,:) / 0.0000513067d0, 0.0000471119d0, 0.0000328458d0, & 0.0000132586d0, 0.0000211621d0, 0.0000154592d0, & 0.0000085830d0, 0.0000106377d0, 0.0000060140d0, & 0.0000058815d0, 0.0000073820d0, 0.0000042029d0, & 0.0000054567d0, 0.0000041212d0, 0.0000018646d0, & 0.0000023994d0, 0.0000014275d0, 0.0000018493d0, & 0.0000011151d0, 0.0000011543d0, 0.0000009245d0, & 0.0000012066d0, 0.0000007246d0, 0.0000007519d0, & 0.0000004803d0, 0.0000008191d0, 0.0000005011d0, & 0.0000004138d0, 0.0000004368d0, 0.0000003569d0, & 0.0000006387d0, 0.0000005261d0, 0.0000004315d0, & 0.0000002781d0, 0.0000003871d0, 0.0000001946d0, & 0.0000003503d0, 0.0000002314d0, 0.0000002482d0, & 0.0000002172d0, 0.0000003055d0, 0.0000001223d0, & 0.0000002858d0, 0.0000001905d0, 0.0000002117d0 / data aij(41,:) / 0.0000450816d0, 0.0000408154d0, 0.0000282845d0, & 0.0000155178d0, 0.0000138761d0, 0.0000175937d0, & 0.0000098262d0, 0.0000121258d0, 0.0000069414d0, & 0.0000066229d0, 0.0000029233d0, 0.0000048194d0, & 0.0000037116d0, 0.0000036148d0, 0.0000027563d0, & 0.0000016149d0, 0.0000009741d0, 0.0000012561d0, & 0.0000012827d0, 0.0000016831d0, 0.0000010254d0, & 0.0000010378d0, 0.0000014009d0, 0.0000008403d0, & 0.0000008877d0, 0.0000009243d0, 0.0000009675d0, & 0.0000003626d0, 0.0000004818d0, 0.0000003920d0, & 0.0000003302d0, 0.0000004548d0, 0.0000002250d0, & 0.0000003083d0, 0.0000003321d0, 0.0000003601d0, & 0.0000001838d0, 0.0000002508d0, 0.0000001319d0, & 0.0000003035d0, 0.0000000966d0, 0.0000001703d0, & 0.0000002389d0, 0.0000002086d0, 0.0000000873d0 / data aij(42,:) / 0.0000516615d0, 0.0000359046d0, 0.0000250255d0, & 0.0000176967d0, 0.0000162043d0, 0.0000117023d0, & 0.0000111500d0, 0.0000083372d0, 0.0000080845d0, & 0.0000057760d0, 0.0000057683d0, 0.0000042198d0, & 0.0000042307d0, 0.0000031731d0, 0.0000018613d0, & 0.0000018786d0, 0.0000018362d0, 0.0000018880d0, & 0.0000011419d0, 0.0000019392d0, 0.0000015208d0, & 0.0000005532d0, 0.0000005717d0, 0.0000005781d0, & 0.0000007821d0, 0.0000004847d0, 0.0000005016d0, & 0.0000004026d0, 0.0000005570d0, 0.0000007553d0, & 0.0000003651d0, 0.0000002375d0, 0.0000004137d0, & 0.0000004454d0, 0.0000003721d0, 0.0000003077d0, & 0.0000002562d0, 0.0000001692d0, 0.0000001437d0, & 0.0000003380d0, 0.0000001705d0, 0.0000002396d0, & 0.0000001596d0, 0.0000002284d0, 0.0000001911d0 / data aij(43,:) / 0.0000345441d0, 0.0000316241d0, 0.0000286584d0, & 0.0000206648d0, 0.0000186795d0, 0.0000136872d0, & 0.0000097047d0, 0.0000096665d0, 0.0000091419d0, & 0.0000067531d0, 0.0000038985d0, 0.0000048445d0, & 0.0000028978d0, 0.0000037146d0, 0.0000021550d0, & 0.0000021547d0, 0.0000016273d0, 0.0000009960d0, & 0.0000012967d0, 0.0000013308d0, 0.0000008052d0, & 0.0000010640d0, 0.0000008348d0, 0.0000008528d0, & 0.0000008847d0, 0.0000003357d0, 0.0000004374d0, & 0.0000005905d0, 0.0000002889d0, 0.0000005062d0, & 0.0000005427d0, 0.0000003357d0, 0.0000003624d0, & 0.0000002976d0, 0.0000004179d0, 0.0000002635d0, & 0.0000003711d0, 0.0000001854d0, 0.0000003373d0, & 0.0000001698d0, 0.0000002400d0, 0.0000001599d0, & 0.0000001739d0, 0.0000001177d0, 0.0000002124d0 / data aij(44,:) / 0.0000408929d0, 0.0000365974d0, 0.0000338537d0, & 0.0000239837d0, 0.0000219789d0, 0.0000159079d0, & 0.0000148083d0, 0.0000064093d0, 0.0000047381d0, & 0.0000060372d0, 0.0000058068d0, 0.0000056862d0, & 0.0000032968d0, 0.0000024911d0, 0.0000024593d0, & 0.0000019073d0, 0.0000019128d0, 0.0000019005d0, & 0.0000014645d0, 0.0000009027d0, 0.0000008974d0, & 0.0000012109d0, 0.0000007360d0, 0.0000005796d0, & 0.0000007748d0, 0.0000003802d0, 0.0000005085d0, & 0.0000004071d0, 0.0000004279d0, 0.0000004439d0, & 0.0000003642d0, 0.0000002963d0, 0.0000003129d0, & 0.0000003366d0, 0.0000003574d0, 0.0000001793d0, & 0.0000001519d0, 0.0000002667d0, 0.0000001760d0, & 0.0000002482d0, 0.0000001261d0, 0.0000002263d0, & 0.0000001493d0, 0.0000002143d0, 0.0000000869d0 / data aij(45,:) / 0.0000460894d0, 0.0000423271d0, 0.0000297879d0, & 0.0000205531d0, 0.0000193030d0, 0.0000178901d0, & 0.0000130914d0, 0.0000096919d0, 0.0000091541d0, & 0.0000052562d0, 0.0000039234d0, 0.0000038485d0, & 0.0000029218d0, 0.0000028777d0, 0.0000021609d0, & 0.0000021577d0, 0.0000022213d0, 0.0000012807d0, & 0.0000010154d0, 0.0000007967d0, 0.0000006264d0, & 0.0000008077d0, 0.0000006542d0, 0.0000006707d0, & 0.0000006786d0, 0.0000005617d0, 0.0000004357d0, & 0.0000005927d0, 0.0000004775d0, 0.0000003001d0, & 0.0000003137d0, 0.0000002632d0, 0.0000002739d0, & 0.0000002881d0, 0.0000003141d0, 0.0000002009d0, & 0.0000002152d0, 0.0000003873d0, 0.0000001959d0, & 0.0000001287d0, 0.0000002305d0, 0.0000001938d0, & 0.0000002115d0, 0.0000003004d0, 0.0000001533d0 / c c Bij neck correction constants c data bij(1,:) / -1.20d0, -1.05d0, -1.30d0, -1.15d0, -1.00d0, & -0.85d0, -0.90d0, -0.75d0, -1.20d0, -1.05d0, & -0.90d0, -0.95d0, -0.80d0, -0.65d0, -0.70d0, & -0.75d0, -0.60d0, -0.45d0, -0.50d0, -0.75d0, & -0.40d0, -0.25d0, -0.30d0, -0.15d0, -0.20d0, & -0.25d0, 0.10d0, 0.05d0, 0.20d0, -0.05d0, & 0.30d0, 0.25d0, 0.40d0, 0.15d0, 0.10d0, & 0.25d0, 0.60d0, 0.55d0, 0.70d0, 0.45d0, & 0.80d0, 0.55d0, 0.90d0, 0.65d0, 1.00d0 / data bij(2,:) / -1.25d0, -1.10d0, -0.95d0, -1.40d0, -1.05d0, & -1.10d0, -0.95d0, -0.80d0, -0.85d0, -0.70d0, & -0.55d0, -1.00d0, -0.65d0, -0.70d0, -0.95d0, & -0.60d0, -0.65d0, -0.70d0, -0.55d0, -0.60d0, & -0.45d0, -0.10d0, -0.15d0, 0.00d0, -0.05d0, & 0.10d0, 0.05d0, 0.20d0, 0.15d0, 0.10d0, & 0.25d0, 0.00d0, 0.15d0, -0.10d0, 0.25d0, & 0.20d0, 0.35d0, 0.50d0, 0.65d0, 0.40d0, & 0.75d0, 0.70d0, 0.85d0, 0.60d0, 0.95d0 / data bij(3,:) / -1.30d0, -1.15d0, -1.00d0, -1.05d0, -0.90d0, & -0.95d0, -1.20d0, -0.85d0, -0.90d0, -0.95d0, & -0.80d0, -0.65d0, -0.70d0, -0.75d0, -0.40d0, & -0.65d0, -0.30d0, -0.35d0, -0.60d0, -0.45d0, & -0.50d0, -0.35d0, -0.20d0, -0.25d0, -0.10d0, & 0.05d0, 0.00d0, 0.15d0, -0.10d0, 0.25d0, & 0.00d0, 0.35d0, 0.10d0, 0.45d0, 0.40d0, & 0.55d0, 0.30d0, 0.65d0, 0.60d0, 0.75d0, & 0.50d0, 0.85d0, 0.80d0, 0.95d0, 0.70d0 / data bij(4,:) / -1.15d0, -1.40d0, -1.05d0, -0.90d0, -1.15d0, & -0.80d0, -1.05d0, -0.90d0, -0.95d0, -0.60d0, & -0.85d0, -0.70d0, -0.75d0, -0.40d0, -0.45d0, & -0.30d0, -0.35d0, -0.40d0, -0.25d0, -0.30d0, & -0.15d0, -0.40d0, -0.05d0, -0.30d0, -0.15d0, & -0.20d0, -0.05d0, 0.10d0, 0.25d0, 0.00d0, & 0.35d0, 0.10d0, 0.25d0, 0.20d0, 0.35d0, & 0.30d0, 0.45d0, 0.40d0, 0.75d0, 0.50d0, & 0.65d0, 0.80d0, 0.75d0, 0.90d0, 0.65d0 / data bij(5,:) / -1.00d0, -1.25d0, -0.90d0, -1.15d0, -1.00d0, & -0.85d0, -0.90d0, -0.75d0, -0.60d0, -0.85d0, & -0.50d0, -0.95d0, -0.80d0, -0.65d0, -0.70d0, & -0.55d0, -0.60d0, -0.25d0, -0.50d0, -0.35d0, & -0.40d0, -0.05d0, -0.10d0, 0.05d0, -0.20d0, & 0.15d0, -0.10d0, 0.05d0, 0.00d0, 0.15d0, & 0.10d0, 0.25d0, 0.40d0, 0.35d0, 0.50d0, & 0.45d0, 0.60d0, 0.55d0, 0.70d0, 0.45d0, & 0.80d0, 0.75d0, 0.90d0, 0.65d0, 1.00d0 / data bij(6,:) / -0.85d0, -1.10d0, -1.15d0, -1.00d0, -0.85d0, & -0.90d0, -0.95d0, -0.80d0, -0.65d0, -0.50d0, & -0.55d0, -0.60d0, -0.65d0, -0.50d0, -0.55d0, & -0.40d0, -0.25d0, -0.50d0, -0.15d0, -0.60d0, & -0.05d0, -0.30d0, -0.15d0, 0.00d0, -0.05d0, & 0.10d0, 0.05d0, 0.20d0, 0.15d0, 0.30d0, & 0.05d0, 0.40d0, 0.35d0, 0.50d0, 0.45d0, & 0.60d0, 0.55d0, 0.70d0, 0.45d0, 0.80d0, & 0.75d0, 0.90d0, 0.85d0, 1.00d0, 0.75d0 / data bij(7,:) / -0.90d0, -1.15d0, -1.00d0, -1.05d0, -0.90d0, & -0.55d0, -0.60d0, -0.45d0, -0.70d0, -0.55d0, & -0.60d0, -0.65d0, -0.50d0, -0.35d0, -0.40d0, & -0.25d0, -0.50d0, -0.35d0, -0.20d0, -0.05d0, & -0.10d0, 0.05d0, 0.00d0, 0.15d0, 0.30d0, & 0.25d0, 0.40d0, 0.15d0, 0.30d0, -0.15d0, & 0.40d0, 0.55d0, 0.50d0, 0.25d0, 0.60d0, & 0.55d0, 0.90d0, 0.45d0, 0.60d0, 0.75d0, & 0.70d0, 0.85d0, 1.00d0, 0.95d0, 0.90d0 / data bij(8,:) / -1.15d0, -1.00d0, -1.25d0, -0.90d0, -0.75d0, & -0.80d0, -0.45d0, -0.50d0, -0.95d0, -0.40d0, & -0.45d0, -0.70d0, -0.55d0, -0.40d0, -0.45d0, & -0.30d0, -0.15d0, -0.20d0, -0.45d0, -0.10d0, & -0.15d0, -0.20d0, -0.05d0, 0.10d0, 0.05d0, & 0.20d0, 0.15d0, 0.10d0, 0.05d0, 0.40d0, & 0.35d0, 0.50d0, 0.45d0, 0.20d0, 0.55d0, & 0.50d0, 0.45d0, 0.20d0, 0.75d0, 0.70d0, & 0.85d0, 0.80d0, 0.95d0, 1.10d0, 1.05d0 / data bij(9,:) / -1.00d0, -0.85d0, -0.90d0, -0.75d0, -0.80d0, & -0.85d0, -0.90d0, -0.55d0, -0.60d0, -0.45d0, & -0.50d0, -0.35d0, -0.40d0, -0.65d0, -0.30d0, & -0.35d0, 0.00d0, -0.25d0, 0.10d0, -0.35d0, & 0.00d0, -0.05d0, -0.10d0, 0.05d0, 0.00d0, & 0.15d0, 0.10d0, 0.25d0, 0.20d0, 0.15d0, & 0.30d0, 0.45d0, 0.00d0, 0.55d0, 0.70d0, & 0.65d0, 0.80d0, 0.75d0, 0.90d0, 1.05d0, & 1.00d0, 1.15d0, 1.10d0, 1.25d0, 1.00d0 / data bij(10,:) / -1.05d0, -1.10d0, -0.75d0, -0.60d0, -0.65d0, & -0.70d0, -0.95d0, -0.60d0, -0.45d0, -0.70d0, & -0.55d0, -0.20d0, -0.45d0, -0.30d0, -0.35d0, & -0.20d0, -0.25d0, -0.10d0, 0.05d0, 0.00d0, & -0.05d0, 0.30d0, 0.25d0, 0.00d0, 0.15d0, & 0.10d0, 0.25d0, 0.20d0, 0.55d0, 0.50d0, & 0.45d0, 0.20d0, 0.75d0, 0.30d0, 0.85d0, & 0.60d0, 0.55d0, 0.70d0, 0.85d0, 0.80d0, & 0.75d0, 0.90d0, 1.05d0, 1.00d0, 1.35d0 / data bij(11,:) / -1.10d0, -0.75d0, -0.80d0, -0.65d0, -0.50d0, & -0.75d0, -0.60d0, -0.45d0, -0.70d0, -0.55d0, & -0.40d0, -0.65d0, -0.30d0, -0.15d0, -0.20d0, & -0.25d0, -0.30d0, -0.15d0, -0.20d0, -0.05d0, & -0.10d0, 0.05d0, 0.20d0, 0.15d0, 0.30d0, & 0.05d0, 0.20d0, 0.55d0, 0.30d0, 0.45d0, & 0.40d0, 0.55d0, 0.50d0, 0.65d0, 0.60d0, & 0.55d0, 0.90d0, 0.65d0, 1.00d0, 0.95d0, & 0.90d0, 0.65d0, 1.00d0, 0.75d0, 1.10d0 / data bij(12,:) / -0.75d0, -1.00d0, -0.65d0, -0.50d0, -0.75d0, & -0.60d0, -0.65d0, -0.30d0, -0.35d0, -0.20d0, & -0.65d0, -0.50d0, -0.55d0, -0.20d0, -0.05d0, & 0.10d0, -0.15d0, -0.20d0, -0.25d0, -0.10d0, & -0.15d0, 0.00d0, 0.15d0, 0.10d0, 0.25d0, & 0.20d0, 0.35d0, 0.30d0, 0.25d0, 0.40d0, & 0.55d0, 0.70d0, 0.45d0, 0.60d0, 0.55d0, & 0.90d0, 0.85d0, 1.00d0, 0.75d0, 1.10d0, & 1.05d0, 1.20d0, 1.15d0, 1.30d0, 1.05d0 / data bij(13,:) / -0.80d0, -0.65d0, -0.70d0, -0.75d0, -0.60d0, & -0.65d0, -0.50d0, -0.55d0, -0.40d0, -0.65d0, & -0.30d0, -0.55d0, -0.40d0, -0.45d0, -0.10d0, & -0.35d0, 0.00d0, 0.15d0, 0.10d0, 0.05d0, & -0.20d0, 0.35d0, -0.10d0, 0.05d0, 0.20d0, & 0.35d0, 0.50d0, 0.45d0, 0.40d0, 0.75d0, & 0.50d0, 0.85d0, 0.60d0, 0.55d0, 0.70d0, & 0.85d0, 1.00d0, 0.75d0, 1.10d0, 1.05d0, & 1.00d0, 1.15d0, 0.90d0, 1.05d0, 1.00d0 / data bij(14,:) / -0.85d0, -0.70d0, -0.95d0, -0.60d0, -0.85d0, & -0.50d0, -0.75d0, -0.40d0, -0.25d0, -0.30d0, & -0.15d0, -0.20d0, -0.25d0, -0.10d0, 0.05d0, & -0.20d0, -0.05d0, 0.10d0, 0.05d0, -0.40d0, & 0.35d0, 0.30d0, 0.45d0, 0.20d0, -0.05d0, & 0.10d0, 0.25d0, 0.40d0, 0.35d0, 0.50d0, & 0.65d0, 1.00d0, 0.75d0, 0.90d0, 0.65d0, & 0.20d0, 0.75d0, 0.70d0, 0.85d0, 1.00d0, & 0.95d0, 1.10d0, 1.25d0, 1.20d0, 1.35d0 / data bij(15,:) / -0.70d0, -0.95d0, -0.60d0, -0.65d0, -0.50d0, & -0.55d0, -0.40d0, -0.25d0, -0.30d0, -0.15d0, & -0.20d0, -0.05d0, -0.30d0, 0.05d0, 0.20d0, & -0.05d0, -0.30d0, 0.05d0, 0.00d0, 0.15d0, & 0.10d0, 0.25d0, 0.20d0, 0.35d0, 0.10d0, & 0.45d0, 0.60d0, 0.55d0, 0.50d0, 0.25d0, & 0.20d0, 0.55d0, 0.70d0, 0.85d0, 0.80d0, & 1.15d0, 0.90d0, 1.25d0, 0.80d0, 0.95d0, & 0.90d0, 1.05d0, 1.00d0, 1.55d0, 0.90d0 / data bij(16,:) / -0.35d0, -0.80d0, -0.45d0, -0.50d0, -0.35d0, & -0.40d0, -0.25d0, -0.50d0, -0.15d0, -0.20d0, & -0.05d0, -0.50d0, -0.15d0, -0.40d0, -0.05d0, & -0.10d0, 0.25d0, 0.20d0, 0.15d0, 0.10d0, & 0.25d0, 0.20d0, 0.35d0, 0.30d0, 0.45d0, & 0.40d0, 0.35d0, 0.70d0, 0.65d0, 0.40d0, & 0.75d0, 0.50d0, 0.65d0, 0.60d0, 0.95d0, & 0.90d0, 1.05d0, 1.00d0, 1.15d0, 0.70d0, & 1.25d0, 1.00d0, 0.95d0, 1.10d0, 1.05d0 / data bij(17,:) / -0.40d0, -0.45d0, -0.50d0, -0.35d0, -0.60d0, & -0.45d0, -0.50d0, -0.15d0, 0.00d0, -0.25d0, & -0.30d0, -0.15d0, -0.40d0, -0.05d0, 0.10d0, & 0.25d0, 0.40d0, 0.15d0, 0.10d0, 0.05d0, & 0.40d0, -0.05d0, 0.10d0, 0.25d0, 0.40d0, & 0.35d0, 0.50d0, 0.45d0, 0.60d0, 0.75d0, & 0.90d0, 0.85d0, 0.60d0, 0.95d0, 0.70d0, & 1.05d0, 0.80d0, 0.95d0, 0.90d0, 1.05d0, & 1.20d0, 1.15d0, 1.30d0, 1.25d0, 1.40d0 / data bij(18,:) / -0.45d0, -0.30d0, -0.35d0, -0.40d0, -0.25d0, & -0.10d0, -0.35d0, -0.20d0, -0.25d0, -0.30d0, & -0.15d0, 0.00d0, -0.05d0, 0.10d0, 0.25d0, & 0.20d0, 0.15d0, 0.30d0, 0.05d0, 0.20d0, & 0.35d0, 0.50d0, 0.65d0, 0.20d0, 0.55d0, & 0.50d0, 0.85d0, 0.40d0, 0.75d0, 0.50d0, & 0.65d0, 0.60d0, 0.75d0, 0.90d0, 1.05d0, & 1.20d0, 0.95d0, 1.30d0, 1.05d0, 1.00d0, & 0.95d0, 1.30d0, 1.25d0, 1.40d0, 0.95d0 / data bij(19,:) / -0.30d0, -0.35d0, -0.40d0, -0.45d0, -0.30d0, & -0.35d0, -0.20d0, -0.45d0, -0.10d0, 0.05d0, & 0.20d0, -0.05d0, -0.10d0, -0.15d0, 0.20d0, & 0.15d0, 0.10d0, 0.05d0, 0.60d0, 0.35d0, & 0.50d0, 0.25d0, 0.40d0, 0.55d0, 0.70d0, & 0.65d0, 0.80d0, 0.55d0, 0.70d0, 1.05d0, & 1.00d0, 0.55d0, 0.90d0, 1.05d0, 1.20d0, & 0.75d0, 1.10d0, 0.85d0, 1.40d0, 1.35d0, & 1.50d0, 1.05d0, 1.20d0, 1.15d0, 1.30d0 / data bij(20,:) / -0.55d0, -0.40d0, -0.65d0, -0.30d0, -0.35d0, & -0.20d0, -0.25d0, -0.10d0, -0.35d0, 0.00d0, & -0.05d0, 0.10d0, 0.05d0, 0.00d0, -0.25d0, & 0.30d0, 0.25d0, 0.20d0, 0.35d0, -0.10d0, & 0.25d0, 0.40d0, 0.55d0, 0.70d0, 0.65d0, & 0.60d0, 0.75d0, 0.90d0, 0.65d0, 0.40d0, & 0.95d0, 0.70d0, 1.05d0, 1.00d0, 1.15d0, & 0.90d0, 1.05d0, 1.00d0, 0.75d0, 1.30d0, & 1.25d0, 1.60d0, 1.35d0, 1.10d0, 1.45d0 / data bij(21,:) / -0.40d0, -0.45d0, -0.70d0, -0.15d0, -0.20d0, & -0.05d0, 0.10d0, -0.35d0, 0.00d0, 0.15d0, & -0.10d0, 0.25d0, 0.00d0, 0.35d0, 0.30d0, & 0.25d0, 0.20d0, 0.55d0, 0.50d0, 0.45d0, & 0.20d0, 0.75d0, 0.50d0, 0.65d0, 0.60d0, & 0.75d0, 0.50d0, 0.85d0, 0.80d0, 0.95d0, & 1.10d0, 1.05d0, 1.00d0, 1.15d0, 1.10d0, & 1.05d0, 1.20d0, 0.95d0, 1.10d0, 1.25d0, & 1.20d0, 1.35d0, 1.30d0, 1.45d0, 1.40d0 / data bij(22,:) / -0.25d0, -0.10d0, -0.15d0, -0.40d0, -0.45d0, & -0.30d0, 0.05d0, -0.20d0, 0.15d0, 0.10d0, & 0.05d0, 0.00d0, 0.35d0, 0.10d0, 0.45d0, & 0.20d0, 0.35d0, 0.10d0, 0.25d0, 0.40d0, & 0.55d0, 0.30d0, 0.65d0, 0.20d0, 0.35d0, & 0.30d0, 0.65d0, 0.60d0, 0.75d0, 0.90d0, & 0.85d0, 1.00d0, 0.95d0, 1.30d0, 1.05d0, & 1.20d0, 1.15d0, 1.10d0, 1.05d0, 1.20d0, & 1.35d0, 1.30d0, 1.45d0, 1.40d0, 1.75d0 / data bij(23,:) / -0.30d0, -0.15d0, -0.20d0, -0.25d0, 0.10d0, & -0.35d0, -0.20d0, 0.15d0, -0.10d0, 0.05d0, & 0.40d0, 0.15d0, 0.10d0, 0.45d0, 0.00d0, & 0.35d0, 0.10d0, 0.45d0, 0.60d0, 0.55d0, & 0.50d0, 0.65d0, 0.20d0, 0.35d0, 0.90d0, & 0.45d0, 0.60d0, 0.35d0, 0.90d0, 0.65d0, & 0.60d0, 0.95d0, 1.10d0, 1.25d0, 1.00d0, & 1.15d0, 1.30d0, 1.45d0, 1.00d0, 1.15d0, & 1.50d0, 1.65d0, 1.20d0, 1.35d0, 1.30d0 / data bij(24,:) / -0.15d0, -0.20d0, -0.05d0, -0.10d0, -0.15d0, & -0.40d0, -0.05d0, 0.10d0, 0.05d0, 0.00d0, & 0.15d0, 0.30d0, 0.25d0, 0.20d0, 0.55d0, & 0.50d0, 0.45d0, 0.20d0, 0.15d0, 0.70d0, & 0.45d0, 0.60d0, 0.35d0, 0.90d0, 0.65d0, & 0.80d0, 0.55d0, 0.50d0, 0.45d0, 0.80d0, & 0.95d0, 0.90d0, 1.05d0, 1.00d0, 0.95d0, & 1.10d0, 1.25d0, 1.40d0, 1.35d0, 1.30d0, & 1.45d0, 1.20d0, 1.55d0, 1.70d0, 1.65d0 / data bij(25,:) / 0.00d0, -0.25d0, -0.10d0, -0.15d0, 0.00d0, & -0.05d0, -0.10d0, 0.05d0, 0.00d0, 0.15d0, & 0.30d0, 0.25d0, 0.20d0, 0.15d0, 0.50d0, & 0.45d0, 0.20d0, 0.35d0, 0.70d0, 0.45d0, & 0.40d0, 0.35d0, 0.70d0, 0.65d0, 0.80d0, & 0.75d0, 0.90d0, 0.65d0, 1.00d0, 0.95d0, & 1.30d0, 1.25d0, 1.00d0, 1.35d0, 0.90d0, & 1.25d0, 1.00d0, 1.35d0, 1.30d0, 1.45d0, & 1.40d0, 1.55d0, 1.70d0, 1.25d0, 1.60d0 / data bij(26,:) / -0.25d0, -0.10d0, -0.15d0, 0.00d0, 0.15d0, & 0.10d0, -0.15d0, 0.20d0, 0.15d0, 0.10d0, & 0.05d0, 0.40d0, 0.35d0, 0.50d0, 0.05d0, & 0.00d0, 0.35d0, 0.50d0, 0.25d0, 0.60d0, & 0.35d0, 0.50d0, 0.65d0, 1.00d0, 0.95d0, & 0.90d0, 0.85d0, 0.80d0, 1.15d0, 1.10d0, & 1.25d0, 1.40d0, 1.15d0, 0.90d0, 1.05d0, & 1.60d0, 1.55d0, 1.10d0, 1.25d0, 1.60d0, & 1.35d0, 1.30d0, 1.45d0, 1.60d0, 1.55d0 / data bij(27,:) / -0.10d0, -0.15d0, 0.00d0, -0.05d0, 0.10d0, & -0.15d0, 0.00d0, 0.35d0, 0.30d0, 0.05d0, & 0.20d0, 0.55d0, 0.30d0, 0.65d0, 0.60d0, & 0.15d0, 0.50d0, 0.25d0, 0.60d0, 0.55d0, & 0.90d0, 0.85d0, 0.60d0, 0.55d0, 0.70d0, & 1.05d0, 0.80d0, 0.95d0, 0.90d0, 1.05d0, & 1.00d0, 1.15d0, 1.30d0, 1.25d0, 1.20d0, & 1.55d0, 0.90d0, 1.45d0, 1.40d0, 1.35d0, & 1.90d0, 1.45d0, 1.60d0, 1.55d0, 1.50d0 / data bij(28,:) / 0.05d0, 0.00d0, 0.15d0, 0.10d0, -0.15d0, & 0.20d0, 0.35d0, 0.10d0, 0.45d0, 0.20d0, & 0.15d0, 0.30d0, 0.05d0, 0.40d0, 0.15d0, & 0.70d0, 0.45d0, 0.40d0, 0.75d0, 0.50d0, & 0.85d0, 0.60d0, 0.75d0, 0.90d0, 1.05d0, & 1.20d0, 1.15d0, 0.90d0, 1.25d0, 1.00d0, & 0.95d0, 1.10d0, 1.25d0, 1.00d0, 1.15d0, & 1.10d0, 1.25d0, 1.60d0, 1.15d0, 1.30d0, & 1.25d0, 1.20d0, 1.75d0, 1.50d0, 1.65d0 / data bij(29,:) / 0.20d0, 0.15d0, -0.10d0, -0.15d0, 0.00d0, & 0.15d0, 0.10d0, 0.45d0, 0.20d0, 0.35d0, & 0.10d0, 0.45d0, 0.40d0, 0.35d0, 0.30d0, & 0.65d0, 0.40d0, 0.35d0, 0.70d0, 0.85d0, & 0.60d0, 0.55d0, 0.50d0, 0.85d0, 1.20d0, & 0.95d0, 0.50d0, 0.85d0, 1.20d0, 1.35d0, & 0.90d0, 1.05d0, 1.40d0, 1.35d0, 1.50d0, & 1.25d0, 1.40d0, 1.55d0, 1.70d0, 1.05d0, & 1.60d0, 1.75d0, 1.70d0, 1.65d0, 1.80d0 / data bij(30,:) / 0.15d0, 0.10d0, 0.05d0, 0.00d0, 0.15d0, & 0.10d0, 0.25d0, 0.60d0, 0.35d0, 0.30d0, & 0.05d0, 0.60d0, 0.55d0, 0.30d0, 0.25d0, & 0.40d0, 0.55d0, 0.50d0, 0.85d0, 0.40d0, & 0.75d0, 1.10d0, 1.05d0, 0.40d0, 0.95d0, & 0.70d0, 0.85d0, 1.00d0, 0.95d0, 1.30d0, & 1.05d0, 1.40d0, 1.35d0, 1.70d0, 1.45d0, & 1.40d0, 1.35d0, 1.50d0, 1.45d0, 1.60d0, & 1.55d0, 1.70d0, 1.85d0, 2.00d0, 1.75d0 / data bij(31,:) / 0.10d0, 0.05d0, 0.00d0, 0.15d0, 0.10d0, & 0.25d0, 0.20d0, 0.35d0, 0.10d0, 0.45d0, & 0.60d0, 0.55d0, 0.10d0, 0.65d0, 0.80d0, & 0.75d0, 0.30d0, 0.65d0, 0.40d0, 0.75d0, & 1.10d0, 0.85d0, 0.40d0, 0.75d0, 0.70d0, & 0.85d0, 1.20d0, 0.95d0, 1.30d0, 1.25d0, & 1.40d0, 0.95d0, 1.50d0, 0.85d0, 1.60d0, & 1.75d0, 1.70d0, 0.65d0, 1.60d0, 1.55d0, & 1.50d0, 1.65d0, 1.80d0, 1.75d0, 1.90d0 / data bij(32,:) / 0.05d0, 0.20d0, 0.15d0, 0.30d0, 0.25d0, & 0.40d0, 0.35d0, 0.50d0, 0.65d0, 0.20d0, & 0.55d0, 0.30d0, 0.45d0, 0.40d0, 0.55d0, & 0.90d0, 0.85d0, 0.40d0, 0.55d0, 0.90d0, & 0.65d0, 0.80d0, 0.95d0, 1.10d0, 1.45d0, & 1.40d0, 0.95d0, 1.10d0, 1.05d0, 1.00d0, & 1.35d0, 1.30d0, 1.05d0, 1.40d0, 1.75d0, & 1.30d0, 1.65d0, 1.40d0, 1.75d0, 1.50d0, & 2.05d0, 1.60d0, 2.15d0, 1.90d0, 1.65d0 / data bij(33,:) / 0.20d0, 0.15d0, 0.30d0, 0.25d0, 0.40d0, & 0.35d0, 0.30d0, 0.25d0, 0.60d0, 0.35d0, & 0.70d0, 0.85d0, 0.20d0, 0.95d0, 0.70d0, & 0.65d0, 0.80d0, 0.55d0, 0.90d0, 0.85d0, & 1.00d0, 0.95d0, 0.90d0, 1.05d0, 1.20d0, & 1.35d0, 1.10d0, 1.25d0, 0.80d0, 1.55d0, & 1.30d0, 1.25d0, 1.20d0, 1.95d0, 1.50d0, & 1.45d0, 1.20d0, 1.95d0, 1.30d0, 1.85d0, & 1.40d0, 1.95d0, 1.50d0, 1.85d0, 1.80d0 / data bij(34,:) / 0.35d0, 0.50d0, 0.45d0, 0.40d0, 0.55d0, & 0.50d0, 0.45d0, 0.60d0, 0.55d0, 0.50d0, & 0.45d0, 0.60d0, 0.55d0, 0.70d0, 0.85d0, & 0.80d0, 0.75d0, 0.70d0, 1.05d0, 1.00d0, & 0.55d0, 0.90d0, 1.25d0, 1.00d0, 1.35d0, & 1.10d0, 1.45d0, 1.00d0, 1.75d0, 1.50d0, & 1.45d0, 1.40d0, 1.75d0, 1.30d0, 1.25d0, & 1.60d0, 1.95d0, 1.10d0, 1.85d0, 2.00d0, & 1.95d0, 2.10d0, 1.85d0, 2.20d0, 2.15d0 / data bij(35,:) / 0.30d0, 0.45d0, 0.40d0, 0.15d0, 0.50d0, & 0.65d0, 0.40d0, 0.35d0, 0.50d0, 0.85d0, & 0.80d0, 0.75d0, 0.70d0, 0.85d0, 0.80d0, & 0.95d0, 0.70d0, 1.05d0, 0.80d0, 1.15d0, & 0.90d0, 1.05d0, 1.00d0, 1.35d0, 0.90d0, & 1.05d0, 1.00d0, 1.35d0, 1.10d0, 1.45d0, & 1.40d0, 1.75d0, 1.70d0, 1.65d0, 1.40d0, & 1.35d0, 1.30d0, 1.85d0, 2.20d0, 1.55d0, & 1.90d0, 1.85d0, 2.00d0, 1.55d0, 2.10d0 / data bij(36,:) / 0.45d0, 0.20d0, 0.15d0, 0.30d0, 0.45d0, & 0.40d0, 0.55d0, 0.50d0, 0.65d0, 0.60d0, & 0.75d0, 0.70d0, 0.85d0, 0.60d0, 0.95d0, & 0.70d0, 1.05d0, 0.80d0, 0.95d0, 0.90d0, & 1.05d0, 0.80d0, 1.15d0, 1.10d0, 1.25d0, & 1.60d0, 0.75d0, 1.10d0, 1.25d0, 1.40d0, & 1.55d0, 1.70d0, 1.45d0, 1.60d0, 1.75d0, & 1.90d0, 1.65d0, 1.80d0, 2.15d0, 2.10d0, & 1.45d0, 2.00d0, 1.75d0, 1.90d0, 1.85d0 / data bij(37,:) / 0.20d0, 0.35d0, 0.30d0, 0.45d0, 0.40d0, & 0.55d0, 0.50d0, 0.45d0, 0.80d0, 0.75d0, & 0.50d0, 0.85d0, 1.00d0, 0.75d0, 0.50d0, & 0.85d0, 1.20d0, 1.15d0, 1.10d0, 1.05d0, & 0.80d0, 1.15d0, 0.70d0, 1.25d0, 1.40d0, & 1.15d0, 1.70d0, 1.45d0, 1.60d0, 1.35d0, & 1.50d0, 1.45d0, 1.80d0, 1.55d0, 1.90d0, & 1.45d0, 2.00d0, 2.15d0, 2.10d0, 1.45d0, & 1.60d0, 1.75d0, 1.90d0, 2.25d0, 1.80d0 / data bij(38,:) / 0.35d0, 0.50d0, 0.45d0, 0.60d0, 0.55d0, & 0.70d0, 0.65d0, 0.40d0, 0.75d0, 0.70d0, & 1.05d0, 0.60d0, 0.75d0, 0.70d0, 0.85d0, & 1.00d0, 0.95d0, 0.70d0, 1.05d0, 1.00d0, & 1.35d0, 1.30d0, 1.25d0, 1.40d0, 1.15d0, & 1.50d0, 1.25d0, 1.60d0, 1.55d0, 1.50d0, & 1.45d0, 1.80d0, 1.35d0, 1.90d0, 1.85d0, & 1.80d0, 1.95d0, 1.70d0, 1.65d0, 1.60d0, & 1.75d0, 1.70d0, 2.25d0, 1.80d0, 2.15d0 / data bij(39,:) / 0.30d0, 0.65d0, 0.60d0, 0.55d0, 0.70d0, & 0.85d0, 0.80d0, 0.95d0, 0.90d0, 0.65d0, & 1.00d0, 0.75d0, 0.70d0, 1.25d0, 1.00d0, & 0.95d0, 1.30d0, 1.05d0, 1.20d0, 0.95d0, & 1.30d0, 1.25d0, 1.20d0, 1.55d0, 0.90d0, & 1.05d0, 1.40d0, 1.15d0, 1.50d0, 1.25d0, & 1.60d0, 1.75d0, 1.70d0, 2.05d0, 1.80d0, & 2.15d0, 1.70d0, 1.65d0, 1.80d0, 1.95d0, & 1.90d0, 2.05d0, 1.80d0, 2.15d0, 2.10d0 / data bij(40,:) / 0.65d0, 0.80d0, 0.75d0, 0.30d0, 0.85d0, & 0.80d0, 0.55d0, 0.90d0, 0.65d0, 0.80d0, & 1.15d0, 0.90d0, 1.25d0, 1.20d0, 0.75d0, & 1.10d0, 0.85d0, 1.20d0, 0.95d0, 1.10d0, & 1.05d0, 1.40d0, 1.15d0, 1.30d0, 1.05d0, & 1.60d0, 1.35d0, 1.30d0, 1.45d0, 1.40d0, & 1.95d0, 1.90d0, 1.85d0, 1.60d0, 1.95d0, & 1.50d0, 2.05d0, 1.80d0, 1.95d0, 1.90d0, & 2.25d0, 1.60d0, 2.35d0, 2.10d0, 2.25d0 / data bij(41,:) / 0.60d0, 0.75d0, 0.70d0, 0.45d0, 0.60d0, & 0.95d0, 0.70d0, 1.05d0, 0.80d0, 0.95d0, & 0.50d0, 1.05d0, 1.00d0, 1.15d0, 1.10d0, & 0.85d0, 0.60d0, 0.95d0, 1.10d0, 1.45d0, & 1.20d0, 1.35d0, 1.70d0, 1.45d0, 1.60d0, & 1.75d0, 1.90d0, 1.25d0, 1.60d0, 1.55d0, & 1.50d0, 1.85d0, 1.40d0, 1.75d0, 1.90d0, & 2.05d0, 1.60d0, 1.95d0, 1.50d0, 2.25d0, & 1.40d0, 1.95d0, 2.30d0, 2.25d0, 1.60d0 / data bij(42,:) / 0.75d0, 0.70d0, 0.65d0, 0.60d0, 0.75d0, & 0.70d0, 0.85d0, 0.80d0, 0.95d0, 0.90d0, & 1.05d0, 1.00d0, 1.15d0, 1.10d0, 0.85d0, & 1.00d0, 1.15d0, 1.30d0, 1.05d0, 1.60d0, & 1.55d0, 0.90d0, 1.05d0, 1.20d0, 1.55d0, & 1.30d0, 1.45d0, 1.40d0, 1.75d0, 2.10d0, & 1.65d0, 1.40d0, 1.95d0, 2.10d0, 2.05d0, & 2.00d0, 1.95d0, 1.70d0, 1.65d0, 2.40d0, & 1.95d0, 2.30d0, 2.05d0, 2.40d0, 2.35d0 / data bij(43,:) / 0.50d0, 0.65d0, 0.80d0, 0.75d0, 0.90d0, & 0.85d0, 0.80d0, 0.95d0, 1.10d0, 1.05d0, & 0.80d0, 1.15d0, 0.90d0, 1.25d0, 1.00d0, & 1.15d0, 1.10d0, 0.85d0, 1.20d0, 1.35d0, & 1.10d0, 1.45d0, 1.40d0, 1.55d0, 1.70d0, & 1.05d0, 1.40d0, 1.75d0, 1.30d0, 1.85d0, & 2.00d0, 1.75d0, 1.90d0, 1.85d0, 2.20d0, & 1.95d0, 2.30d0, 1.85d0, 2.40d0, 1.95d0, & 2.30d0, 2.05d0, 2.20d0, 1.95d0, 2.50d0 / data bij(44,:) / 0.65d0, 0.80d0, 0.95d0, 0.90d0, 1.05d0, & 1.00d0, 1.15d0, 0.70d0, 0.65d0, 1.00d0, & 1.15d0, 1.30d0, 1.05d0, 1.00d0, 1.15d0, & 1.10d0, 1.25d0, 1.40d0, 1.35d0, 1.10d0, & 1.25d0, 1.60d0, 1.35d0, 1.30d0, 1.65d0, & 1.20d0, 1.55d0, 1.50d0, 1.65d0, 1.80d0, & 1.75d0, 1.70d0, 1.85d0, 2.00d0, 2.15d0, & 1.70d0, 1.65d0, 2.20d0, 1.95d0, 2.30d0, & 1.85d0, 2.40d0, 2.15d0, 2.50d0, 1.85d0 / data bij(45,:) / 0.80d0, 0.95d0, 0.90d0, 0.85d0, 1.00d0, & 1.15d0, 1.10d0, 1.05d0, 1.20d0, 0.95d0, & 0.90d0, 1.05d0, 1.00d0, 1.15d0, 1.10d0, & 1.25d0, 1.40d0, 1.15d0, 1.10d0, 1.05d0, & 1.00d0, 1.35d0, 1.30d0, 1.45d0, 1.60d0, & 1.55d0, 1.50d0, 1.85d0, 1.80d0, 1.55d0, & 1.70d0, 1.65d0, 1.80d0, 1.95d0, 2.10d0, & 1.85d0, 2.00d0, 2.55d0, 2.10d0, 1.85d0, & 2.40d0, 2.35d0, 2.50d0, 2.85d0, 2.40d0 / c c c set atom radii and parameter values for neck corrections c do i = 1, maxneck rneck(i) = radbin(i) do j = 1, maxneck aneck(j,i) = aij(j,i) bneck(j,i) = bij(j,i) end do end do return end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine initprm -- initialize force field parameters ## c ## ## c ################################################################# c c c "initprm" completely initializes a force field by setting all c parameters to zero and using defaults for control values c c subroutine initprm use angpot use bndpot use chgpot use ctrpot use dsppot use expol use extfld use fields use ielscf use kanang use kangs use kantor use katoms use kbonds use kcflux use kchrge use kcpen use kctrn use kdipol use kdsp use kexpl use khbond use kiprop use kitors use kmulti use kopbnd use kopdst use korbs use kpitor use kpolpr use kpolr use krepl use ksolut use kstbnd use ksttor use ktorsn use ktrtor use kurybr use kvdws use kvdwpr use math use mplpot use polpot use reppot use rxnpot use solpot use sizes use solute use urypot use torpot use units use uprior use vdwpot implicit none integer i,j character*3 blank3 character*8 blank8 character*12 blank12 character*16 blank16 character*20 blank20 character*24 blank24 c c c define blank character strings of various lengths c blank3 = ' ' blank8 = ' ' blank12 = ' ' blank16 = ' ' blank20 = ' ' blank24 = ' ' c c initialize strings of parameter atom types and classes c do i = 1, maxnvp kvpr(i) = blank8 end do do i = 1, maxnhb khb(i) = blank8 end do do i = 1, maxnb kb(i) = blank8 end do do i = 1, maxnb5 kb5(i) = blank8 end do do i = 1, maxnb4 kb4(i) = blank8 end do do i = 1, maxnb3 kb3(i) = blank8 end do do i = 1, maxnel kel(i) = blank12 end do do i = 1, maxna ka(i) = blank12 end do do i = 1, maxna5 ka5(i) = blank12 end do do i = 1, maxna4 ka4(i) = blank12 end do do i = 1, maxna3 ka3(i) = blank12 end do do i = 1, maxnap kap(i) = blank12 end do do i = 1, maxnaf kaf(i) = blank12 end do do i = 1, maxnsb ksb(i) = blank12 end do do i = 1, maxnu ku(i) = blank12 end do do i = 1, maxnopb kopb(i) = blank16 end do do i = 1, maxnopd kopd(i) = blank16 end do do i = 1, maxndi kdi(i) = blank16 end do do i = 1, maxnti kti(i) = blank16 end do do i = 1, maxnt kt(i) = blank16 end do do i = 1, maxnt5 kt5(i) = blank16 end do do i = 1, maxnt4 kt4(i) = blank16 end do do i = 1, maxnpt kpt(i) = blank8 end do do i = 1, maxnbt kbt(i) = blank16 end do do i = 1, maxnat kat(i) = blank16 end do do i = 1, maxntt ktt(i) = blank20 end do do i = 1, maxnd kd(i) = blank8 end do do i = 1, maxnd5 kd5(i) = blank8 end do do i = 1, maxnd4 kd4(i) = blank8 end do do i = 1, maxnd3 kd3(i) = blank8 end do do i = 1, maxnmp kmp(i) = blank12 end do do i = 1, maxnpp kppr(i) = blank8 end do do i = 1, maxncfb kcfb(i) = blank8 end do do i = 1, maxncfa kcfa(i) = blank12 end do do i = 1, maxnpi kpi(i) = blank8 end do do i = 1, maxnpi5 kpi5(i) = blank8 end do do i = 1, maxnpi4 kpi4(i) = blank8 end do c c perform dynamic allocation of some global arrays c if (.not. allocated(atmcls)) allocate (atmcls(maxtyp)) if (.not. allocated(atmnum)) allocate (atmnum(maxtyp)) if (.not. allocated(ligand)) allocate (ligand(maxtyp)) if (.not. allocated(weight)) allocate (weight(maxtyp)) if (.not. allocated(symbol)) allocate (symbol(maxtyp)) if (.not. allocated(describe)) allocate (describe(maxtyp)) if (.not. allocated(anan)) allocate (anan(3,maxclass)) if (.not. allocated(rad)) allocate (rad(maxtyp)) if (.not. allocated(eps)) allocate (eps(maxtyp)) if (.not. allocated(rad4)) allocate (rad4(maxtyp)) if (.not. allocated(eps4)) allocate (eps4(maxtyp)) if (.not. allocated(reduct)) allocate (reduct(maxtyp)) if (.not. allocated(prsiz)) allocate (prsiz(maxclass)) if (.not. allocated(prdmp)) allocate (prdmp(maxclass)) if (.not. allocated(prele)) allocate (prele(maxclass)) if (.not. allocated(dspsix)) allocate (dspsix(maxclass)) if (.not. allocated(dspdmp)) allocate (dspdmp(maxclass)) if (.not. allocated(chg)) allocate (chg(maxtyp)) if (.not. allocated(cpele)) allocate (cpele(maxclass)) if (.not. allocated(cpalp)) allocate (cpalp(maxclass)) if (.not. allocated(polr)) allocate (polr(maxtyp)) if (.not. allocated(athl)) allocate (athl(maxtyp)) if (.not. allocated(dthl)) allocate (dthl(maxtyp)) if (.not. allocated(pgrp)) allocate (pgrp(maxval,maxtyp)) if (.not. allocated(pepk)) allocate (pepk(maxclass)) if (.not. allocated(peppre)) allocate (peppre(maxclass)) if (.not. allocated(pepdmp)) allocate (pepdmp(maxclass)) if (.not. allocated(pepl)) allocate (pepl(maxclass)) if (.not. allocated(ctchg)) allocate (ctchg(maxclass)) if (.not. allocated(ctdmp)) allocate (ctdmp(maxclass)) if (.not. allocated(pbr)) allocate (pbr(maxtyp)) if (.not. allocated(csr)) allocate (csr(maxtyp)) if (.not. allocated(gkr)) allocate (gkr(maxtyp)) if (.not. allocated(snk)) allocate (snk(maxtyp)) if (.not. allocated(electron)) allocate (electron(maxclass)) if (.not. allocated(ionize)) allocate (ionize(maxclass)) if (.not. allocated(repulse)) allocate (repulse(maxclass)) if (.not. allocated(biotyp)) allocate (biotyp(maxbio)) c c initialize values of force field model parameters c forcefield = blank20 do i = 1, maxtyp atmcls(i) = 0 atmnum(i) = 0 ligand(i) = 0 weight(i) = 0.0d0 symbol(i) = blank3 describe(i) = blank24 rad(i) = 0.0d0 eps(i) = 0.0d0 rad4(i) = 0.0d0 eps4(i) = 0.0d0 reduct(i) = 0.0d0 chg(i) = 0.0d0 polr(i) = 0.0d0 athl(i) = 0.0d0 dthl(i) = 0.0d0 do j = 1, maxval pgrp(j,i) = 0 end do pbr(i) = 0.0d0 csr(i) = 0.0d0 gkr(i) = 0.0d0 snk(i) = 0.0d0 end do do i = 1, maxclass do j = 1, 3 anan(j,i) = 0.0d0 end do prsiz(i) = 0.0d0 prdmp(i) = 0.0d0 prele(i) = 0.0d0 dspsix(i) = 0.0d0 dspdmp(i) = 0.0d0 cpele(i) = 0.0d0 cpalp(i) = 0.0d0 pepk(i) = 0.0d0 peppre(i) = 0.0d0 pepdmp(i) = 0.0d0 pepl(i) = .false. ctchg(i) = 0.0d0 ctdmp(i) = 0.0d0 electron(i) = 0.0d0 ionize(i) = 0.0d0 repulse(i) = 0.0d0 end do do i = 1, maxbio biotyp(i) = 0 end do c c set default control parameters for local geometry terms c bndtyp = 'HARMONIC' bndunit = 1.0d0 cbnd = 0.0d0 qbnd = 0.0d0 angunit = 1.0d0 / radian**2 cang = 0.0d0 qang = 0.0d0 pang = 0.0d0 sang = 0.0d0 stbnunit = 1.0d0 / radian ureyunit = 1.0d0 cury = 0.0d0 qury = 0.0d0 aaunit = 1.0d0 / radian**2 opbtyp = 'W-D-C' opbunit = 1.0d0 / radian**2 copb = 0.0d0 qopb = 0.0d0 popb = 0.0d0 sopb = 0.0d0 opdunit = 1.0d0 copd = 0.0d0 qopd = 0.0d0 popd = 0.0d0 sopd = 0.0d0 idihunit = 1.0d0 / radian**2 itorunit = 1.0d0 torsunit = 1.0d0 ptorunit = 1.0d0 storunit = 1.0d0 atorunit = 1.0d0 / radian ttorunit = 1.0d0 c c set default control parameters for van der Waals terms c vdwindex = 'CLASS' vdwtyp = 'LENNARD-JONES' radrule = 'ARITHMETIC' radtyp = 'R-MIN' radsiz = 'RADIUS' epsrule = 'GEOMETRIC' gausstyp = 'NONE' ngauss = 0 abuck = 0.0d0 bbuck = 0.0d0 cbuck = 0.0d0 ghal = 0.12d0 dhal = 0.07d0 v2scale = 0.0d0 v3scale = 0.0d0 v4scale = 1.0d0 v5scale = 1.0d0 use_vcorr = .false. c c set default control parameters for repulsion terms c r2scale = 0.0d0 r3scale = 0.0d0 r4scale = 1.0d0 r5scale = 1.0d0 c c set default control parameters for dispersion terms c dsp2scale = 0.0d0 dsp3scale = 0.0d0 dsp4scale = 1.0d0 dsp5scale = 1.0d0 use_dcorr = .false. c c set default control parameters for charge-charge terms c electric = coulomb dielec = 1.0d0 ebuffer = 0.0d0 c1scale = 0.0d0 c2scale = 0.0d0 c3scale = 0.0d0 c4scale = 1.0d0 c5scale = 1.0d0 neutnbr = .false. neutcut = .false. use_exfld = .false. do i = 1, 3 exfld(i) = 0.0d0 end do c c set default control parameters for atomic multipole terms c pentyp = 'GORDON1' m2scale = 0.0d0 m3scale = 0.0d0 m4scale = 1.0d0 m5scale = 1.0d0 d1scale = 0.0d0 d2scale = 1.0d0 d3scale = 1.0d0 d4scale = 1.0d0 use_chgpen = .false. c c set default control parameters for polarization terms c poltyp = 'MUTUAL' scrtyp = 'S2U' politer = 100 poleps = 0.000001d0 uaccel = 2.0d0 p2scale = 0.0d0 p3scale = 0.0d0 p4scale = 1.0d0 p5scale = 1.0d0 p2iscale = 0.0d0 p3iscale = 0.0d0 p4iscale = 0.5d0 p5iscale = 1.0d0 u1scale = 1.0d0 u2scale = 1.0d0 u3scale = 1.0d0 u4scale = 1.0d0 w2scale = 1.0d0 w3scale = 1.0d0 w4scale = 1.0d0 w5scale = 1.0d0 use_thole = .true. use_tholed = .false. use_pred = .false. use_ielscf = .false. dpequal = .false. use_expol = .false. c c set default control parameters for charge transfer terms c ctrntyp = 'SEPARATE' c c set default control parameters for implicit solvation c solvtyp = blank8 borntyp = blank8 c c set default control parameters for reaction field c rfsize = 1000000.0d0 rfbulkd = 80.0d0 rfterms = 1 c c initialize some Merck Molecular force field parameters c call initmmff return end c c c ################################################################ c ## ## c ## subroutine initmmff -- initialize some MMFF parameters ## c ## ## c ################################################################ c c c "initmmff" initializes some parameter values for the Merck c Molecular force field c c subroutine initmmff use ktorsn use merck implicit none integer i,j,k character*16 blank16 c c c define blank character strings of various lengths c blank16 = ' ' c c perform dynamic allocation of some global arrays c if (.not. allocated(mmff_ka)) & allocate (mmff_ka(0:100,100,0:100)) if (.not. allocated(mmff_ka1)) & allocate (mmff_ka1(0:100,100,0:100)) if (.not. allocated(mmff_ka2)) & allocate (mmff_ka2(0:100,100,0:100)) if (.not. allocated(mmff_ka3)) & allocate (mmff_ka3(0:100,100,0:100)) if (.not. allocated(mmff_ka4)) & allocate (mmff_ka4(0:100,100,0:100)) if (.not. allocated(mmff_ka5)) & allocate (mmff_ka5(0:100,100,0:100)) if (.not. allocated(mmff_ka6)) & allocate (mmff_ka6(0:100,100,0:100)) if (.not. allocated(mmff_ka7)) & allocate (mmff_ka7(0:100,100,0:100)) if (.not. allocated(mmff_ka8)) & allocate (mmff_ka8(0:100,100,0:100)) if (.not. allocated(mmff_ang0)) & allocate (mmff_ang0(0:100,100,0:100)) if (.not. allocated(mmff_ang1)) & allocate (mmff_ang1(0:100,100,0:100)) if (.not. allocated(mmff_ang2)) & allocate (mmff_ang2(0:100,100,0:100)) if (.not. allocated(mmff_ang3)) & allocate (mmff_ang3(0:100,100,0:100)) if (.not. allocated(mmff_ang4)) & allocate (mmff_ang4(0:100,100,0:100)) if (.not. allocated(mmff_ang5)) & allocate (mmff_ang5(0:100,100,0:100)) if (.not. allocated(mmff_ang6)) & allocate (mmff_ang6(0:100,100,0:100)) if (.not. allocated(mmff_ang7)) & allocate (mmff_ang7(0:100,100,0:100)) if (.not. allocated(mmff_ang8)) & allocate (mmff_ang8(0:100,100,0:100)) if (.not. allocated(stbn_abc)) & allocate (stbn_abc(100,100,100)) if (.not. allocated(stbn_cba)) & allocate (stbn_cba(100,100,100)) if (.not. allocated(stbn_abc1)) & allocate (stbn_abc1(100,100,100)) if (.not. allocated(stbn_cba1)) & allocate (stbn_cba1(100,100,100)) if (.not. allocated(stbn_abc2)) & allocate (stbn_abc2(100,100,100)) if (.not. allocated(stbn_cba2)) & allocate (stbn_cba2(100,100,100)) if (.not. allocated(stbn_abc3)) & allocate (stbn_abc3(100,100,100)) if (.not. allocated(stbn_cba3)) & allocate (stbn_cba3(100,100,100)) if (.not. allocated(stbn_abc4)) & allocate (stbn_abc4(100,100,100)) if (.not. allocated(stbn_cba4)) & allocate (stbn_cba4(100,100,100)) if (.not. allocated(stbn_abc5)) & allocate (stbn_abc5(100,100,100)) if (.not. allocated(stbn_cba5)) & allocate (stbn_cba5(100,100,100)) if (.not. allocated(stbn_abc6)) & allocate (stbn_abc6(100,100,100)) if (.not. allocated(stbn_cba6)) & allocate (stbn_cba6(100,100,100)) if (.not. allocated(stbn_abc7)) & allocate (stbn_abc7(100,100,100)) if (.not. allocated(stbn_cba7)) & allocate (stbn_cba7(100,100,100)) if (.not. allocated(stbn_abc8)) & allocate (stbn_abc8(100,100,100)) if (.not. allocated(stbn_cba8)) & allocate (stbn_cba8(100,100,100)) if (.not. allocated(stbn_abc9)) & allocate (stbn_abc9(100,100,100)) if (.not. allocated(stbn_cba9)) & allocate (stbn_cba9(100,100,100)) if (.not. allocated(stbn_abc10)) & allocate (stbn_abc10(100,100,100)) if (.not. allocated(stbn_cba10)) & allocate (stbn_cba10(100,100,100)) if (.not. allocated(stbn_abc11)) & allocate (stbn_abc11(100,100,100)) if (.not. allocated(stbn_cba11)) & allocate (stbn_cba11(100,100,100)) c c initialize values for MMFF atom class equivalencies c do i = 1, 5 do j = 1, 500 eqclass(j,i) = 1000 end do end do c c initialize values for MMFF aromatic ring parameters c do i = 1, 6 do j = 1, maxtyp mmffarom(j,i) = 0 mmffaromc(j,i) = 0 mmffaroma(j,i) = 0 end do end do c c initialize values for MMFF bond stretching parameters c do i = 1, 100 do j = 1, 100 mmff_kb(j,i) = 1000.0d0 mmff_kb1(j,i) = 1000.0d0 mmff_b0(j,i) = 1000.0d0 mmff_b1(j,i) = 1000.0d0 end do end do c c initialize values for MMFF angle bending parameters c do i = 0, 100 do j = 1, 100 do k = 0, 100 mmff_ka(k,j,i) = 1000.0d0 mmff_ka1(k,j,i) = 1000.0d0 mmff_ka2(k,j,i) = 1000.0d0 mmff_ka3(k,j,i) = 1000.0d0 mmff_ka4(k,j,i) = 1000.0d0 mmff_ka5(k,j,i) = 1000.0d0 mmff_ka6(k,j,i) = 1000.0d0 mmff_ka7(k,j,i) = 1000.0d0 mmff_ka8(k,j,i) = 1000.0d0 mmff_ang0(k,j,i) = 1000.0d0 mmff_ang1(k,j,i) = 1000.0d0 mmff_ang2(k,j,i) = 1000.0d0 mmff_ang3(k,j,i) = 1000.0d0 mmff_ang4(k,j,i) = 1000.0d0 mmff_ang5(k,j,i) = 1000.0d0 mmff_ang6(k,j,i) = 1000.0d0 mmff_ang7(k,j,i) = 1000.0d0 mmff_ang8(k,j,i) = 1000.0d0 end do end do end do c c initialize values for MMFF stretch-bend parameters c do i = 1, 100 do j = 1, 100 do k = 1, 100 stbn_abc(k,j,i) = 1000.0d0 stbn_cba(k,j,i) = 1000.0d0 stbn_abc1(k,j,i) = 1000.0d0 stbn_cba1(k,j,i) = 1000.0d0 stbn_abc2(k,j,i) = 1000.0d0 stbn_cba2(k,j,i) = 1000.0d0 stbn_abc3(k,j,i) = 1000.0d0 stbn_cba3(k,j,i) = 1000.0d0 stbn_abc4(k,j,i) = 1000.0d0 stbn_cba4(k,j,i) = 1000.0d0 stbn_abc5(k,j,i) = 1000.0d0 stbn_cba5(k,j,i) = 1000.0d0 stbn_abc6(k,j,i) = 1000.0d0 stbn_cba6(k,j,i) = 1000.0d0 stbn_abc7(k,j,i) = 1000.0d0 stbn_cba7(k,j,i) = 1000.0d0 stbn_abc8(k,j,i) = 1000.0d0 stbn_cba8(k,j,i) = 1000.0d0 stbn_abc9(k,j,i) = 1000.0d0 stbn_cba9(k,j,i) = 1000.0d0 stbn_abc10(k,j,i) = 1000.0d0 stbn_cba10(k,j,i) = 1000.0d0 stbn_abc11(k,j,i) = 1000.0d0 stbn_cba11(k,j,i) = 1000.0d0 end do end do end do c c initialize values for MMFF torsional parameters c do i = 1, maxnt kt(i) = blank16 kt_1(i) = blank16 kt_2(i) = blank16 t1(1,i) = 1000.0d0 t1(2,i) = 1000.0d0 t2(1,i) = 1000.0d0 t2(2,i) = 1000.0d0 t3(1,i) = 1000.0d0 t3(2,i) = 1000.0d0 t1_1(1,i) = 1000.0d0 t1_1(2,i) = 1000.0d0 t2_1(1,i) = 1000.0d0 t2_1(2,i) = 1000.0d0 t3_1(1,i) = 1000.0d0 t3_1(2,i) = 1000.0d0 t1_2(1,i) = 1000.0d0 t1_2(2,i) = 1000.0d0 t2_2(1,i) = 1000.0d0 t2_2(2,i) = 1000.0d0 t3_2(1,i) = 1000.0d0 t3_2(2,i) = 1000.0d0 end do c c initialize values for MMFF bond charge increment parameters c do i = 1, 100 do j = 1, 100 bci(j,i) = 1000.0d0 bci_1(j,i) = 1000.0d0 end do end do return end c c c ################################################### c ## COPYRIGHT (C) 1999 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine initres -- setup biopolymer residue names ## c ## ## c ############################################################## c c c "initres" sets biopolymer residue names and biotype codes used c in PDB file conversion and automated generation of structures c c subroutine initres use resdue implicit none integer i integer nt(maxamino),cat(maxamino) integer ct(maxamino),hnt(maxamino) integer ot(maxamino),hat(maxamino) integer cbt(maxamino) integer nn(maxamino),can(maxamino) integer cn(maxamino),hnn(maxamino) integer on(maxamino),han(maxamino) integer nc(maxamino),cac(maxamino) integer cc(maxamino),hnc(maxamino) integer oc(maxamino),hac(maxamino) integer o5t(maxnuc),c5t(maxnuc) integer h51t(maxnuc),h52t(maxnuc) integer c4t(maxnuc),h4t(maxnuc) integer o4t(maxnuc),c1t(maxnuc) integer h1t(maxnuc),c3t(maxnuc) integer h3t(maxnuc),c2t(maxnuc) integer h21t(maxnuc),o2t(maxnuc) integer h22t(maxnuc),o3t(maxnuc) integer pt(maxnuc),opt(maxnuc) integer h5tt(maxnuc),h3tt(maxnuc) character*1 acid1(maxamino) character*1 base1(maxnuc) character*3 acid3(maxamino) character*3 base3(maxnuc) c c supported amino acid 1-letter and 3-letter codes c data acid1 / 'G', 'A', 'V', 'L', 'I', 'S', 'T', 'C', 'C', 'c', & 'P', 'F', 'Y', 'y', 'W', 'H', 'U', 'Z', 'D', 'd', & 'N', 'E', 'e', 'Q', 'M', 'K', 'k', 'R', 'O', 'B', & 'J', 't', 'f', 'a', 'x', 'n', 'm', 'X' / data acid3 / 'GLY', 'ALA', 'VAL', 'LEU', 'ILE', 'SER', 'THR', & 'CYS', 'CYX', 'CYD', 'PRO', 'PHE', 'TYR', 'TYD', & 'TRP', 'HIS', 'HID', 'HIE', 'ASP', 'ASH', 'ASN', & 'GLU', 'GLH', 'GLN', 'MET', 'LYS', 'LYD', 'ARG', & 'ORN', 'AIB', 'PCA', 'H2N', 'FOR', 'ACE', 'COH', & 'NH2', 'NME', 'UNK' / c c supported nucleotide 1-letter and 3-letter codes c data base1 / 'A', 'G', 'C', 'U', 'D', 'B', 'I', 'T', '1', '2', & '3', 'X' / data base3 / ' A', ' G', ' C', ' U', ' DA', ' DG', ' DC', & ' DT', ' MP', ' DP', ' TP', 'UNK' / c c biopolymer types for mid-chain peptide backbone atoms c data nt / 1, 7, 15, 27, 41, 55, 65, 77, 87, 96, & 105, 116, 131, 147, 162, 185, 202, 218, 234, 244, & 256, 268, 280, 294, 308, 321, 337, 353, 370, 384, & 391, 0, 0, 0, 0, 0, 0, 1 / data cat / 2, 8, 16, 28, 42, 56, 66, 78, 88, 97, & 106, 117, 132, 148, 163, 186, 203, 219, 235, 245, & 257, 269, 281, 295, 309, 322, 338, 354, 371, 385, & 392, 0, 0, 0, 0, 0, 0, 2 / data ct / 3, 9, 17, 29, 43, 57, 67, 79, 89, 98, & 107, 118, 133, 149, 164, 187, 204, 220, 236, 246, & 258, 270, 282, 296, 310, 323, 339, 355, 372, 386, & 393, 0, 0, 0, 0, 0, 0, 3 / data hnt / 4, 10, 18, 30, 44, 58, 68, 80, 90, 99, & 0, 119, 134, 150, 165, 188, 205, 221, 237, 247, & 259, 271, 283, 297, 311, 324, 340, 356, 373, 387, & 394, 0, 0, 0, 0, 0, 0, 4 / data ot / 5, 11, 19, 31, 45, 59, 69, 81, 91, 100, & 108, 120, 135, 151, 166, 189, 206, 222, 238, 248, & 260, 272, 284, 298, 312, 325, 341, 357, 374, 388, & 395, 0, 0, 0, 0, 0, 0, 5 / data hat / 6, 12, 20, 32, 46, 60, 70, 82, 92, 101, & 109, 121, 136, 152, 167, 190, 207, 223, 239, 249, & 261, 273, 285, 299, 313, 326, 342, 358, 375, 0, & 396, 0, 0, 0, 0, 0, 0, 6 / data cbt / 0, 13, 21, 33, 47, 61, 71, 83, 93, 102, & 110, 122, 137, 153, 168, 191, 208, 224, 240, 250, & 262, 274, 286, 300, 314, 327, 343, 359, 376, 389, & 397, 0, 0, 0, 0, 0, 0, 0 / c c biopolymer types for N-terminal peptide backbone atoms c data nn / 403, 409, 415, 421, 427, 433, 439, 445, 451, 457, & 463, 471, 477, 483, 489, 495, 501, 507, 513, 519, & 525, 531, 537, 543, 549, 555, 561, 567, 573, 579, & 391, 762, 0, 0, 0, 0, 0, 403 / data can / 404, 410, 416, 422, 428, 434, 440, 446, 452, 458, & 464, 472, 478, 484, 490, 496, 502, 508, 514, 520, & 526, 532, 538, 544, 550, 556, 562, 568, 574, 580, & 392, 0, 0, 767, 0, 0, 0, 404 / data cn / 405, 411, 417, 423, 429, 435, 441, 447, 453, 459, & 465, 473, 479, 485, 491, 497, 503, 509, 515, 521, & 527, 533, 539, 545, 551, 557, 563, 569, 575, 581, & 393, 0, 764, 769, 0, 0, 0, 405 / data hnn / 406, 412, 418, 424, 430, 436, 442, 448, 454, 460, & 466, 474, 480, 486, 492, 498, 504, 510, 516, 522, & 528, 534, 540, 546, 552, 558, 564, 570, 576, 582, & 394, 763, 0, 0, 0, 0, 0, 406 / data on / 407, 413, 419, 425, 431, 437, 443, 449, 455, 461, & 467, 475, 481, 487, 493, 499, 505, 511, 517, 523, & 529, 535, 541, 547, 553, 559, 565, 571, 577, 583, & 395, 0, 766, 770, 0, 0, 0, 407 / data han / 408, 414, 420, 426, 432, 438, 444, 450, 456, 462, & 468, 476, 482, 488, 494, 500, 506, 512, 518, 524, & 530, 536, 542, 548, 554, 560, 566, 572, 578, 0, & 396, 0, 765, 768, 0, 0, 0, 408 / c c biopolymer types for C-terminal peptide backbone atoms c data nc / 584, 590, 596, 602, 608, 614, 620, 626, 632, 638, & 644, 649, 655, 661, 667, 673, 679, 685, 691, 697, & 703, 709, 715, 721, 727, 733, 739, 745, 751, 757, & 0, 0, 0, 0, 773, 775, 777, 584 / data cac / 585, 591, 597, 603, 609, 615, 621, 627, 633, 639, & 645, 650, 656, 662, 668, 674, 680, 686, 692, 698, & 704, 710, 716, 722, 728, 734, 740, 746, 752, 758, & 0, 0, 0, 0, 0, 0, 779, 585 / data cc / 586, 592, 598, 604, 610, 616, 622, 628, 634, 640, & 646, 651, 657, 663, 669, 675, 681, 687, 693, 699, & 705, 711, 717, 723, 729, 735, 741, 747, 753, 759, & 0, 0, 0, 0, 771, 0, 0, 586 / data hnc / 587, 593, 599, 605, 611, 617, 623, 629, 635, 641, & 0, 652, 658, 664, 670, 676, 682, 688, 694, 700, & 706, 712, 718, 724, 730, 736, 742, 748, 754, 760, & 0, 0, 0, 0, 774, 776, 778, 587 / data oc / 588, 594, 600, 606, 612, 618, 624, 630, 636, 642, & 647, 653, 659, 665, 671, 677, 683, 689, 695, 701, & 707, 713, 719, 725, 731, 737, 743, 749, 755, 761, & 0, 0, 0, 0, 772, 0, 0, 588 / data hac / 589, 595, 601, 607, 613, 619, 625, 631, 637, 643, & 648, 654, 660, 666, 672, 678, 684, 690, 696, 702, & 708, 714, 720, 726, 732, 738, 744, 750, 756, 0, & 0, 0, 0, 0, 0, 0, 780, 589 / c c biopolymer types for nucleotide phosphate and sugar atoms c data o5t / 1001, 1031, 1062, 1090, 1117, 1146, 1176, 1203, & 0, 0, 0, 0 / data c5t / 1002, 1032, 1063, 1091, 1118, 1147, 1177, 1204, & 0, 0, 0, 0 / data h51t / 1003, 1033, 1064, 1092, 1119, 1148, 1178, 1205, & 0, 0, 0, 0 / data h52t / 1004, 1034, 1065, 1093, 1120, 1149, 1179, 1206, & 0, 0, 0, 0 / data c4t / 1005, 1035, 1066, 1094, 1121, 1150, 1180, 1207, & 0, 0, 0, 0 / data h4t / 1006, 1036, 1067, 1095, 1122, 1151, 1181, 1208, & 0, 0, 0, 0 / data o4t / 1007, 1037, 1068, 1096, 1123, 1152, 1182, 1209, & 0, 0, 0, 0 / data c1t / 1008, 1038, 1069, 1097, 1124, 1153, 1183, 1210, & 0, 0, 0, 0 / data h1t / 1009, 1039, 1070, 1098, 1125, 1154, 1184, 1211, & 0, 0, 0, 0 / data c3t / 1010, 1040, 1071, 1099, 1126, 1155, 1185, 1212, & 0, 0, 0, 0 / data h3t / 1011, 1041, 1072, 1100, 1127, 1156, 1186, 1213, & 0, 0, 0, 0 / data c2t / 1012, 1042, 1073, 1101, 1128, 1157, 1187, 1214, & 0, 0, 0, 0 / data h21t / 1013, 1043, 1074, 1102, 1129, 1158, 1188, 1215, & 0, 0, 0, 0 / data o2t / 1014, 1044, 1075, 1103, 0, 0, 0, 0, & 0, 0, 0, 0 / data h22t / 1015, 1045, 1076, 1104, 1130, 1159, 1189, 1216, & 0, 0, 0, 0 / data o3t / 1016, 1046, 1077, 1105, 1131, 1160, 1190, 1217, & 0, 0, 0, 0 / data pt / 1230, 1230, 1230, 1230, 1242, 1242, 1242, 1242, & 0, 0, 0, 0 / data opt / 1231, 1231, 1231, 1231, 1243, 1243, 1243, 1243, & 0, 0, 0, 0 / data h5tt / 1233, 1233, 1233, 1233, 1245, 1245, 1245, 1245, & 0, 0, 0, 0 / data h3tt / 1238, 1238, 1238, 1238, 1250, 1250, 1250, 1250, & 0, 0, 0, 0 / c c c set amino acid names and peptide backbone biotypes c do i = 1, maxamino amino(i) = acid3(i) amino1(i) = acid1(i) ntyp(i) = nt(i) catyp(i) = cat(i) ctyp(i) = ct(i) hntyp(i) = hnt(i) otyp(i) = ot(i) hatyp(i) = hat(i) cbtyp(i) = cbt(i) nntyp(i) = nn(i) cantyp(i) = can(i) cntyp(i) = cn(i) hnntyp(i) = hnn(i) ontyp(i) = on(i) hantyp(i) = han(i) nctyp(i) = nc(i) cactyp(i) = cac(i) cctyp(i) = cc(i) hnctyp(i) = hnc(i) octyp(i) = oc(i) hactyp(i) = hac(i) end do c c set values for the 1- and 3-letter nucleotide names c do i = 1, maxnuc nuclz(i) = base3(i) nuclz1(i) = base1(i) o5typ(i) = o5t(i) c5typ(i) = c5t(i) h51typ(i) = h51t(i) h52typ(i) = h52t(i) c4typ(i) = c4t(i) h4typ(i) = h4t(i) o4typ(i) = o4t(i) c1typ(i) = c1t(i) h1typ(i) = h1t(i) c3typ(i) = c3t(i) h3typ(i) = h3t(i) c2typ(i) = c2t(i) h21typ(i) = h21t(i) o2typ(i) = o2t(i) h22typ(i) = h22t(i) o3typ(i) = o3t(i) ptyp(i) = pt(i) optyp(i) = opt(i) h5ttyp(i) = h5tt(i) h3ttyp(i) = h3tt(i) 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 initrot -- set bonds for dihedral rotation ## c ## ## c ############################################################### c c c "initrot" sets the torsional angles which are to be rotated c in subsequent computation, by default automatically selects c all rotatable single bonds; optionally makes atoms inactive c when they are not moved by any torsional rotation c c note that internal coordinates must already be setup c c subroutine initrot use atoms use couple use group use inform use iounit use math use omega use potent use restrn use rotbnd use usage use zcoord implicit none integer i,j,j1,j2 integer mode,iring integer bond1,bond2 integer attach1,attach2 integer nlist,nfixed integer, allocatable :: list(:) integer, allocatable :: ifixed(:,:) logical exist,query logical rotate,rotcheck logical use_partial character*240 record character*240 string c c c initialize the number of rotatable torsional angles c nomega = 0 c c use partial structure, mark inactive any atoms that do not move; c faster for limited torsions, only use with pairwise potentials c use_partial = .true. if (use_polar) use_partial = .false. c c use shortest rotlist if there is no absolute coordinate frame c use_short = .true. if (use_group) use_short = .false. if (npfix .ne. 0) use_short = .false. c c choose automatic or manual selection of torsional angles c 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 (/,' Selection of Torsional Angles for Rotation :', & //,' 0 - Automatic Selection of Torsional Angles', & /,' 1 - Manual Selection of Angles to Rotate', & /,' 2 - Manual Selection of Angles to Freeze', & //,' Enter the Method of Choice [0] : ',$) read (input,30) mode 30 format (i10) end if if (mode.ne.1 .and. mode.ne.2) mode = 0 c c perform dynamic allocation of some global arrays c if (.not. allocated(iomega)) allocate (iomega(2,n)) if (.not. allocated(zline)) allocate (zline(n)) if (.not. allocated(dihed)) allocate (dihed(n)) c c manual selection of the torsional angles to be rotated c if (mode .eq. 1) then do while (.true.) nomega = nomega + 1 j1 = 0 j2 = 0 write (iout,40) nomega 40 format (/,' Enter Atoms in Rotatable Bond',i5,' : ',$) read (input,50) record 50 format (a240) read (record,*,err=80,end=80) j1,j2 if (j1.eq.0 .and. j2.eq.0) goto 80 do i = 4, n if (iz(4,i) .eq. 0) then bond1 = iz(1,i) bond2 = iz(2,i) attach1 = n12(bond1) attach2 = n12(bond2) if (attach1.gt.1 .and. attach2.gt.1) then if ((bond1.eq.j1 .and. bond2.eq.j2) .or. & (bond1.eq.j2 .and. bond2.eq.j1)) then if (rotcheck(bond1,bond2)) then iomega(1,nomega) = bond1 iomega(2,nomega) = bond2 dihed(nomega) = ztors(i) / radian zline(nomega) = i goto 70 end if end if end if end if end do nomega = nomega - 1 write (iout,60) j1,j2 60 format (/,' INITROT -- Bond between Atoms',2i6, & ' is not Rotatable') 70 continue end do 80 continue nomega = nomega - 1 end if c c perform dynamic allocation of some local arrays c allocate (ifixed(2,n)) c c manual selection of the torsional angles to be frozen c nfixed = 0 if (mode .eq. 2) then do i = 1, n ifixed(1,i) = 0 ifixed(2,i) = 0 write (iout,90) i 90 format (/,' Enter Atoms in Frozen Bond',i5,' : ',$) read (input,100) record 100 format (a240) read (record,*,err=110,end=110) ifixed(1,i),ifixed(2,i) if (ifixed(1,i).eq.0 .or. ifixed(2,i).eq.0) goto 110 nfixed = nfixed + 1 end do 110 continue end if c c perform the automatic selection of torsional angles to rotate c if (mode.eq.0 .or. mode.eq.2) then do i = 4, n if (iz(4,i) .eq. 0) then rotate = .true. bond1 = iz(1,i) bond2 = iz(2,i) c c do not rotate a bond if either bonded atom is univalent c attach1 = n12(bond1) attach2 = n12(bond2) if (attach1.le.1 .or. attach2.le.1) rotate = .false. c c do not rotate a bond contained within a small ring c iring = 0 call chkring (iring,bond1,bond2,0,0) if (iring .ne. 0) rotate = .false. c c do not rotate bonds explicitly frozen by the user c if (mode.eq.2 .and. rotate) then do j = 1, nfixed j1 = ifixed(1,j) j2 = ifixed(2,j) if ((bond1.eq.j1 .and. bond2.eq.j2) .or. & (bond1.eq.j2 .and. bond2.eq.j1)) then rotate = .false. goto 120 end if end do end if 120 continue c c do not rotate bonds with inactive atoms on both sides c if (rotate) then if (.not. rotcheck(bond1,bond2)) rotate = .false. end if c c check for possible duplication of rotatable bonds c if (rotate) then do j = 1, nomega j1 = iomega(1,j) j2 = iomega(2,j) if ((bond1.eq.j1 .and. bond2.eq.j2) .or. & (bond1.eq.j2 .and. bond2.eq.j1)) then write (iout,130) bond1,bond2 130 format (/,' INITROT -- Rotation about',2i6, & ' occurs more than once in Z-matrix') call fatal end if end do nomega = nomega + 1 iomega(1,nomega) = bond1 iomega(2,nomega) = bond2 dihed(nomega) = ztors(i) / radian zline(nomega) = i end if end if end do end if c c perform deallocation of some local arrays c deallocate (ifixed) c c perform dynamic allocation of some local arrays c allocate (list(n)) c c make inactive the atoms not rotatable via any torsion c if (use_partial .and. nuse.eq.n) then do i = 1, n use(i) = .false. end do do i = 1, nomega bond1 = iomega(1,i) bond2 = iomega(2,i) call rotlist (bond1,bond2) do j = 1, nrot use(rot(j)) = .true. end do end do nuse = 0 do i = 1, n if (use(i)) nuse = nuse + 1 end do if (debug .and. nuse.gt.0 .and. nuse.lt.n) then nlist = 0 do i = 1, n if (use(i)) then nlist = nlist + 1 list(nlist) = i end if end do write (iout,140) 140 format (/,' List of Active Atoms for Torsional', & ' Calculations :',/) write (iout,150) (list(i),i=1,nlist) 150 format (3x,10i7) end if end if c c perform deallocation of some local arrays c deallocate (list) c c write out the number of rotatable torsions to be used c if (nomega .eq. 0) then write (iout,160) 160 format (/,' INITROT -- No Torsions for Subsequent', & ' Computation') call fatal end if write (iout,170) nomega 170 format (/,' Number of Torsions Used in Derivative', & ' Computation :',i6) return end c c c ################################################################ c ## ## c ## function rotcheck -- check for fixed atoms across bond ## c ## ## c ################################################################ c c c "rotcheck" tests a specified candidate rotatable bond for c the disallowed case where inactive atoms are found on both c sides of the candidate bond c c function rotcheck (base,partner) use atoms use rotbnd use usage implicit none integer i,base,partner logical rotcheck,value logical, allocatable :: list(:) c c c initialize status and find atoms on short side of the bond c value = .true. call rotlist (base,partner) c c rotation is allowed if all atoms on one side are active c do i = 1, nrot if (.not. use(rot(i))) then value = .false. goto 10 end if end do 10 continue c c if short side had inactive atoms, check the other side c if (.not. value) then allocate (list(n)) do i = 1, n list(i) = .true. end do do i = 1, nrot list(rot(i)) = .false. end do do i = 1, n if (list(i) .and. .not.use(i)) goto 20 end do value = .true. 20 continue deallocate (list) end if c c set the final return value of the function c rotcheck = value return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine insert -- insert atom into coordinates list ## c ## ## c ################################################################ c c c "insert" adds the specified atom to the Cartesian c coordinates list and shifts the remaining atoms c c subroutine insert (iatom) use atomid use atoms use couple use inform use iounit implicit none integer i,j,iatom c c c increase by one the total number of atoms c n = n + 1 c c shift the atom coordinates, types and connectivities c do i = n, iatom+1, -1 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 put new atom at the origin with a big atom type number c name(iatom) = 'NEW' x(iatom) = 0.0d0 y(iatom) = 0.0d0 z(iatom) = 0.0d0 type(iatom) = maxtyp + 1 n12(iatom) = 0 c c shift the connected atom lists to allow the insertion c do i = 1, n do j = 1, n12(i) if (i12(j,i) .ge. iatom) then i12(j,i) = i12(j,i) + 1 end if end do end do c c write a message to describe the atom insertion c if (debug) then write (iout,10) iatom 10 format (' INSERT -- Inserting Atom Number :',i9) 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 intedit -- edit and display Z-matrix file ## c ## ## c ########################################################### c c c "intedit" allows the user to extract information from c or alter the values within an internal coordinates file c c program intedit use atomid use atoms use files use iounit use katoms use zcoord implicit none integer i,j,k,l,m integer izmt,space integer freeunit integer trimtext integer numrow,numcol integer next,number(4) real*8 value,geometry logical changed,error character*4 word character*240 zmtfile character*240 record c c c read coordinate file and force field definition c call initial call getint call field c c print out the instructions for the program c next = 1 changed = .false. error = .false. 10 continue call zhelp c c start of main loop, examine or change Z-matrix elements c 20 continue m = 0 write (iout,30) 30 format (/,' INTEDIT> ',$) read (input,40) record 40 format (a240) c c interpret any user entered text command c space = 1 call getword (record,word,space) call upcase (word) if (word .eq. 'EXIT') then if (changed) then izmt = freeunit () zmtfile = filename(1:leng)//'.int' call version (zmtfile,'new') open (unit=izmt,file=zmtfile,status='new') call prtint (izmt) close (unit=izmt) write (iout,50) zmtfile(1:trimtext(zmtfile)) 50 format (/,' Z-Matrix Internal Coordinates written to : ',a) else write (iout,60) 60 format (/,' The Z-Matrix was not Changed;', & ' No File was Written') end if goto 410 else if (word .eq. 'QUIT') then goto 410 else if (word .eq. 'SHOW') then write (iout,70) 70 format () call prtint (iout) c c get the number of atoms entered by the user c else do i = 1, 4 number(i) = 0 end do read (record,*,err=10,end=80) (number(i),i=1,4) 80 continue do i = 1, 4 if (number(i) .ne. 0) m = i if (number(i) .gt. n) then write (iout,90) n 90 format (/,' Warning; Only',i6,' Atoms are Present', & ' in the Z-matrix') goto 20 end if end do if (m .eq. 0) then m = 1 number(1) = next end if end if c c get information about a single specified atom c if (m .eq. 1) then i = number(1) write (iout,100) i 100 format (/,' Atom Number :',i8) write (iout,110) name(i) 110 format (' Atom Name :',6x,a4) write (iout,120) describe(type(i)) 120 format (' Atom Type :',5x,a20) write (iout,130) type(i) 130 format (' Type Number :',i8) if (i .eq. 1) then write (iout,140) 140 format (/,' Atom 1 is at the Coordinate System Origin') else write (iout,150) 150 format (/,' Internal Coordinate Structural Definition :',/) write (iout,160) iz(1,i),-i,zbond(i) 160 format (1x,2i6,17x,'Distance Value :',f14.4) if (i .gt. 2) then write (iout,170) iz(2,i),-iz(1,i),-i,zang(i) 170 format (1x,3i6,11x,'Bond Angle Value :',f12.4) if (i .gt. 3) then if (iz(4,i) .eq. 0) then write (iout,180) iz(3,i),-iz(2,i), & -iz(1,i),-i,ztors(i) 180 format (1x,4i6,5x,'Dihedral Angle :',f14.4) else write (iout,190) iz(3,i),-iz(1,i),-i,ztors(i) 190 format (1x,3i6,11x,'Bond Angle Value :',f12.4) write (iout,200) iz(4,i) 200 format (30x,'Chirality Flag :',6x,i6) end if end if end if end if next = i + 1 if (next .gt. n) next = 1 c c chirality change for an atom was requested c else if (m.eq.2 .and. number(2).lt.0) then do i = 1, n if (iz(4,i).ne.0 .and. iz(1,i).eq.number(1)) then changed = .true. write (iout,210) i 210 format (/,' Inverting Chirality of Atom : ',i6) iz(4,i) = -iz(4,i) end if end do next = number(1) call makexyz c c information about a specified bond or distance c else if (m .eq. 2) then i = max(number(1),number(2)) j = min(number(1),number(2)) if (min(i,j).le.0 .and. max(i,j).gt.n) then write (iout,220) 220 format (/,' Invalid Atom Number') error = .true. else if (j .ne. iz(1,i)) then value = geometry (i,j,0,0) write (iout,230) value 230 format (/,' The Current Distance is : ',f9.4) write (iout,240) 240 format (' That Bond is not in the Z-matrix') else write (iout,250) zbond(i) 250 format (/,' The Current Distance is : ',f9.4) call zvalue ('Bond Length',zbond(i),changed) next = i end if end if c c an atom type change was requested c else if (m.eq.3 .and. number(2).lt.0) then if (number(3).gt.0 .and. number(3).le.maxtyp) then changed = .true. write (iout,260) describe(type(number(1))) 260 format (/,' Old Atom Type is : ',a20) type(number(1)) = number(3) write (iout,270) describe(type(number(1))) 270 format (' New Atom Type is : ',a20) else write (iout,280) 280 format (/,' Invalid Atom Type; Valid Types are :',/) numrow = (maxtyp+2) / 3 numcol = 2 do i = 1, numrow if (i .gt. numrow-2+mod(maxtyp-1,3)) numcol = 1 write (iout,290) (j*numrow+i,describe(j*numrow+i), & j=0,numcol) 290 format (1x,3(i3,1x,a20,2x)) end do end if c c information about a specified bond angle c else if (m .eq. 3) then i = max(number(1),number(3)) j = number(2) k = min(number(1),number(3)) if (min(i,j,k).le.0 .or. max(i,j,k).gt.n) then write (iout,300) 300 format (/,' Invalid Atom Number') error = .true. else if (iz(1,i) .ne. j) then value = geometry (i,j,k,0) write (iout,310) value 310 format (/,' The Bond Angle Value is : ',f9.4) write (iout,320) 320 format (' That Bond Angle is not in the Z-matrix') else if (iz(2,i) .eq. k) then write (iout,330) zang(i) 330 format (/,' The Bond Angle Value is : ',f9.4) call zvalue ('Bond Angle',zang(i),changed) next = i else if (iz(3,i).eq.k .and. iz(4,i).ne.0) then write (iout,340) ztors(i) 340 format (/,' The Bond Angle Value is : ',f9.4) call zvalue ('Bond Angle',ztors(i),changed) next = i else value = geometry (i,j,k,0) write (iout,350) value 350 format (/,' The Bond Angle Value is : ',f9.4) write (iout,360) 360 format (' That Bond Angle is not in the Z-matrix') end if end if c c information about a specified dihedral angle c else if (m .eq. 4) then if (number(1) .gt. number(4)) then i = number(1) j = number(2) k = number(3) l = number(4) else i = number(4) j = number(3) k = number(2) l = number(1) end if if (min(i,j,k,l).le.0 .or. max(i,j,k,l).gt.n) then write (iout,370) 370 format (/,' Invalid Atom Number') error = .true. else if (iz(1,i).ne.j .or. iz(2,i).ne.k .or. & iz(3,i).ne.l .or. iz(4,i).ne.0) then value = geometry (i,j,k,l) write (iout,380) value 380 format (/,' The Dihedral Angle Value is : ',f9.4) write (iout,390) 390 format (' That Dihedral Angle is not in the Z-matrix') else write (iout,400) ztors(i) 400 format (/,' The Dihedral Angle Value is : ',f9.4) call zvalue ('Dihedral Angle',ztors(i),changed) next = i end if end if end if c c print instructions for the program if needed c if (error) then error = .false. call zhelp end if goto 20 c c perform any final tasks before program exit c 410 continue call final end c c c ################################################################# c ## ## c ## subroutine zhelp -- print Z-matrix editing instructions ## c ## ## c ################################################################# c c c "zhelp" prints the general information and instructions c for the Z-matrix editing program c c subroutine zhelp use iounit implicit none c c c print the help and information message for Z-matrix editing c write (iout,10) 10 format (/,' If a single atom number is entered, the', & ' current definition of', & /,' the atom will be displayed.', & //,' If two atom numbers are entered, the output', & ' gives the distance', & /,' between the atoms, and asks for a new bond', & ' length if applicable;', & /,' Entry of three atoms shows the angle, and', & ' entry of four atoms', & /,' will display the corresponding dihedral angle.', & //,' To change the chirality at an atom, enter', & ' its number and -1.', & /,' To change the type of an atom, enter its', & ' number, -1, and the', & /,' new atom type number.') write (iout,20) 20 format (/,' A carriage return at the prompt will display', & ' the atom last', & /,' changed or the next atom after the one just', & ' examined.', & //,' Typing SHOW will display the contents of the', & ' current Z-matrix.', & //,' Entering EXIT writes a new file then stops,', & ' while QUIT aborts.') return end c c c ############################################################# c ## ## c ## subroutine zvalue -- gets user input Z-matrix value ## c ## ## c ############################################################# c c c "zvalue" gets user supplied values for selected coordinates c as needed by the internal coordinate editing program c c subroutine zvalue (text,x,changed) use iounit implicit none integer length integer trimtext real*8 x,xnew logical changed character*240 record character*(*) text c c c ask the user for the new internal coordinate value c xnew = x write (iout,10) text 10 format (/,' Enter the New ',a,' : ',$) read (input,20) record 20 format (a240) length = trimtext (record) if (length .ne. 0) then read (record,*,end=30,err=30) xnew 30 continue end if c c return with the altered value and recompute coordinates c if (xnew .ne. x) then changed = .true. x = xnew call makexyz 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 inter -- sum of intermolecular energy components ## c ## ## c ################################################################# c c c einter total intermolecular potential energy c c module inter implicit none real*8 einter save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## program intxyz -- internal to Cartesian coordinates ## c ## ## c ############################################################# c c c "intxyz" takes as input an internal coordinates file, c converts to and then writes out Cartesian coordinates c c program intxyz use files use iounit use titles implicit none integer ixyz,freeunit character*240 xyzfile c c c get and read the internal coordinates file; c conversion to Cartesians is done in "getint" c call initial call getint write (iout,10) title(1:ltitle) 10 format (/,' Title : ',a) c c write out the Cartesian coordinates file c ixyz = freeunit () xyzfile = filename(1:leng)//'.xyz' call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') call prtxyz (ixyz) close (unit=ixyz) c c perform any final tasks before program exit c call final end c c c ################################################### c ## COPYRIGHT (C) 1998 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## function invbeta -- inverse Beta distribution function ## c ## ## c ################################################################ c c c "invbeta" computes the inverse Beta distribution function c via a combination of Newton iteration and bisection search c c literature reference: c c K. L. Majumder and G. P. Bhattacharjee, "Inverse of the c Incomplete Beta Function Ratio", Applied Statistics, 22, c 411-414 (1973) c c function invbeta (a,b,y) implicit none real*8 eps parameter (eps=1.0d-5) real*8 invbeta,a,b,y real*8 x,x0,x1 real*8 aexp,bexp,beta real*8 mean,stdev real*8 betai,gammln real*8 slope,error logical done external betai c c c use limiting values when input argument is out of range c done = .false. if (y .le. 0.0d0) then x = 0.0d0 done = .true. else if (y .ge. 1.0d0) then x = 1.0d0 done = .true. end if c c initial guess from mean and variance of probability function c if (.not. done) then aexp = a - 1.0d0 bexp = b - 1.0d0 beta = exp(gammln(a) + gammln(b) - gammln(a+b)) mean = a / (a+b) stdev = sqrt(a*b/((a+b+1.0d0)*(a+b)**2)) if (y.gt.0.0d0 .and. y.le.0.167d0) then x = mean + (y/0.167d0-2.0d0)*stdev else if (y.gt.0.167d0 .and. y.lt.0.833d0) then x = mean + (y/0.333d0-1.5d0)*stdev else if (y.ge.0.833d0 .and. y.lt.1.0d0) then x = mean + (y/0.167d0-4.0d0)*stdev end if x = max(eps,min(1.0d0-eps,x)) end if c c refine inverse distribution value via Newton iteration c do while (.not. done) slope = (x**aexp * (1.0d0-x)**bexp) / beta error = betai(a,b,x) - y x = x - error/slope if (abs(error) .lt. eps) done = .true. if (x.lt.0.0d0 .or. x.gt.1.0d0) done = .true. end do c c try bisection search if Newton iteration moved out of range c if (x.lt.0.0d0 .or. x.gt.1.0d0) then x0 = 0.0d0 x1 = 1.0d0 done = .false. end if c c refine inverse distribution value via bisection search c do while (.not. done) x = 0.5d0 * (x0+x1) error = betai(a,b,x) - y if (error .gt. 0.0d0) x1 = x if (error .lt. 0.0d0) x0 = x if (abs(error) .lt. eps) done = .true. end do c c return best estimate of the inverse beta distribution value c invbeta = x return end c c c ################################################################# c ## ## c ## function betai -- cumulative Beta distribution function ## c ## ## c ################################################################# c c c "betai" evaluates the cumulative Beta distribution function c as the probability that a random variable from a distribution c with Beta parameters "a" and "b" will be less than "x" c c function betai (a,b,x) implicit none real*8 betai,a,b,x real*8 bt,gammln real*8 betacf external betacf c c c get cumulative distribution directly or via reflection c if (x .le. 0.0d0) then betai = 0.0d0 else if (x .ge. 1.0d0) then betai = 1.0d0 else bt = exp(gammln(a+b) - gammln(a) - gammln(b) & + a*log(x) + b*log(1.0d0-x)) if (x .lt. (a+1.0d0)/(a+b+2.0d0)) then betai = (bt/a) * betacf (a,b,x) else betai = 1.0d0 - (bt/b) * betacf (b,a,1.0d0-x) end if end if return end c c c ################################################################# c ## ## c ## function betacf -- continued fraction routine for betai ## c ## ## c ################################################################# c c c "betacf" computes a rapidly convergent continued fraction needed c by routine "betai" to evaluate the cumulative Beta distribution c c function betacf (a,b,x) implicit none integer maxiter real*8 eps,delta parameter (maxiter=100) parameter (eps=1.0d-10) parameter (delta=1.0d-30) integer i real*8 betacf,a,b,x real*8 m,m2,aa real*8 c,d,del,h real*8 qab,qam,qap c c c establish an initial guess for the Beta continued fraction c qab = a + b qap = a + 1.0d0 qam = a - 1.0d0 c = 1.0d0 d = 1.0d0 - qab*x/qap if (abs(d) .lt. delta) d = delta d = 1.0d0 / d h = d c c iteratively improve the continued fraction to convergence c do i = 1, maxiter m = dble(i) m2 = 2.0d0 * m aa = m * (b-m) * x / ((qam+m2)*(a+m2)) d = 1.0d0 + aa*d if (abs(d) .lt. delta) d = delta c = 1.0d0 + aa/c if (abs(c) .lt. delta) c = delta d = 1.0d0 / d h = h * d * c aa = -(a+m) * (qab+m) * x / ((a+m2)*(qap+m2)) d = 1.0d0 + aa*d if (abs(d) .lt. delta) d = delta c = 1.0d0 + aa/c if (abs(c) .lt. delta) c = delta d = 1.0d0 / d del = d * c h = h * del if (abs(del-1.0d0) .lt. eps) goto 10 end do 10 continue betacf = h return end c c c ############################################################## c ## ## c ## function gammln -- natural log of the Gamma function ## c ## ## c ############################################################## c c c "gammln" uses a series expansion due to Lanczos to compute c the natural logarithm of the Gamma function at "x" in [0,1] c c function gammln (x) implicit none real*8 step,c0,c1,c2,c3,c4,c5,c6 parameter (step=2.5066282746310005d0) parameter (c0=1.000000000190015d0) parameter (c1=7.618009172947146d1) parameter (c2=-8.650532032941677d1) parameter (c3=2.401409824083091d1) parameter (c4=-1.231739572450155d0) parameter (c5=1.208650973866179d-3) parameter (c6=-5.395239384953d-6) real*8 gammln,x real*8 series,temp c c c get the natural log of Gamma via a series expansion c temp = x + 5.5d0 temp = (x+0.5d0)*log(temp) - temp series = c0 + c1/(x+1.0d0) + c2/(x+2.0d0) + c3/(x+3.0d0) & + c4/(x+4.0d0) + c5/(x+5.0d0) + c6/(x+6.0d0) gammln = temp + log(step*series/x) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine invert -- gauss-jordan matrix inversion ## c ## ## c ############################################################ c c c "invert" inverts a matrix using the Gauss-Jordan method c c variables and parameters: c c n dimension of the matrix to be inverted c a matrix to invert; contains inverse on exit c c subroutine invert (n,a) use iounit implicit none integer i,j,k,n integer icol,irow integer, allocatable :: ipivot(:) integer, allocatable :: indxc(:) integer, allocatable :: indxr(:) real*8 big,temp real*8 pivot real*8 a(n,*) c c c perform dynamic allocation of some local arrays c allocate (ipivot(n)) allocate (indxc(n)) allocate (indxr(n)) c c perform matrix inversion via the Gauss-Jordan algorithm c do i = 1, n ipivot(i) = 0 end do do i = 1, n big = 0.0d0 do j = 1, n if (ipivot(j) .ne. 1) then do k = 1, n if (ipivot(k) .eq. 0) then if (abs(a(j,k)) .ge. big) then big = abs(a(j,k)) irow = j icol = k end if else if (ipivot(k) .gt. 1) then write (iout,10) 10 format (/,' INVERT -- Cannot Invert', & ' a Singular Matrix') call fatal end if end do end if end do ipivot(icol) = ipivot(icol) + 1 if (irow .ne. icol) then do j = 1, n temp = a(irow,j) a(irow,j) = a(icol,j) a(icol,j) = temp end do end if indxr(i) = irow indxc(i) = icol if (a(icol,icol) .eq. 0.0d0) then write (iout,20) 20 format (/,' INVERT -- Cannot Invert a Singular Matrix') call fatal end if pivot = a(icol,icol) a(icol,icol) = 1.0d0 do j = 1, n a(icol,j) = a(icol,j) / pivot end do do j = 1, n if (j .ne. icol) then temp = a(j,icol) a(j,icol) = 0.0d0 do k = 1, n a(j,k) = a(j,k) - a(icol,k)*temp end do end if end do end do do i = n, 1, -1 if (indxr(i) .ne. indxc(i)) then do k = 1, n temp = a(k,indxr(i)) a(k,indxr(i)) = a(k,indxc(i)) a(k,indxc(i)) = temp end do end if end do c c perform deallocation of some local arrays c deallocate (ipivot) deallocate (indxc) deallocate (indxr) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## module iounit -- Fortran input/output unit numbers ## c ## ## c ############################################################ c c c input Fortran I/O unit for main input (default=5) c iout Fortran I/O unit for main output (default=6) c c module iounit implicit none integer input integer iout save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine jacobi -- jacobi matrix diagonalization ## c ## ## c ############################################################ c c c "jacobi" performs a matrix diagonalization of a real c symmetric matrix by the method of Jacobi rotations c c variables and parameters: c c n dimension of the matrix to be diagonalized c a input with the matrix to be diagonalized; only c the upper triangle and diagonal are required c d returned with the eigenvalues in ascending order c v returned with the eigenvectors of the matrix c b temporary work vector c z temporary work vector c c subroutine jacobi (n,a,d,v) use iounit implicit none integer i,j,k integer n,ip,iq integer nrot,maxrot real*8 sm,tresh,s,c,t real*8 theta,tau,h,g,p real*8 d(*) real*8, allocatable :: b(:) real*8, allocatable :: z(:) real*8 a(n,*) real*8 v(n,*) c c c perform dynamic allocation of some local arrays c allocate (b(n)) allocate (z(n)) c c setup and initialization c maxrot = 100 nrot = 0 do ip = 1, n do iq = 1, n v(ip,iq) = 0.0d0 end do v(ip,ip) = 1.0d0 end do do ip = 1, n b(ip) = a(ip,ip) d(ip) = b(ip) z(ip) = 0.0d0 end do c c perform the jacobi rotations c do i = 1, maxrot sm = 0.0d0 do ip = 1, n-1 do iq = ip+1, n sm = sm + abs(a(ip,iq)) end do end do if (sm .eq. 0.0d0) goto 10 if (i .lt. 4) then tresh = 0.2d0*sm / n**2 else tresh = 0.0d0 end if do ip = 1, n-1 do iq = ip+1, n g = 100.0d0 * abs(a(ip,iq)) if (i.gt.4 .and. abs(d(ip))+g.eq.abs(d(ip)) & .and. abs(d(iq))+g.eq.abs(d(iq))) then a(ip,iq) = 0.0d0 else if (abs(a(ip,iq)) .gt. tresh) then h = d(iq) - d(ip) if (abs(h)+g .eq. abs(h)) then t = a(ip,iq) / h else theta = 0.5d0*h / a(ip,iq) t = 1.0d0 / (abs(theta)+sqrt(1.0d0+theta**2)) if (theta .lt. 0.0d0) t = -t end if c = 1.0d0 / sqrt(1.0d0+t**2) s = t * c tau = s / (1.0d0+c) h = t * a(ip,iq) z(ip) = z(ip) - h z(iq) = z(iq) + h d(ip) = d(ip) - h d(iq) = d(iq) + h a(ip,iq) = 0.0d0 do j = 1, ip-1 g = a(j,ip) h = a(j,iq) a(j,ip) = g - s*(h+g*tau) a(j,iq) = h + s*(g-h*tau) end do do j = ip+1, iq-1 g = a(ip,j) h = a(j,iq) a(ip,j) = g - s*(h+g*tau) a(j,iq) = h + s*(g-h*tau) end do do j = iq+1, n g = a(ip,j) h = a(iq,j) a(ip,j) = g - s*(h+g*tau) a(iq,j) = h + s*(g-h*tau) end do do j = 1, n g = v(j,ip) h = v(j,iq) v(j,ip) = g - s*(h+g*tau) v(j,iq) = h + s*(g-h*tau) end do nrot = nrot + 1 end if end do end do do ip = 1, n b(ip) = b(ip) + z(ip) d(ip) = b(ip) z(ip) = 0.0d0 end do end do c c perform deallocation of some local arrays c deallocate (b) deallocate (z) c c print warning if not converged c 10 continue if (nrot .eq. maxrot) then write (iout,20) 20 format (/,' JACOBI -- Matrix Diagonalization not Converged') end if c c sort the eigenvalues and vectors c do i = 1, n-1 k = i p = d(i) do j = i+1, n if (d(j) .lt. p) then k = j p = d(j) end if end do if (k .ne. i) then d(k) = d(i) d(i) = p do j = 1, n p = v(j,i) v(j,i) = v(j,k) v(j,k) = p end do end if 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 kanang -- angle-angle term forcefield parameters ## c ## ## c ################################################################# c c c anan angle-angle cross term parameters for each atom class c c module kanang implicit none real*8, allocatable :: anan(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine kangang -- angle-angle parameter assignment ## c ## ## c ################################################################ c c c "kangang" assigns the parameters for angle-angle cross term c interactions and processes new or changed parameter values c c subroutine kangang use angang use angbnd use atmlst use atomid use atoms use couple use inform use iounit use kanang use keys use potent use tors implicit none integer i,j,k,m,next integer it,ia,ic integer nang,jang,kang integer maxaa real*8 fa,faa,aak(3) logical header character*20 keyword character*240 record character*240 string c c c process keywords containing angle-angle parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'ANGANG ') then it = 0 do j = 1, 3 aak(j) = 0.0d0 end do string = record(next:240) read (string,*,err=10,end=10) it,(aak(j),j=1,3) 10 continue if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Angle-Angle Parameters :', & //,5x,'Atom Class',12x,'K(AA)-1',8x,'K(AA)-2', & 8x,'K(AA)-3',/) end if write (iout,30) it,(aak(j),j=1,3) 30 format (9x,i3,7x,3f15.3) end if do j = 1, 3 anan(j,it) = aak(j) end do end if end do c c perform dynamic allocation of some global arrays c maxaa = 15 * n if (allocated(iaa)) deallocate (iaa) if (allocated(kaa)) deallocate (kaa) allocate (iaa(2,maxaa)) allocate (kaa(maxaa)) c c assign the angle-angle parameters for each angle pair c nangang = 0 do i = 1, n nang = n12(i) * (n12(i)-1) / 2 it = class(i) if (it .ne. 0) then do j = 1, nang-1 jang = anglist(j,i) ia = iang(1,jang) ic = iang(3,jang) m = 1 if (atomic(ia) .le. 1) m = m + 1 if (atomic(ic) .le. 1) m = m + 1 fa = anan(m,it) do k = j+1, nang kang = anglist(k,i) ia = iang(1,kang) ic = iang(3,kang) m = 1 if (atomic(ia) .le. 1) m = m + 1 if (atomic(ic) .le. 1) m = m + 1 faa = fa * anan(m,it) if (faa .ne. 0.0d0) then nangang = nangang + 1 iaa(1,nangang) = jang iaa(2,nangang) = kang kaa(nangang) = faa end if end do end do end if end do c c turn off the angle-angle potential if it is not used c if (nangang .eq. 0) use_angang = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine kangle -- angle bend parameter assignment ## c ## ## c ############################################################## c c c "kangle" assigns the force constants and ideal angles for c the bond angles; also processes new or changed parameters c c subroutine kangle use angbnd use angpot use atomid use atoms use couple use fields use inform use iounit use kangs use keys use potent use usage implicit none integer i,j integer ia,ib,ic integer ita,itb,itc integer na,nap,naf integer na3,na4,na5 integer jen,ih,nh integer next,size integer minat,iring real*8 fc,an,pr real*8 an1,an2,an3 logical header,done logical use_ring character*4 pa,pb,pc character*6 label character*12 blank,pt character*20 keyword character*240 record character*240 string c c c process keywords containing angle bending parameters c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) iring = -1 if (keyword(1:6) .eq. 'ANGLE ') iring = 0 if (keyword(1:7) .eq. 'ANGLE5 ') iring = 5 if (keyword(1:7) .eq. 'ANGLE4 ') iring = 4 if (keyword(1:7) .eq. 'ANGLE3 ') iring = 3 if (iring .ge. 0) then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 an3 = 0.0d0 jen = 0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,fc,an1,an2,an3 10 continue if (min(ia,ib,ic) .le. 0) goto 190 if (an2.ne.0.0d0 .or. an3.ne.0.0d0) jen = 1 if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Angle Bending Parameters :', & //,5x,'Atom Classes',13x,'K(B)',10x,'Angle',/) end if if (iring .eq. 0) then if (jen .eq. 0) then write (iout,30) ia,ib,ic,fc,an1 30 format (4x,3i4,3x,2f15.3) else if (an1 .ne. 0.0d0) then write (iout,40) ia,ib,ic,fc,an1 40 format (4x,3i4,3x,2f15.3,3x,'0-H''s') end if if (an2 .ne. 0.0d0) then write (iout,50) ia,ib,ic,fc,an2 50 format (4x,3i4,3x,2f15.3,3x,'1-H''s') end if if (an3 .ne. 0.0d0) then write (iout,60) ia,ib,ic,fc,an3 60 format (4x,3i4,3x,2f15.3,3x,'2-H''s') end if else if (iring .eq. 5) label = '5-Ring' if (iring .eq. 4) label = '4-Ring' if (iring .eq. 3) label = '3-Ring' if (jen .eq. 0) then write (iout,70) ia,ib,ic,fc,an1,label 70 format (4x,3i4,3x,2f15.3,3x,a6) else if (an1 .ne. 0.0d0) then write (iout,80) ia,ib,ic,fc,an1,label 80 format (4x,3i4,3x,2f15.3,3x,a6,3x,'0-H''s') end if if (an2 .ne. 0.0d0) then write (iout,90) ia,ib,ic,fc,an2,label 90 format (4x,3i4,3x,2f15.3,3x,a6,3x,'1-H''s') end if if (an3 .ne. 0.0d0) then write (iout,100) ia,ib,ic,fc,an3,label 100 format (4x,3i4,3x,2f15.3,3x,a6,3x,'2-H''s') end if end if end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) if (ia .le. ic) then pt = pa//pb//pc else pt = pc//pb//pa end if if (iring .eq. 0) then do j = 1, maxna if (ka(j).eq.blank .or. ka(j).eq.pt) then ka(j) = pt acon(j) = fc ang(1,j) = an1 ang(2,j) = an2 ang(3,j) = an3 goto 120 end if end do write (iout,110) 110 format (/,' KANGLE -- Too many Bond Angle', & ' Bending Parameters') abort = .true. 120 continue else if (iring .eq. 5) then do j = 1, maxna5 if (ka5(j).eq.blank .or. ka5(j).eq.pt) then ka5(j) = pt acon5(j) = fc ang5(1,j) = an1 ang5(2,j) = an2 ang5(3,j) = an3 goto 140 end if end do write (iout,130) 130 format (/,' KANGLE -- Too many 5-Ring Angle', & ' Bending Parameters') abort = .true. 140 continue else if (iring .eq. 4) then do j = 1, maxna4 if (ka4(j).eq.blank .or. ka4(j).eq.pt) then ka4(j) = pt acon4(j) = fc ang4(1,j) = an1 ang4(2,j) = an2 ang4(3,j) = an3 goto 160 end if end do write (iout,150) 150 format (/,' KANGLE -- Too many 4-Ring Angle', & ' Bending Parameters') abort = .true. 160 continue else if (iring .eq. 3) then do j = 1, maxna3 if (ka3(j).eq.blank .or. ka3(j).eq.pt) then ka3(j) = pt acon3(j) = fc ang3(1,j) = an1 ang3(2,j) = an2 ang3(3,j) = an3 goto 180 end if end do write (iout,170) 170 format (/,' KANGLE -- Too many 3-Ring Angle', & ' Bending Parameters') abort = .true. 180 continue end if 190 continue end if end do c c process keywords containing in-plane angle bending parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'ANGLEP ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 jen = 0 string = record(next:240) read (string,*,err=200,end=200) ia,ib,ic,fc,an1,an2 200 continue if (an2 .ne. 0.0d0) jen = 1 if (.not. silent) then if (header) then header = .false. write (iout,210) 210 format (/,' Additional In-Plane Angle Bending', & ' Parameters :', & //,5x,'Atom Classes',13x,'K(B)',10x,'Angle',/) end if if (jen .eq. 0) then write (iout,220) ia,ib,ic,fc,an1 220 format (4x,3i4,3x,2f15.3) else if (an1 .ne. 0.0d0) then write (iout,230) ia,ib,ic,fc,an1 230 format (4x,3i4,3x,2f15.3,3x,'0-H''s') end if if (an2 .ne. 0.0d0) then write (iout,240) ia,ib,ic,fc,an2 240 format (4x,3i4,3x,2f15.3,3x,'1-H''s') end if end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) if (ia .le. ic) then pt = pa//pb//pc else pt = pc//pb//pa end if do j = 1, maxnap if (kap(j).eq.blank .or. kap(j).eq.pt) then kap(j) = pt aconp(j) = fc angp(1,j) = an1 angp(2,j) = an2 goto 260 end if end do write (iout,250) 250 format (/,' KANGLE -- Too many In-Plane Angle', & ' Bending Parameters') abort = .true. 260 continue end if end do c c process keywords containing Fourier angle bending parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'ANGLEF ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an = 0.0d0 pr = 0.0d0 string = record(next:240) read (string,*,err=270,end=270) ia,ib,ic,fc,an,pr 270 continue if (.not. silent) then if (header) then header = .false. write (iout,280) 280 format (/,' Additional Fourier Angle Bending', & ' Parameters :', & //,5x,'Atom Classes',13x,'K(B)',10x,'Shift', & 9x,'Period',/) end if write (iout,290) ia,ib,ic,fc,an,pr 290 format (4x,3i4,3x,3f15.3) end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) if (ia .le. ic) then pt = pa//pb//pc else pt = pc//pb//pa end if do j = 1, maxnaf if (kaf(j).eq.blank .or. kaf(j).eq.pt) then kaf(j) = pt aconf(j) = fc angf(1,j) = an angf(2,j) = pr goto 310 end if end do write (iout,300) 300 format (/,' KANGLE -- Too many Fourier Angle', & ' Bending Parameters') abort = .true. 310 continue end if end do c c determine the total number of forcefield parameters c na = maxna na5 = maxna5 na4 = maxna4 na3 = maxna3 nap = maxnap naf = maxnaf do i = maxna, 1, -1 if (ka(i) .eq. blank) na = i - 1 end do do i = maxna5, 1, -1 if (ka5(i) .eq. blank) na5 = i - 1 end do do i = maxna4, 1, -1 if (ka4(i) .eq. blank) na4 = i - 1 end do do i = maxna3, 1, -1 if (ka3(i) .eq. blank) na3 = i - 1 end do do i = maxnap, 1, -1 if (kap(i) .eq. blank) nap = i - 1 end do do i = maxnaf, 1, -1 if (kaf(i) .eq. blank) naf = i - 1 end do use_ring = .false. if (min(na5,na4,na3) .ne. 0) use_ring = .true. c c set generic parameters for use with any number of hydrogens c do i = 1, na if (ang(2,i).eq.0.0d0 .and. ang(3,i).eq.0.0d0) then ang(2,i) = ang(1,i) ang(3,i) = ang(1,i) end if end do do i = 1, na5 if (ang5(2,i).eq.0.0d0 .and. ang5(3,i).eq.0.0d0) then ang5(2,i) = ang5(1,i) ang5(3,i) = ang5(1,i) end if end do do i = 1, na4 if (ang4(2,i).eq.0.0d0 .and. ang4(3,i).eq.0.0d0) then ang4(2,i) = ang4(1,i) ang4(3,i) = ang4(1,i) end if end do do i = 1, na3 if (ang3(2,i).eq.0.0d0 .and. ang3(3,i).eq.0.0d0) then ang3(2,i) = ang3(1,i) ang3(3,i) = ang3(1,i) end if end do do i = 1, nap if (angp(2,i) .eq. 0.0d0) then angp(2,i) = angp(1,i) end if end do c c perform dynamic allocation of some global arrays c if (allocated(ak)) deallocate (ak) if (allocated(anat)) deallocate (anat) if (allocated(afld)) deallocate (afld) if (allocated(angtyp)) deallocate (angtyp) allocate (ak(nangle)) allocate (anat(nangle)) allocate (afld(nangle)) allocate (angtyp(nangle)) c c use special angle parameter assignment method for MMFF c if (forcefield .eq. 'MMFF94') then call kanglem return end if c c assign ideal bond angle and force constant for each angle c header = .true. do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pt = pa//pb//pc else pt = pc//pb//pa end if ak(i) = 0.0d0 anat(i) = 0.0d0 afld(i) = 0.0d0 angtyp(i) = 'HARMONIC' done = .false. c c count number of non-angle hydrogens on the central atom c nh = 1 do j = 1, n12(ib) ih = i12(j,ib) if (ih.ne.ia .and. ih.ne.ic .and. atomic(ih).eq.1) & nh = nh + 1 end do c c make a check for bond angles contained inside small rings c iring = 0 if (use_ring) then call chkring (iring,ia,ib,ic,0) if (iring .eq. 6) iring = 0 if (iring.eq.5 .and. na5.eq.0) iring = 0 if (iring.eq.4 .and. na4.eq.0) iring = 0 if (iring.eq.3 .and. na3.eq.0) iring = 0 end if c c assign angle bending parameters for bond angles c if (iring .eq. 0) then do j = 1, na if (ka(j).eq.pt .and. ang(nh,j).ne.0.0d0) then ak(i) = acon(j) anat(i) = ang(nh,j) done = .true. goto 320 end if end do c c assign bending parameters for 5-membered ring angles c else if (iring .eq. 5) then do j = 1, na5 if (ka5(j).eq.pt .and. ang5(nh,j).ne.0.0d0) then ak(i) = acon5(j) anat(i) = ang5(nh,j) done = .true. goto 320 end if end do c c assign bending parameters for 4-membered ring angles c else if (iring .eq. 4) then do j = 1, na4 if (ka4(j).eq.pt .and. ang4(nh,j).ne.0.0d0) then ak(i) = acon4(j) anat(i) = ang4(nh,j) done = .true. goto 320 end if end do c c assign bending parameters for 3-membered ring angles c else if (iring .eq. 3) then do j = 1, na3 if (ka3(j).eq.pt .and. ang3(nh,j).ne.0.0d0) then ak(i) = acon3(j) anat(i) = ang3(nh,j) done = .true. goto 320 end if end do end if c c assign in-plane angle bending parameters for bond angles c if (.not.done .and. n12(ib).eq.3) then do j = 1, nap if (kap(j).eq.pt .and. angp(nh,j).ne.0.0d0) then ak(i) = aconp(j) anat(i) = angp(nh,j) angtyp(i) = 'IN-PLANE' done = .true. goto 320 end if end do end if c c assign Fourier angle bending parameters for bond angles c if (.not. done) then do j = 1, naf if (kaf(j) .eq. pt) then ak(i) = aconf(j) anat(i) = angf(1,j) afld(i) = angf(2,j) angtyp(i) = 'FOURIER' done = .true. goto 320 end if end do end if c c warning if suitable angle bending parameter not found c 320 continue minat = min(atomic(ia),atomic(ib),atomic(ic)) if (minat .eq. 0) done = .true. if (use_angle .and. .not.done) then if (use(ia) .or. use(ib) .or. use(ic)) abort = .true. if (header) then header = .false. write (iout,330) 330 format (/,' Undefined Angle Bending Parameters :', & //,' Type',18x,'Atom Names',19x, & 'Atom Classes',/) end if label = 'Angle ' if (iring .eq. 5) label = '5-Ring' if (iring .eq. 4) label = '4-Ring' if (iring .eq. 3) label = '3-Ring' write (iout,340) label,ia,name(ia),ib,name(ib), & ic,name(ic),ita,itb,itc 340 format (1x,a6,5x,3(i6,'-',a3),7x,3i5) end if end do c c process keywords containing angle specific parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:6) .eq. 'ANGLE ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 string = record(next:240) read (string,*,err=350,end=350) ia,ib,ic,fc,an1 350 continue if (min(ia,ib,ic) .lt. 0) then ia = abs(ia) ib = abs(ib) ic = abs(ic) if (header .and. .not.silent) then header = .false. write (iout,360) 360 format (/,' Additional Angle Parameters for', & ' Specific Angles :', & //,8x,'Atoms',17x,'K(B)',10x,'Angle',/) end if if (.not. silent) then write (iout,370) ia,ib,ic,fc,an1 370 format (4x,3i4,3x,2f15.3) end if do j = 1, nangle ita = iang(1,j) itb = iang(2,j) itc = iang(3,j) if (ib .eq. itb) then if ((ia.eq.ita .and. ic.eq.itc) .or. & (ia.eq.itc .and. ic.eq.ita)) then ak(j) = fc anat(j) = an1 angtyp(j) = 'HARMONIC' goto 380 end if end if end do end if 380 continue end if end do c c process keywords containing in-plane angle specific parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'ANGLEP ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 string = record(next:240) read (string,*,err=390,end=390) ia,ib,ic,fc,an1 390 continue if (min(ia,ib,ic) .lt. 0) then ia = abs(ia) ib = abs(ib) ic = abs(ic) if (header .and. .not.silent) then header = .false. write (iout,400) 400 format (/,' Additional In-Plane Angle Parameters', & ' for Specific Angles :', & //,8x,'Atoms',17x,'K(B)',10x,'Angle',/) end if if (.not. silent) then write (iout,410) ia,ib,ic,fc,an1 410 format (4x,3i4,3x,2f15.3) end if if (ia .gt. ic) then ita = ia ia = ic ic = ita end if do j = 1, nangle if (ia.eq.iang(1,j) .and. ib.eq.iang(2,j) & .and. ic.eq.iang(3,j)) then ak(j) = fc anat(j) = an1 angtyp(j) = 'IN-PLANE' goto 420 end if end do end if 420 continue end if end do c c process keywords containing Fourier angle specific parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'ANGLEF ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an = 0.0d0 pr = 0.0d0 string = record(next:240) read (string,*,err=430,end=430) ia,ib,ic,fc,an,pr 430 continue if (min(ia,ib,ic) .lt. 0) then ia = abs(ia) ib = abs(ib) ic = abs(ic) if (header .and. .not.silent) then header = .false. write (iout,440) 440 format (/,' Additional Fourier Angle Parameters', & ' for Specific Angles :', & //,8x,'Atoms',17x,'K(B)',10x,'Shift', & 9x,'Period',/) end if if (.not. silent) then write (iout,450) ia,ib,ic,fc,an,pr 450 format (4x,3i4,3x,3f15.3) end if if (ia .gt. ic) then ita = ia ia = ic ic = ita end if do j = 1, nangle if (ia.eq.iang(1,j) .and. ib.eq.iang(2,j) & .and. ic.eq.iang(3,j)) then ak(j) = fc anat(j) = an afld(j) = pr angtyp(j) = 'FOURIER' goto 460 end if end do end if 460 continue end if end do c c turn off the angle bending potential if it is not used c if (nangle .eq. 0) use_angle = .false. return end c c c ############################################################### c ## ## c ## subroutine kanglem -- MMFF angle parameter assignment ## c ## ## c ############################################################### c c c "kanglem" assigns the force constants and ideal angles for c bond angles according to the Merck Molecular Force Field (MMFF) c c literature reference: c c T. A. Halgren, "Merck Molecular Force Field. I. Basis, Form, c Scope, Parametrization, and Performance of MMFF94", Journal of c Computational Chemistry, 17, 490-519 (1995) c c T. A. Halgren, "Merck Molecular Force Field. V. Extension of c MMFF94 Using Experimental Data, Additional Computational Data, c and Empirical Rules", Journal of Computational Chemistry, 17, c 616-641 (1995) c c subroutine kanglem use angbnd use angpot use atomid use atoms use bndstr use merck use potent use ring implicit none integer i,j,k,l,m integer ia,ib,ic integer ita,itb,itc integer ina,inb,inc integer itta,ittb,ittc integer bnd_ab,bnd_bc integer at,minat integer mclass real*8 d,beta real*8 z2(100),c(100) logical done logical ring3,ring4 c c c set empirical rule parameters for some common elements c do i = 1, 100 z2(i) = 1000.0d0 c(i) = 1000.0d0 end do z2(1) = 1.395d0 z2(5) = 0.0d0 z2(6) = 2.494d0 z2(7) = 2.711d0 z2(8) = 3.045d0 z2(9) = 2.847d0 z2(14) = 2.350d0 z2(15) = 2.350d0 z2(16) = 2.980d0 z2(17) = 2.909d0 z2(35) = 3.017d0 z2(33) = 0.0d0 z2(53) = 3.086d0 c(1) = 0.0d0 c(5) = 0.704d0 c(6) = 1.016d0 c(7) = 1.113d0 c(8) = 1.337d0 c(9) = 0.0d0 c(14) = 0.811d0 c(15) = 1.068d0 c(16) = 1.249d0 c(17) = 1.078d0 c(35) = 0.0d0 c(33) = 0.825d0 c(53) = 0.0d0 c c assign MMFF bond angle and force constant for each angle c do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) itta = type(ia) ittb = type(ib) ittc = type(ic) ina = atomic(ia) inb = atomic(ib) inc = atomic(ic) c c set angle index value, accounting for MMFF bond type = 1 c at = 0 do j = 1, nligne if ((ia.eq.bt_1(j,1) .and. ib.eq.bt_1(j,2)) .or. & (ib.eq.bt_1(j,1) .and. ia.eq.bt_1(j,2))) then at = at + 1 end if if ((ic.eq.bt_1(j,1) .and. ib.eq.bt_1(j,2)) .or. & (ib.eq.bt_1(j,1) .and. ic.eq.bt_1(j,2))) then at = at + 1 end if end do c c determine if the atoms belong to a 3- or 4-membered ring c ring3 = .false. ring4 = .false. do j = 1, nring3 do k = 1, 3 if (ia .eq. iring3(k,j)) then do l = 1, 3 if (ib .eq. iring3(l,j)) then do m = 1, 3 if (ic .eq. iring3(m,j)) ring3 = .true. end do end if end do end if end do end do if (.not. ring3) then do j = 1, nring4 do k = 1, 4 if (ia .eq. iring4(k,j)) then do l = 1, 4 if (ib .eq. iring4(l,j)) then do m = 1, 4 if (ic .eq. iring4(m,j)) ring4 = .true. end do end if end do end if end do end do end if c c set special index value when 3- or 4-rings are present c if (at.eq.0 .and. ring4) then at = 4 else if (at.eq.1 .and. ring4) then at = 7 else if (at.eq.2 .and. ring4) then at = 8 else if (at.eq.0 .and. ring3) then at = 3 else if (at.eq.1 .and. ring3) then at = 5 else if (at.eq.2 .and. ring3) then at = 6 end if c c setup the atom class equivalencies assignment c mclass = 0 10 continue mclass = mclass + 1 if (mclass .eq. 1) then ita = eqclass(itta,1) itb = eqclass(ittb,1) itc = eqclass(ittc,1) else if (mclass .eq. 2) then ita = eqclass(itta,2) itb = eqclass(ittb,2) itc = eqclass(ittc,2) else if (mclass .eq. 3) then ita = eqclass(itta,3) itb = eqclass(ittb,2) itc = eqclass(ittc,3) else if (mclass .eq. 4) then ita = eqclass(itta,4) itb = eqclass(ittb,2) itc = eqclass(ittc,4) else if (mclass .eq. 5) then ita = eqclass(itta,5) itb = eqclass(ittb,2) itc = eqclass(ittc,5) end if if (mclass .gt. 5) then goto 20 else if (at .eq. 0) then ak(i) = mmff_ka(ita,itb,itc) anat(i) = mmff_ang0(ita,itb,itc) else if (at .eq. 1) then ak(i) = mmff_ka1(ita,itb,itc) anat(i) = mmff_ang1(ita,itb,itc) else if (at .eq. 2) then ak(i) = mmff_ka2(ita,itb,itc) anat(i) = mmff_ang2(ita,itb,itc) else if (at .eq. 3) then ak(i) = mmff_ka3(ita,itb,itc) anat(i) = mmff_ang3(ita,itb,itc) else if (at .eq. 4) then ak(i) = mmff_ka4(ita,itb,itc) anat(i) = mmff_ang4(ita,itb,itc) else if (at .eq. 5) then ak(i) = mmff_ka5(ita,itb,itc) anat(i) = mmff_ang5(ita,itb,itc) else if (at .eq. 6) then ak(i) = mmff_ka6(ita,itb,itc) anat(i) = mmff_ang6(ita,itb,itc) else if (at .eq. 7) then ak(i) = mmff_ka7(ita,itb,itc) anat(i) = mmff_ang7(ita,itb,itc) else if (at .eq. 8) then ak(i) = mmff_ka8(ita,itb,itc) anat(i) = mmff_ang8(ita,itb,itc) end if c c use empirical rule to calculate the force constant c if (mclass .eq. 5) then if (z2(ina) .eq. 1000.0d0) goto 20 if (z2(inb) .eq. 1000.0d0) goto 20 if (z2(inc) .eq. 1000.0d0) goto 20 if (c(ina) .eq. 1000.0d0) goto 20 if (c(inb) .eq. 1000.0d0) goto 20 if (c(inc) .eq. 1000.0d0) goto 20 do k = 1, nbond if ((min(ia,ib).eq.ibnd(1,k)) .and. & (max(ia,ib).eq.ibnd(2,k))) then bnd_ab = k end if if ((min(ic,ib).eq.ibnd(1,k)) .and. & (max(ic,ib).eq.ibnd(2,k))) then bnd_bc = k end if end do d = (bl(bnd_ab)-bl(bnd_bc))**2 & / (bl(bnd_ab)+bl(bnd_bc))**2 beta = 1.0d0 if (ring4) beta = 0.85d0 if (ring3) beta = 0.05d0 ak(i) = beta*1.75d0*z2(ina)*z2(inc)*c(inb) & / ((0.01745329252d0*anat(i))**2 & *(bl(bnd_ab)+bl(bnd_bc))*exp(2.0d0*d)) end if done = .true. if (ak(i) .eq. 1000.0d0) done = .false. if (anat(i) .eq. 1000.0d0) done = .false. if (.not. done) goto 10 goto 20 end if c c use empirical rule for ideal angle and force constant c 20 continue minat = min(ina,inb,inc) if (minat .eq. 0) done = .true. if (.not. done) then if (use_angle) then anat(i) = 120.0d0 if (crd(itb) .eq. 4) anat(i) = 109.45d0 if (crd(itb) .eq. 2) then if (inb .eq. 8) then anat(i) = 105.0d0 else if (inb .gt. 10) then anat(i) = 95.0d0 else if (lin(itb) .eq. 1) then anat(i) = 180.0d0 end if end if if (crd(itb).eq.3 .and. val(itb).eq.3 & .and. mltb(itb).eq.0) then if (inb .eq. 7) then anat(i) = 107.0d0 else anat(i) = 92.0d0 end if end if if (ring3) anat(i) = 60.0d0 if (ring4) anat(i) = 90.0d0 do k = 1, nbond if ((min(ia,ib).eq.ibnd(1,k)) .and. & (max(ia,ib).eq.ibnd(2,k))) then bnd_ab = k end if if ((min(ic,ib).eq.ibnd(1,k)) .and. & (max(ic,ib).eq.ibnd(2,k))) then bnd_bc = k end if end do d = (bl(bnd_ab)-bl(bnd_bc))**2 & / (bl(bnd_ab)+bl(bnd_bc))**2 beta = 1.0d0 if (ring4) beta = 0.85d0 if (ring3) beta = 0.05d0 ak(i) = beta*1.75d0*z2(ina)*z2(inc)*c(inb) & / ((0.01745329252d0*anat(i))**2 & *(bl(bnd_ab)+bl(bnd_bc))*exp(2.0d0*d)) end if end if angtyp(i) = 'HARMONIC' if (anat(i) .eq. 180.0d0) angtyp(i) = 'LINEAR' end do c c turn off the angle bending potential if it is not used c if (nangle .eq. 0) use_angle = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module kangs -- bond angle bend forcefield parameters ## c ## ## c ############################################################### c c c maxna maximum number of harmonic angle bend parameter entries c maxna5 maximum number of 5-membered ring angle bend entries c maxna4 maximum number of 4-membered ring angle bend entries c maxna3 maximum number of 3-membered ring angle bend entries c maxnap maximum number of in-plane angle bend parameter entries c maxnaf maximum number of Fourier angle bend parameter entries c c acon force constant parameters for harmonic angle bends c acon5 force constant parameters for 5-ring angle bends c acon4 force constant parameters for 4-ring angle bends c acon3 force constant parameters for 3-ring angle bends c aconp force constant parameters for in-plane angle bends c aconf force constant parameters for Fourier angle bends c ang bond angle parameters for harmonic angle bends c ang5 bond angle parameters for 5-ring angle bends c ang4 bond angle parameters for 4-ring angle bends c ang3 bond angle parameters for 3-ring angle bends c angp bond angle parameters for in-plane angle bends c angf phase shift angle and periodicity for Fourier bends c ka string of atom classes for harmonic angle bends c ka5 string of atom classes for 5-ring angle bends c ka4 string of atom classes for 4-ring angle bends c ka3 string of atom classes for 3-ring angle bends c kap string of atom classes for in-plane angle bends c kaf string of atom classes for Fourier angle bends c c module kangs implicit none integer maxna integer maxna5 integer maxna4 integer maxna3 integer maxnap integer maxnaf real*8, allocatable :: acon(:) real*8, allocatable :: acon5(:) real*8, allocatable :: acon4(:) real*8, allocatable :: acon3(:) real*8, allocatable :: aconp(:) real*8, allocatable :: aconf(:) real*8, allocatable :: ang(:,:) real*8, allocatable :: ang5(:,:) real*8, allocatable :: ang4(:,:) real*8, allocatable :: ang3(:,:) real*8, allocatable :: angp(:,:) real*8, allocatable :: angf(:,:) character*12, allocatable :: ka(:) character*12, allocatable :: ka5(:) character*12, allocatable :: ka4(:) character*12, allocatable :: ka3(:) character*12, allocatable :: kap(:) character*12, allocatable :: kaf(:) save end c c c ########################################################## c ## COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder ## c ## All Rights Reserved ## c ########################################################## c c ################################################################## c ## ## c ## subroutine kangtor -- angle-torsion parameter assignment ## c ## ## c ################################################################## c c c "kangtor" assigns parameters for angle-torsion interactions c and processes new or changed parameter values c c subroutine kangtor use angtor use atmlst use atomid use atoms use couple use inform use iounit use keys use kantor use potent use tors implicit none integer i,j,k,l,m,nat integer ia,ib,ic,id integer ita,itb,itc,itd integer size,next real*8 at1,at2,at3 real*8 at4,at5,at6 logical header,swap character*4 pa,pb,pc,pd character*4 zeros character*16 blank character*16 pt character*20 keyword character*240 record character*240 string c c c process keywords containing angle-torsion parameters c blank = ' ' zeros = '0000' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:8) .eq. 'ANGTORS ') then ia = 0 ib = 0 ic = 0 id = 0 at1 = 0.0d0 at2 = 0.0d0 at3 = 0.0d0 at4 = 0.0d0 at5 = 0.0d0 at6 = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,id,at1,at2, & at3,at4,at5,at6 10 continue if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Angle-Torsion Parameters :', & //,32x,'1st Angle',20x,'2nd Angle', & /,5x,'Atom Classes',7x,'1-Fold',3x,'2-Fold', & 3x,'3-Fold',5x,'1-Fold',3x,'2-Fold', & 3x,'3-Fold'/) end if write (iout,30) ia,ib,ic,id,at1,at2,at3,at4,at5,at6 30 format (2x,4i4,3x,3f9.3,2x,3f9.3) end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) if (ib .lt. ic) then pt = pa//pb//pc//pd swap = .false. else if (ic .lt. ib) then pt = pd//pc//pb//pa swap = .true. else if (ia .le. id) then pt = pa//pb//pc//pd swap = .false. else if (id .lt. ia) then pt = pd//pc//pb//pa swap = .true. end if do j = 1, maxnat if (kat(j).eq.blank .or. kat(j).eq.pt) then kat(j) = pt if (swap) then atcon(1,j) = at4 atcon(2,j) = at5 atcon(3,j) = at6 atcon(4,j) = at1 atcon(5,j) = at2 atcon(6,j) = at3 else atcon(1,j) = at1 atcon(2,j) = at2 atcon(3,j) = at3 atcon(4,j) = at4 atcon(5,j) = at5 atcon(6,j) = at6 end if goto 50 end if end do write (iout,40) 40 format (/,' KANGTOR -- Too many Angle-Torsion', & ' Parameters') abort = .true. 50 continue end if end do c c determine the total number of forcefield parameters c nat = maxnat do i = maxnat, 1, -1 if (kat(i) .eq. blank) nat = i - 1 end do c c perform dynamic allocation of some global arrays c if (allocated(iat)) deallocate (iat) if (allocated(kant)) deallocate (kant) allocate (iat(3,ntors)) allocate (kant(6,ntors)) c c assign the angle-torsion parameters for each torsion c nangtor = 0 if (nat .ne. 0) then do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .lt. itc) then pt = pa//pb//pc//pd swap = .false. else if (itc .lt. itb) then pt = pd//pc//pb//pa swap = .true. else if (ita .le. itd) then pt = pa//pb//pc//pd swap = .false. else if (itd .lt. ita) then pt = pd//pc//pb//pa swap = .true. end if do j = 1, nat if (kat(j) .eq. pt) then nangtor = nangtor + 1 if (swap) then kant(1,nangtor) = atcon(4,j) kant(2,nangtor) = atcon(5,j) kant(3,nangtor) = atcon(6,j) kant(4,nangtor) = atcon(1,j) kant(5,nangtor) = atcon(2,j) kant(6,nangtor) = atcon(3,j) else kant(1,nangtor) = atcon(1,j) kant(2,nangtor) = atcon(2,j) kant(3,nangtor) = atcon(3,j) kant(4,nangtor) = atcon(4,j) kant(5,nangtor) = atcon(5,j) kant(6,nangtor) = atcon(6,j) end if iat(1,nangtor) = i m = 0 do k = 1, n12(ib)-1 do l = k+1, n12(ib) m = m + 1 if ((i12(k,ib).eq.ia .and. i12(l,ib).eq.ic) .or. & (i12(k,ib).eq.ic .and. i12(l,ib).eq.ia)) then iat(2,nangtor) = anglist(m,ib) goto 60 end if end do end do 60 continue m = 0 do k = 1, n12(ic)-1 do l = k+1, n12(ic) m = m + 1 if ((i12(k,ic).eq.ib .and. i12(l,ic).eq.id) .or. & (i12(k,ic).eq.id .and. i12(l,ic).eq.ib)) then iat(3,nangtor) = anglist(m,ic) goto 70 end if end do end do end if end do 70 continue end do end if c c turn off the angle-torsion potential if it is not used c if (nangtor .eq. 0) use_angtor = .false. return end c c c ########################################################## c ## COPYRIGHT (C) 2014 by Chao Lu & Jay William Ponder ## c ## All Rights Reserved ## c ########################################################## c c ############################################################## c ## ## c ## module kantor -- angle-torsion forcefield parameters ## c ## ## c ############################################################## c c c maxnat maximum number of angle-torsion parameter entries c c atcon torsional amplitude parameters for angle-torsion c kat string of atom classes for angle-torsion terms c c module kantor implicit none integer maxnat real*8, allocatable :: atcon(:,:) character*16, allocatable :: kat(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine katom -- atom type parameter assignment ## c ## ## c ############################################################ c c c "katom" assigns an atom type definitions to each atom in c the structure and processes any new or changed values c c literature reference: c c K. A. Feenstra, B. Hess and H. J. C. Berendsen, "Improving c Efficiency of Large Time-Scale Molecular Dynamics Simulations c of Hydrogen-Rich Systems", Journal of Computational Chemistry, c 8, 786-798 (1999) c c C. W. Hopkins, S. Le Grand, R. C. Walker and A. E. Roitberg, c "Long-Time-Step Molecular Dynamics through Hydrogen Mass c Repartitioning", Journal of Chemical Theory and Computation, c 11, 1864-1874 (2015) c c subroutine katom use atomid use atoms use couple use inform use iounit use katoms use keys implicit none integer i,j,k integer next,nh integer cls,atn,lig real*8 wght,sum real*8 hmax,hmass real*8 dmin,dmass logical header,heavy character*3 symb character*20 keyword character*24 notice character*240 record character*240 string c c c process keywords containing atom type parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:5) .eq. 'ATOM ') then k = 0 cls = 0 symb = ' ' notice = ' ' atn = 0 wght = 0.0d0 lig = 0 call getnumb (record,k,next) if (k.gt.0 .and. k.le.maxtyp) then call getnumb (record,cls,next) if (cls .eq. 0) cls = k atmcls(k) = cls call gettext (record,symb,next) call getstring (record,notice,next) string = record(next:240) read (string,*,err=40,end=40) atn,wght,lig if (header .and. .not.silent) then header = .false. write (iout,10) 10 format (/,' Additional Atom Definition Parameters :', & //,5x,'Type Class Symbol Description', & 15x,'Atomic',4x,'Mass',3x,'Valence',/) end if symbol(k) = symb describe(k) = notice atmnum(k) = atn weight(k) = wght ligand(k) = lig if (.not. silent) then write (iout,20) k,cls,symb,notice,atn,wght,lig 20 format (1x,i8,i6,5x,a3,3x,a24,i6,f11.3,i6) end if else if (k .gt. maxtyp) then write (iout,30) 30 format (/,' KATOM -- Too many Atom Types;', & ' Increase MAXTYP') abort = .true. end if 40 continue end if end do c c transfer atom type values to individual atoms c do i = 1, n k = type(i) if (k .eq. 0) then class(i) = 0 atomic(i) = 0 mass(i) = 0.0d0 valence(i) = 0 story(i) = 'Undefined Atom Type ' else if (symbol(k) .ne. ' ') name(i) = symbol(k) class(i) = atmcls(k) atomic(i) = atmnum(k) mass(i) = weight(k) valence(i) = ligand(k) story(i) = describe(k) end if end do c c repartition hydrogen masses to use "heavy" hydrogens c heavy = .false. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:15) .eq. 'HEAVY-HYDROGEN ') then heavy = .true. hmax = 4.0d0 read (string,*,err=50,end=50) hmax end if 50 continue end do if (heavy) then do i = 1, n nh = 0 sum = mass(i) do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 1) then nh = nh + 1 sum = sum + mass(k) end if end do hmass = min(hmax,sum/dble(nh+1)) do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 1) then dmass = hmass - mass(k) mass(k) = hmass mass(i) = mass(i) - dmass end if end do end do do i = 1, n if (mass(i) .lt. hmax) then dmass = hmax - mass(i) dmin = hmax + dmass do j = 1, n12(i) k = i12(j,i) if (mass(k) .gt. dmin) then mass(k) = mass(k) - dmass mass(i) = hmax goto 60 end if end do do j = 1, n13(i) k = i13(j,i) if (mass(k) .gt. dmin) then mass(k) = mass(k) - dmass mass(i) = hmax goto 60 end if end do 60 continue end if end do end if c c process keywords containing atom types for specific atoms c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:5) .eq. 'ATOM ') then k = 0 symb = ' ' notice = ' ' atn = 0 wght = 0.0d0 lig = 0 call getnumb (record,k,next) if (k.lt.0 .and. k.ge.-n) then call getnumb (record,cls,next) call gettext (record,symb,next) call getstring (record,notice,next) string = record(next:240) read (string,*,err=90,end=90) atn,wght,lig if (header .and. .not.silent) then header = .false. write (iout,70) 70 format (/,' Additional Atom Definitions for', & ' Specific Atoms :', & //,5x,'Atom Class Symbol Description', & 15x,'Atomic',4x,'Mass',3x,'Valence',/) end if k = -k if (cls .eq. 0) cls = k class(k) = cls name(k) = symb story(k) = notice atomic(k) = atn mass(k) = wght valence(k) = lig if (.not. silent) then write (iout,80) k,cls,symb,notice,atn,wght,lig 80 format (1x,i8,i6,5x,a3,3x,a24,i6,f11.3,i6) end if end if 90 continue end if end do c c check for presence of undefined atom types or classes c header = .true. do i = 1, n k = type(i) cls = class(i) if (k.lt.1 .or. k.gt.maxtyp & .or. cls.lt.1 .or. cls.gt.maxclass) then abort = .true. if (header) then header = .false. write (iout,100) 100 format (/,' Undefined Atom Types or Classes :', & //,' Type',10x,'Atom Number',5x,'Atom Type', & 5x,'Atom Class',/) end if write (iout,110) i,k,cls 110 format (' Atom',9x,i8,10x,i5,10x,i5) end if end do c c check the number of atoms attached to each atom c header = .true. do i = 1, n if (n12(i) .ne. valence(i)) then if (header) then header = .false. write (iout,120) 120 format (/,' Atoms with an Unusual Number of Attached', & ' Atoms :', & //,' Type',11x,'Atom Name',6x,'Atom Type',7x, & 'Expected',4x,'Found',/) end if write (iout,130) i,name(i),type(i),valence(i),n12(i) 130 format (' Valence',4x,i8,'-',a3,8x,i5,10x,i5,5x,i5) end if 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 katoms -- atom definition forcefield parameters ## c ## ## c ################################################################ c c c atmcls atom class number for each of the atom types c atmnum atomic number for each of the atom types c ligand number of atoms to be attached to each atom type c weight average atomic mass of each atom type c symbol modified atomic symbol for each atom type c describe string identifying each of the atom types c c module katoms implicit none integer, allocatable :: atmcls(:) integer, allocatable :: atmnum(:) integer, allocatable :: ligand(:) real*8, allocatable :: weight(:) character*3, allocatable :: symbol(:) character*24, allocatable :: describe(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine kbond -- bond stretch parameter assignment ## c ## ## c ############################################################### c c c "kbond" assigns a force constant and ideal bond length c to each bond in the structure and processes any new or c changed parameter values c c subroutine kbond use atomid use atoms use bndstr use couple use fields use inform use iounit use kbonds use keys use potent use usage implicit none integer i,j integer ia,ib,ita,itb integer nb,nb5,nb4,nb3 integer size,next integer minat,iring real*8 fc,bd logical header,done logical use_ring character*4 pa,pb character*6 label character*8 blank,pt character*20 keyword character*240 record character*240 string c c c process keywords containing bond stretch parameters c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) iring = -1 if (keyword(1:5) .eq. 'BOND ') iring = 0 if (keyword(1:6) .eq. 'BOND5 ') iring = 5 if (keyword(1:6) .eq. 'BOND4 ') iring = 4 if (keyword(1:6) .eq. 'BOND3 ') iring = 3 if (iring .ge. 0) then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,fc,bd 10 continue if (min(ia,ib) .lt. 0) goto 130 if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Bond Stretching Parameters :', & //,5x,'Atom Classes',13x,'K(S)',9x,'Length',/) end if if (iring .eq. 0) then write (iout,30) ia,ib,fc,bd 30 format (6x,2i4,5x,f15.3,f15.4) else if (iring .eq. 5) label = '5-Ring' if (iring .eq. 4) label = '4-Ring' if (iring .eq. 3) label = '3-Ring' write (iout,40) ia,ib,fc,bd,label 40 format (6x,2i4,5x,f15.3,f15.4,3x,a6) end if end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) if (ia .le. ib) then pt = pa//pb else pt = pb//pa end if if (iring .eq. 0) then do j = 1, maxnb if (kb(j).eq.blank .or. kb(j).eq.pt) then kb(j) = pt bcon(j) = fc blen(j) = bd goto 60 end if end do write (iout,50) 50 format (/,' KBOND -- Too many Bond Stretching', & ' Parameters') abort = .true. 60 continue else if (iring .eq. 5) then do j = 1, maxnb5 if (kb5(j).eq.blank .or. kb5(j).eq.pt) then kb5(j) = pt bcon5(j) = fc blen5(j) = bd goto 80 end if end do write (iout,70) 70 format (/,' KBOND -- Too many 5-Ring Stretching', & ' Parameters') abort = .true. 80 continue else if (iring .eq. 4) then do j = 1, maxnb4 if (kb4(j).eq.blank .or. kb4(j).eq.pt) then kb4(j) = pt bcon4(j) = fc blen4(j) = bd goto 100 end if end do write (iout,90) 90 format (/,' KBOND -- Too many 4-Ring Stretching', & ' Parameters') abort = .true. 100 continue else if (iring .eq. 3) then do j = 1, maxnb3 if (kb3(j).eq.blank .or. kb3(j).eq.pt) then kb3(j) = pt bcon3(j) = fc blen3(j) = bd goto 120 end if end do write (iout,110) 110 format (/,' KBOND -- Too many 3-Ring Stretching', & ' Parameters') abort = .true. 120 continue end if 130 continue end if end do c c determine the total number of forcefield parameters c nb = maxnb nb5 = maxnb5 nb4 = maxnb4 nb3 = maxnb3 do i = maxnb, 1, -1 if (kb(i) .eq. blank) nb = i - 1 end do do i = maxnb5, 1, -1 if (kb5(i) .eq. blank) nb5 = i - 1 end do do i = maxnb4, 1, -1 if (kb4(i) .eq. blank) nb4 = i - 1 end do do i = maxnb3, 1, -1 if (kb3(i) .eq. blank) nb3 = i - 1 end do use_ring = .false. if (min(nb5,nb4,nb3) .ne. 0) use_ring = .true. c c perform dynamic allocation of some global arrays c if (allocated(bk)) deallocate (bk) if (allocated(bl)) deallocate (bl) allocate (bk(nbond)) allocate (bl(nbond)) c c use special bond parameter assignment method for MMFF c if (forcefield .eq. 'MMFF94') then call kbondm return end if c c assign ideal bond length and force constant for each bond c header = .true. do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) ita = class(ia) itb = class(ib) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pt = pa//pb else pt = pb//pa end if bk(i) = 0.0d0 bl(i) = 0.0d0 done = .false. c c make a check for bonds contained inside small rings c iring = 0 if (use_ring) then call chkring (iring,ia,ib,0,0) if (iring .eq. 6) iring = 0 if (iring.eq.5 .and. nb5.eq.0) iring = 0 if (iring.eq.4 .and. nb4.eq.0) iring = 0 if (iring.eq.3 .and. nb3.eq.0) iring = 0 end if c c assign bond stretching parameters for each bond c if (iring .eq. 0) then do j = 1, nb if (kb(j) .eq. pt) then bk(i) = bcon(j) bl(i) = blen(j) done = .true. goto 140 end if end do c c assign stretching parameters for 5-membered ring bonds c else if (iring .eq. 5) then do j = 1, nb5 if (kb5(j) .eq. pt) then bk(i) = bcon5(j) bl(i) = blen5(j) done = .true. goto 140 end if end do c c assign stretching parameters for 4-membered ring bonds c else if (iring .eq. 4) then do j = 1, nb4 if (kb4(j) .eq. pt) then bk(i) = bcon4(j) bl(i) = blen4(j) done = .true. goto 140 end if end do c c assign stretching parameters for 3-membered ring bonds c else if (iring .eq. 3) then do j = 1, nb3 if (kb3(j) .eq. pt) then bk(i) = bcon3(j) bl(i) = blen3(j) done = .true. goto 140 end if end do end if c c warning if suitable bond stretching parameter not found c 140 continue minat = min(atomic(ia),atomic(ib)) if (minat .eq. 0) done = .true. if (use_bond .and. .not.done) then if (use(ia) .or. use(ib)) abort = .true. if (header) then header = .false. write (iout,150) 150 format (/,' Undefined Bond Stretching Parameters :', & //,' Type',13x,'Atom Names',11x, & 'Atom Classes',/) end if label = 'Bond ' if (iring .eq. 5) label = '5-Ring' if (iring .eq. 4) label = '4-Ring' if (iring .eq. 3) label = '3-Ring' write (iout,160) label,ia,name(ia),ib,name(ib),ita,itb 160 format (1x,a6,5x,i6,'-',a3,i6,'-',a3,7x,2i5) end if end do c c process keywords containing bond specific parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:5) .eq. 'BOND ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 string = record(next:240) read (string,*,err=170,end=170) ia,ib,fc,bd 170 continue if (min(ia,ib) .lt. 0) then ia = abs(ia) ib = abs(ib) if (header .and. .not.silent) then header = .false. write (iout,180) 180 format (/,' Additional Bond Parameters for', & ' Specific Bonds :', & //,8x,'Atoms',17x,'K(S)',9x,'Length',/) end if if (.not. silent) then write (iout,190) ia,ib,fc,bd 190 format (6x,2i4,5x,f15.3,f15.4) end if do j = 1, nbond ita = ibnd(1,j) itb = ibnd(2,j) if ((ia.eq.ita .and. ib.eq.itb) .or. & (ib.eq.itb .and. ib.eq.ita)) then bk(j) = fc bl(j) = bd goto 200 end if end do end if 200 continue end if end do c c check for electronegativity bond length corrections c call keneg c c turn off the bond stretch potential if it is not used c if (nbond .eq. 0) use_bond = .false. return end c c c ################################################################# c ## ## c ## subroutine keneg -- assign electronegativity parameters ## c ## ## c ################################################################# c c c "keneg" applies primary and secondary electronegativity bond c length corrections to applicable bond parameters c c note this version does not scale multiple corrections to the c same bond by increasing powers of 0.62 as in MM3 c c subroutine keneg use angbnd use atmlst use atomid use bndstr use couple use inform use iounit use kbonds use keys use tors implicit none integer i,j,k,m,nel integer ia,ib,ic,id integer ita,itb,itc,itd integer size,next real*8 dl,factor logical header character*4 pa,pb,pc,pd character*12 blank character*12 pt,pt1,pt2 character*20 keyword character*240 record character*240 string c c c process keywords containing electronegativity parameters c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:9) .eq. 'ELECTNEG ') then ia = 0 ib = 0 ic = 0 dl = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,dl 10 continue if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Electronegativity', & ' Parameters :', & //,5x,'Atom Classes',18x,'dLength',/) end if write (iout,30) ia,ib,ic,dl 30 format (4x,3i4,14x,f12.4) end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) pt = pa//pb//pc do j = 1, maxnel if (kel(j).eq.blank .or. kel(j).eq.pt) then kel(j) = pt dlen(j) = dl goto 50 end if end do write (iout,40) 40 format (/,' KENEG -- Too many Electronegativity', & ' Parameters') abort = .true. 50 continue end if end do c c determine the total number of forcefield parameters c nel = maxnel do i = 1, maxnel if (kel(i) .eq. blank) then nel = i - 1 goto 60 end if end do 60 continue c c check angles for primary electronegativity corrections c if (nel .ne. 0) then do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) pt1 = pa//pb//pc pt2 = pc//pb//pa c c search the parameter set for a match to either bond c do j = 1, nel if (kel(j) .eq. pt1) then do k = 1, n12(ia) if (i12(k,ia) .eq. ib) then m = bndlist(k,ia) bl(m) = bl(m) + dlen(j) end if end do goto 70 else if (kel(j) .eq. pt2) then do k = 1, n12(ic) if (i12(k,ic) .eq. ib) then m = bndlist(k,ic) bl(m) = bl(m) + dlen(j) end if end do goto 70 end if end do 70 continue end do c c check torsions for secondary electronegativity corrections c factor = 0.4d0 do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) pt1 = pa//pb//pd pt2 = pd//pc//pa c c turn off electronegativity effect for attached hydrogens c if (atomic(id) .le. 1) pt1 = blank if (atomic(ia) .le. 1) pt2 = blank c c search the parameter set for a match to either bond c do j = 1, nel if (kel(j) .eq. pt1) then do k = 1, n12(ia) if (i12(k,ia) .eq. ib) then m = bndlist(k,ia) bl(m) = bl(m) + factor*dlen(j) end if end do goto 80 else if (kel(j) .eq. pt2) then do k = 1, n12(id) if (i12(k,id) .eq. ic) then m = bndlist(k,id) bl(m) = bl(m) + factor*dlen(j) end if end do goto 80 end if end do 80 continue end do end if return end c c c ################################################################## c ## ## c ## subroutine kbondm -- assign MMFF bond stretch parameters ## c ## ## c ################################################################## c c c "kbondm" assigns a force constant and ideal bond length to c each bond according to the Merck Molecular Force Field (MMFF) c c literature reference: c c R. Blom and A. Haaland, "A Modification of the Schomaker-Stevenson c Rule for Prediction of Single Bond Distances", Journal of c Molecular Structure, 128, 21-27 (1985) c c subroutine kbondm use atomid use bndstr use keys use merck use potent implicit none integer i,j integer ia,ib integer ita,itb integer next,size integer minat integer, allocatable :: list(:) real*8 khia,khib,cst real*8 rad0a,rad0b logical header,done character*20 keyword character*240 record character*240 string c c c perform dynamic allocation of some local arrays c size = 40 allocate (list(size)) c c get single bonds that could be double (MMFF bond type=1) c nligne = 0 do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:12) .eq. 'MMFF-PIBOND ') then do j = 1, size list(j) = 0 end do string = record(next:240) read (string,*,err=10,end=10) (list(j),j=1,size) 10 continue do j = 1, size, 2 if (list(j).ne.0 .and. list(j+1).ne.0) then nligne = nligne + 1 bt_1(nligne,1) = list(j) bt_1(nligne,2) = list(j+1) else goto 20 end if end do 20 continue end if end do c c perform deallocation of some local arrays c deallocate (list) c c assign MMFF bond length and force constant values c header = .true. do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) ita = class(ia) itb = class(ib) if (ia .le. ib) then do j = 1, nligne if (ia.eq.bt_1(j,1) .and. ib.eq.bt_1(j,2)) then bk(i) = mmff_kb1(ita,itb) bl(i) = mmff_b1(ita,itb) done = .true. if (bk(i) .eq. 1000.0d0) done = .false. if (bl(i) .eq. 1000.0d0) done = .false. goto 30 end if end do bk(i) = mmff_kb(ita,itb) bl(i) = mmff_b0(ita,itb) done = .true. if (bk(i) .eq. 1000.0d0) done = .false. if (bl(i) .eq. 1000.0d0) done = .false. goto 30 else if (ib .le. ia) then do j = 1, nligne if (ib.eq.bt_1(j,1) .and. ia.eq.bt_1(j,2)) then bk(i) = mmff_kb1(itb,ita) bl(i) = mmff_b1(itb,ita) done = .true. if (bk(i) .eq. 1000.0d0) done = .false. if (bl(i) .eq. 1000.0d0) done = .false. goto 30 end if end do bk(i) = mmff_kb(itb,ita) bl(i) = mmff_b0(itb,ita) done = .true. if (bk(i) .eq. 1000.0d0) done = .false. if (bl(i) .eq. 1000.0d0) done = .false. goto 30 end if c c estimate missing bond parameters via an empirical rule c 30 continue minat = min(atomic(ia),atomic(ib)) if (minat .eq. 0) done = .true. if (.not. done) then khia = paulel(atomic(ia)) khib = paulel(atomic(ib)) rad0a = rad0(atomic(ia)) rad0b = rad0(atomic(ib)) cst = 0.085d0 if (atomic(ia).eq.1 .or. atomic(ib).eq.1) cst = 0.05d0 bl(i) = rad0a + rad0b - cst*abs(khia-khib)**1.4d0 bk(i) = kbref(atomic(ia),atomic(ib)) & * (r0ref(atomic(ia),atomic(ib))/bl(i))**6 end if end do c c turn off the bond stretch potential if it is not used c if (nbond .eq. 0) use_bond = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module kbonds -- bond stretching forcefield parameters ## c ## ## c ################################################################ c c c maxnb maximum number of bond stretch parameter entries c maxnb5 maximum number of 5-membered ring bond stretch entries c maxnb4 maximum number of 4-membered ring bond stretch entries c maxnb3 maximum number of 3-membered ring bond stretch entries c maxnel maximum number of electronegativity bond corrections c c bcon force constant parameters for harmonic bond stretch c bcon5 force constant parameters for 5-ring bond stretch c bcon4 force constant parameters for 4-ring bond stretch c bcon3 force constant parameters for 3-ring bond stretch c blen bond length parameters for harmonic bond stretch c blen5 bond length parameters for 5-ring bond stretch c blen4 bond length parameters for 4-ring bond stretch c blen3 bond length parameters for 3-ring bond stretch c dlen electronegativity bond length correction parameters c kb string of atom classes for harmonic bond stretch c kb5 string of atom classes for 5-ring bond stretch c kb4 string of atom classes for 4-ring bond stretch c kb3 string of atom classes for 3-ring bond stretch c kel string of atom classes for electronegativity corrections c c module kbonds implicit none integer maxnb integer maxnb5 integer maxnb4 integer maxnb3 integer maxnel real*8, allocatable :: bcon(:) real*8, allocatable :: bcon5(:) real*8, allocatable :: bcon4(:) real*8, allocatable :: bcon3(:) real*8, allocatable :: blen(:) real*8, allocatable :: blen5(:) real*8, allocatable :: blen4(:) real*8, allocatable :: blen3(:) real*8, allocatable :: dlen(:) character*8, allocatable :: kb(:) character*8, allocatable :: kb5(:) character*8, allocatable :: kb4(:) character*8, allocatable :: kb3(:) character*12, allocatable :: kel(:) save end c c c ########################################################## c ## COPYRIGHT (C) 2020 by Chengwen Liu & Jay W. Ponder ## c ## All Rights Reserved ## c ########################################################## c c ############################################################### c ## ## c ## module kcflux -- charge flux term forcefield parameters ## c ## ## c ############################################################### c c c maxncfb maximum number of bond stretch charge flux entries c maxncfa maximum number of angle bend charge flux entries c c cflb charge flux over stretching of a bond length c cfla charge flux over bending of a bond angle c cflab charge flux over asymmetric bond within an angle c kcfb string of atom classes for bond stretch charge flux c kcfa string of atom classes for angle bend charge flux c c module kcflux implicit none integer maxncfb integer maxncfa real*8, allocatable :: cflb(:) real*8, allocatable :: cfla(:,:) real*8, allocatable :: cflab(:,:) character*8, allocatable :: kcfb(:) character*12, allocatable :: kcfa(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine kcharge -- assign partial charge parameters ## c ## ## c ################################################################ c c c "kcharge" assigns partial charges to the atoms within c the structure and processes any new or changed values c c subroutine kcharge use atomid use atoms use charge use chgpot use couple use fields use inform use iounit use kchrge use keys use potent implicit none integer i,j,k,m integer ia,it,next integer, allocatable :: list(:) integer, allocatable :: nc12(:) real*8 cg logical header character*20 keyword character*240 record character*240 string c c c process keywords containing partial charge parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'CHARGE ') then ia = 0 cg = 0.0d0 string = record(next:240) read (string,*,err=40,end=40) ia,cg if (ia .gt. 0) then if (header .and. .not.silent) then header = .false. write (iout,10) 10 format (/,' Additional Atomic Partial Charge', & ' Parameters :', & //,5x,'Atom Type',14x,'Charge',/) end if if (ia .le. maxtyp) then chg(ia) = cg if (.not. silent) then write (iout,20) ia,cg 20 format (6x,i6,7x,f15.4) end if else write (iout,30) 30 format (/,' KCHARGE -- Too many Partial Charge', & ' Parameters') abort = .true. end if end if 40 continue end if end do c c perform dynamic allocation of some global arrays c if (allocated(iion)) deallocate (iion) if (allocated(jion)) deallocate (jion) if (allocated(kion)) deallocate (kion) if (allocated(pchg)) deallocate (pchg) if (allocated(pchg0)) deallocate (pchg0) allocate (iion(n)) allocate (jion(n)) allocate (kion(n)) allocate (pchg(n)) allocate (pchg0(n)) c c find and store all the atomic partial charges c do i = 1, n pchg(i) = 0.0d0 pchg0(i) = 0.0d0 it = type(i) if (it .ne. 0) then pchg(i) = chg(it) pchg0(i) = pchg(i) end if end do c c use special charge parameter assignment method for MMFF c if (forcefield .eq. 'MMFF94') call kchargem c c process keywords containing atom specific partial charges c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'CHARGE ') then ia = 0 cg = 0.0d0 string = record(next:240) read (string,*,err=70,end=70) ia,cg if (ia.lt.0 .and. ia.ge.-n) then ia = -ia if (header .and. .not.silent) then header = .false. write (iout,50) 50 format (/,' Additional Partial Charges for', & ' Specific Atoms :', & //,8x,'Atom',16x,'Charge',/) end if if (.not. silent) then write (iout,60) ia,cg 60 format (6x,i6,7x,f15.4) end if pchg(ia) = cg end if 70 continue end if end do c c perform dynamic allocation of some local arrays c allocate (list(n)) allocate (nc12(n)) c c remove zero or undefined partial charges from the list c nion = 0 do i = 1, n list(i) = 0 if (pchg(i) .ne. 0.0d0) then nion = nion + 1 iion(nion) = i jion(i) = i kion(i) = i list(i) = nion end if end do c c optionally use neutral groups for neighbors and cutoffs c if (neutnbr .or. neutcut) then do i = 1, n nc12(i) = 0 do j = 1, n12(i) k = list(i12(j,i)) if (k .ne. 0) nc12(i) = nc12(i) + 1 end do end do do i = 1, nion k = iion(i) if (n12(k) .eq. 1) then do j = 1, n12(k) m = i12(j,k) if (nc12(m) .gt. 1) then if (neutnbr) jion(k) = m if (neutcut) kion(k) = m end if end do end if end do end if c c perform deallocation of some local arrays c deallocate (list) deallocate (nc12) c c turn off charge-charge and charge-dipole terms if not used c if (nion .eq. 0) then use_charge = .false. use_chgdpl = .false. end if return end c c c ############################################################## c ## ## c ## subroutine kchargem -- assign MMFF charge parameters ## c ## ## c ############################################################## c c c "kchargem" assigns partial charges to the atoms according to c the Merck Molecular Force Field (MMFF) c c subroutine kchargem use atomid use atoms use charge use couple use merck implicit none integer i,j,k,m integer it,kt,bt integer ic,kc real*8, allocatable :: pbase(:) logical emprule c c c set and store MMFF base atomic partial charge values c do i = 1, n it = type(i) pchg(i) = 0.0d0 if (it .eq. 107) pchg(i) = -0.5d0 if (it .eq. 113) then pchg(i) = 0.0d0 do j = 1, n12(i) k = i12(j,i) kt = type(k) if (kt .eq. 185) pchg(i) = -0.5d0 end do end if if (it .eq. 114) pchg(i) = -1.0d0 / 3.0d0 if (it .eq. 115) pchg(i) = -3.0d0 if (it .eq. 116) pchg(i) = -0.5d0 if (it .eq. 118) pchg(i) = -0.5d0 if (it .eq. 119) pchg(i) = -2.0d0 / 3.0d0 if (it .eq. 121) pchg(i) = -0.25d0 if (it .eq. 123) pchg(i) = 1.0d0 if (it .eq. 124) pchg(i) = -1.0d0 if (it .eq. 125) pchg(i) = -1.0d0 if (it .eq. 154) pchg(i) = 1.0d0 if (it .eq. 156) pchg(i) = 1.0d0 if (it .eq. 159) pchg(i) = 1.0d0 if (it .eq. 160) pchg(i) = 1.0d0 if (it .eq. 161) pchg(i) = 0.5d0 if (it .eq. 162) pchg(i) = 1.0d0 / 3.0d0 if (it .eq. 165) pchg(i) = 1.0d0 if (it .eq. 168) then do j = 1, n12(i) k = i12(j,i) kt = type(k) if (kt.eq.168 .or. kt.eq.142) pchg(i) = 1.0d0 end do end if if (it .eq. 169) pchg(i) = -1.0d0 if (it .eq. 182) pchg(i) = -0.5d0 if (it .eq. 183) then pchg(i) = -1.0d0 do j = 1, n12(i) k = i12(j,i) kt = type(k) if (kt .eq. 87) pchg(i) = -0.5d0 end do end if if (it .eq. 195) pchg(i) = 1.0d0 if (it .eq. 196) pchg(i) = 1.0d0 if (it .eq. 197) pchg(i) = 1.0d0 if (it .eq. 201) pchg(i) = 2.0d0 if (it .eq. 202) pchg(i) = 3.0d0 if (it .eq. 203) pchg(i) = -1.0d0 if (it .eq. 204) pchg(i) = -1.0d0 if (it .eq. 205) pchg(i) = -1.0d0 if (it .eq. 206) pchg(i) = 1.0d0 if (it .eq. 207) pchg(i) = 1.0d0 if (it .eq. 208) pchg(i) = 1.0d0 if (it .eq. 209) pchg(i) = 2.0d0 if (it .eq. 210) pchg(i) = 2.0d0 if (it .eq. 211) pchg(i) = 2.0d0 if (it .eq. 212) pchg(i) = 1.0d0 if (it .eq. 213) pchg(i) = 2.0d0 if (it .eq. 214) pchg(i) = 2.0d0 end do c c perform dynamic allocation of some local arrays c allocate (pbase(n)) c c modify MMFF base charges using a bond increment scheme c do i = 1, n pbase(i) = pchg(i) end do do i = 1, n it = type(i) ic = class(i) if (pbase(i).lt.0.0d0 .or. it.eq.162) then pchg(i) = (1.0d0-crd(ic)*fcadj(ic)) * pbase(i) end if do j = 1, n12(i) k = i12(j,i) kt = type(k) kc = class(k) if (pbase(k).lt.0.0d0 .or. kt.eq.162) then pchg(i) = pchg(i) + fcadj(kc)*pbase(k) end if bt = 0 do m = 1, nligne if ((i.eq.bt_1(m,1) .and. i12(j,i).eq.bt_1(m,2)).or. & (i12(j,i).eq.bt_1(m,1) .and. i.eq.bt_1(m,2))) then bt = 1 end if end do emprule = .false. if (bt .eq. 1) then pchg(i) = pchg(i) + bci_1(kc,ic) if (bci_1(kc,ic) .eq. 1000.0d0) then emprule = .true. goto 10 end if else if (bt .eq. 0) then pchg(i) = pchg(i) + bci(kc,ic) if (bci(kc,ic) .eq. 1000.0d0) then emprule = .true. goto 10 end if end if end do 10 continue if (emprule) then pchg(i) = (1.0d0-crd(ic)*fcadj(ic)) * pbase(i) do j = 1, n12(i) k = i12(j,i) kc = class(k) pchg(i) = pchg(i) + fcadj(kc)*pbase(i12(j,i)) end do do j = 1, n12(i) k = i12(j,i) kc = class(k) bt = 0 do k = 1, nligne if ((i.eq.bt_1(k,1) .and. & i12(j,i).eq.bt_1(k,2)) .or. & (i12(j,i).eq.bt_1(k,1) .and. & i.eq.bt_1(k,2))) then bt = 1 end if end do if (bt .eq. 1) then if (bci_1(kc,ic) .eq. 1000.0d0) then pchg(i) = pchg(i) + pbci(ic) - pbci(kc) else pchg(i) = pchg(i) + bci_1(kc,ic) end if else if (bt .eq. 0) then if (bci(kc,ic) .eq. 1000.0d0) then pchg(i) = pchg(i) + pbci(ic) - pbci(kc) else pchg(i) = pchg(i) + bci(kc,ic) end if end if end do end if end do c c perform deallocation of some local arrays c deallocate (pbase) 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 kchgflx -- charge flux parameter assignment ## c ## ## c ################################################################ c c c "kchgflx" assigns bond stretch and angle bend charge flux c correction values and processes any new or changed values c for these parameters c c subroutine kchgflx use sizes use angbnd use atmlst use atomid use atoms use bndstr use cflux use couple use inform use iounit use kangs use kbonds use kcflux use keys use potent use usage implicit none integer i,j integer ia,ib,ic integer ita,itb,itc integer na,nb integer size,next real*8 cfb real*8 cfa1,cfa2 real*8 cfb1,cfb2 logical headerb logical headera character*4 pa,pb,pc character*8 blank8,pt2 character*12 blank12,pt3 character*20 keyword character*240 record character*240 string c c c process keywords containing charge flux parameters c blank8 = ' ' blank12 = ' ' size = 4 headerb = .true. headera = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:9) .eq. 'BNDCFLUX ') then ia = 0 ib = 0 cfb = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,cfb 10 continue if (headerb .and. .not.silent) then headerb = .false. write (iout,20) 20 format (/,' Additional Bond Charge Flux Parameters :', & //,5x,'Atom Classes',19x,'K(CFB)',/) end if if (.not. silent) then write (iout,30) ia,ib,cfb 30 format (6x,2i4,13x,f15.6) end if call numeral (ia,pa,size) call numeral (ib,pb,size) if (ia .le. ib) then pt2 = pa//pb else pt2 = pb//pa end if do j = 1, maxncfb if (kcfb(j).eq.blank8 .or. kcfb(j).eq.pt2) then kcfb(j) = pt2 if (ia .lt. ib) then cflb(j) = cfb else if (ib .lt. ia) then cflb(j) = -cfb else cflb(j) = 0.0d0 write (iout,40) 40 format (/,' KCHGFLX -- Bond Charge Flux for', & ' Identical Classes Set to Zero') end if goto 50 end if end do 50 continue else if (keyword(1:9) .eq. 'ANGCFLUX ') then ia = 0 ib = 0 ic = 0 cfa1 = 0.0d0 cfa2 = 0.0d0 cfb1 = 0.0d0 cfb2 = 0.0d0 string = record(next:240) read (string,*,err=60,end=60) ia,ib,ic,cfa1,cfa2,cfb1,cfb2 60 continue if (headera .and. .not.silent) then headera = .false. write (iout,70) 70 format (/,' Additional Angle Charge Flux Parameters :', & //,5x,'Atom Classes',10x,'K(CFA1)', & 7x,'K(CFA2)',7x,'K(CFB1)',7x,'K(CFB2)',/) end if if (.not. silent) then write (iout,80) ia,ib,ic,cfa1,cfa2,cfb1,cfb2 80 format (4x,3i4,4x,4f14.6) end if call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) if (ia .le. ic) then pt3 = pa//pb//pc else pt3 = pc//pb//pa end if do j = 1, maxncfa if (kcfa(j).eq.blank12 .or. kcfa(j).eq.pt3) then kcfa(j) = pt3 if (ia .le. ic) then cfla(1,j) = cfa1 cfla(2,j) = cfa2 cflab(1,j) = cfb1 cflab(2,j) = cfb2 else cfla(1,j) = cfa2 cfla(2,j) = cfa1 cflab(1,j) = cfb2 cflab(2,j) = cfb1 end if goto 90 end if end do 90 continue end if end do c c determine the total number of forcefield parameters c nb = maxncfb do i = maxncfb, 1, -1 if (kcfb(i) .eq. blank8) nb = i - 1 end do na = maxncfa do i = maxncfa, 1, -1 if (kcfa(i) .eq. blank12) na = i - 1 end do c c perform dynamic allocation of some global arrays c if (allocated(bflx)) deallocate (bflx) if (allocated(aflx)) deallocate (aflx) if (allocated(abflx)) deallocate (abflx) allocate (bflx(nbond)) allocate (aflx(2,nangle)) allocate (abflx(2,nangle)) c c assign bond charge flux parameters for each bond c nbflx = 0 do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) ita = class(ia) itb = class(ib) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pt2 = pa//pb else pt2 = pb//pa end if bflx(i) = 0.0d0 do j = 1, nb if (kcfb(j) .eq. pt2) then nbflx = nbflx + 1 if (ita .le. itb) then bflx(i) = cflb(j) else bflx(i) = -cflb(j) end if end if end do end do c c assign angle charge flux parameters for each angle c naflx = 0 do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pt3 = pa//pb//pc else pt3 = pc//pb//pa end if aflx(1,i) = 0.0d0 aflx(2,i) = 0.0d0 abflx(1,i) = 0.0d0 abflx(2,i) = 0.0d0 do j = 1, na if (kcfa(j) .eq. pt3) then naflx = naflx + 1 if (ita .le. itc) then aflx(1,i) = cfla(1,j) aflx(2,i) = cfla(2,j) abflx(1,i) = cflab(1,j) abflx(2,i) = cflab(2,j) else aflx(1,i) = cfla(2,j) aflx(2,i) = cfla(1,j) abflx(1,i) = cflab(2,j) abflx(2,i) = cflab(1,j) end if end if end do end do c c turn off bond and angle charge flux term if not used c if (nbflx.eq.0 .and. naflx.eq.0) use_chgflx = .false. if (.not.use_charge .and. .not.use_mpole & .and. .not.use_polar) use_chgflx = .false. 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 kchgtrn -- charge transfer term assignment ## c ## ## c ############################################################### c c c "kchgtrn" assigns charge magnitude and damping parameters for c charge transfer interactions and processes any new or changed c values for these parameters c c subroutine kchgtrn use atomid use atoms use chgpen use chgtrn use expol use inform use iounit use kctrn use keys use mplpot use mpole use polar use polpot use potent use sizes implicit none integer i,k integer ia,ic,next real*8 chtrn,actrn logical header character*20 keyword character*240 record character*240 string c c c process keywords containing charge transfer parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'CHGTRN ') then k = 0 chtrn = 0.0d0 actrn = 0.0d0 call getnumb (record,k,next) string = record(next:240) read (string,*,err=10,end=10) chtrn,actrn 10 continue if (k .gt. 0) then if (header .and. .not.silent) then header = .false. write (iout,20) 20 format (/,' Additional Charge Transfer', & ' Parameters :', & //,5x,'Atom Class',13x,'Charge',11x,'Damp',/) end if if (k .le. maxclass) then ctchg(k) = chtrn ctdmp(k) = actrn if (.not. silent) then write (iout,30) k,chtrn,actrn 30 format (6x,i6,7x,f15.4,f15.4) end if else write (iout,40) 40 format (/,' KCHGTRN -- Too many Charge', & ' Transfer Parameters') abort = .true. end if end if end if end do c c perform dynamic allocation of some global arrays c if (allocated(chgct)) deallocate (chgct) if (allocated(dmpct)) deallocate (dmpct) allocate (chgct(n)) allocate (dmpct(n)) c c assign the charge transfer charge and alpha parameters c nct = n do i = 1, n ic = class(i) chgct(i) = ctchg(ic) dmpct(i) = ctdmp(ic) end do c c process keywords containing atom specific charge transfer c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'CHGTRN ') then ia = 0 chtrn = 0.0d0 actrn = 0.0d0 string = record(next:240) read (string,*,err=70,end=70) ia,chtrn,actrn if (ia.lt.0 .and. ia.ge.-n) then ia = -ia if (header .and. .not.silent) then header = .false. write (iout,50) 50 format (/,' Additional Charge Transfer Values', & ' for Specific Atoms :', & //,8x,'Atom',16x,'Charge',11x,'Damp',/) end if if (.not. silent) then write (iout,60) ia,chtrn,actrn 60 format (6x,i6,7x,f15.4,f15.4) end if chgct(ia) = chtrn dmpct(ia) = actrn end if 70 continue end if end do c c remove zero or undefined electrostatic sites from the list c if (use_chgtrn) then npole = 0 ncp = 0 npolar = 0 nexpol = 0 nct = 0 do i = 1, n if (polarity(i) .eq. 0.0d0) douind(i) = .false. if (polsiz(i).ne.0 .or. polarity(i).ne.0.0d0 .or. & chgct(i).ne.0.0d0 .or. dmpct(i).ne.0.0d0) then npole = npole + 1 ipole(npole) = i pollist(i) = npole mono0(i) = pole(1,i) if (palpha(i) .ne. 0.0d0) ncp = ncp + 1 if (polarity(i) .ne. 0.0d0) then npolar = npolar + 1 ipolar(npolar) = npole douind(i) = .true. end if if (tholed(i) .ne. 0.0d0) use_tholed = .true. if (kpep(i) .ne. 0.0d0) nexpol = nexpol + 1 if (chgct(i).ne.0.0d0 .or. dmpct(i).ne.0.0d0) then nct = nct + 1 end if end if end do end if c c test multipoles at chiral sites and invert if necessary c if (use_chgtrn) call chkpole c c turn off individual electrostatic potentials if not used c if (npole .eq. 0) use_mpole = .false. if (npolar .eq. 0) use_polar = .false. if (ncp .ne. 0) use_chgpen = .true. if (ncp .ne. 0) use_thole = .false. if (use_tholed) use_thole = .true. if (nexpol .ne. 0) use_expol = .true. if (nct .eq. 0) use_chgtrn = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module kchrge -- partial charge forcefield parameters ## c ## ## c ############################################################### c c c chg partial charge parameters for each atom type c c module kchrge implicit none real*8, allocatable :: chg(:) 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 kcpen -- charge penetration forcefield parameters ## c ## ## c ################################################################## c c c cpele valence electron magnitude for each atom class c cpalp alpha charge penetration parameter for each atom class c c module kcpen implicit none real*8, allocatable :: cpele(:) real*8, allocatable :: cpalp(:) 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 kctrn -- charge transfer forcefield parameters ## c ## ## c ############################################################### c c c ctchg charge transfer magnitude for each atom class c ctdmp alpha charge transfer parameter for each atom class c c module kctrn implicit none real*8, allocatable :: ctchg(:) real*8, allocatable :: ctdmp(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## module kdipol -- bond dipole forcefield parameters ## c ## ## c ############################################################ c c c maxnd maximum number of bond dipole parameter entries c maxnd5 maximum number of 5-membered ring dipole entries c maxnd4 maximum number of 4-membered ring dipole entries c maxnd3 maximum number of 3-membered ring dipole entries c c dpl dipole moment parameters for bond dipoles c dpl5 dipole moment parameters for 5-ring dipoles c dpl4 dipole moment parameters for 4-ring dipoles c dpl3 dipole moment parameters for 3-ring dipoles c pos dipole position parameters for bond dipoles c pos5 dipole position parameters for 5-ring dipoles c pos4 dipole position parameters for 4-ring dipoles c pos3 dipole position parameters for 3-ring dipoles c kd string of atom classes for bond dipoles c kd5 string of atom classes for 5-ring dipoles c kd4 string of atom classes for 4-ring dipoles c kd3 string of atom classes for 3-ring dipoles c c module kdipol implicit none integer maxnd integer maxnd5 integer maxnd4 integer maxnd3 real*8, allocatable :: dpl(:) real*8, allocatable :: dpl5(:) real*8, allocatable :: dpl4(:) real*8, allocatable :: dpl3(:) real*8, allocatable :: pos(:) real*8, allocatable :: pos5(:) real*8, allocatable :: pos4(:) real*8, allocatable :: pos3(:) character*8, allocatable :: kd(:) character*8, allocatable :: kd5(:) character*8, allocatable :: kd4(:) character*8, allocatable :: kd3(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine kdipole -- assign bond dipole parameters ## c ## ## c ############################################################# c c c "kdipole" assigns bond dipoles to the bonds within c the structure and processes any new or changed values c c subroutine kdipole use atmlst use atoms use bndstr use couple use dipole use inform use iounit use kdipol use keys use potent implicit none integer i,j,k integer ia,ib,ita,itb integer nd,nd5,nd4,nd3 integer iring,size,next real*8 dp,ps logical header logical use_ring character*4 pa,pb character*6 label character*8 blank,pt character*20 keyword character*240 record character*240 string c c c process keywords containing bond dipole parameters c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) iring = -1 if (keyword(1:7) .eq. 'DIPOLE ') iring = 0 if (keyword(1:8) .eq. 'DIPOLE5 ') iring = 5 if (keyword(1:8) .eq. 'DIPOLE4 ') iring = 4 if (keyword(1:8) .eq. 'DIPOLE3 ') iring = 3 if (iring .ge. 0) then ia = 0 ib = 0 dp = 0.0d0 ps = 0.5d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,dp,ps 10 continue if (ia.gt.0 .and. ib.gt.0) then if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Bond Dipole Moment ', & 'Parameters :', & //,5x,'Atom Types',13x,'Moment', & 8x,'Position',/) end if if (iring .eq. 0) then write (iout,30) ia,ib,dp,ps 30 format (6x,2i4,5x,2f15.3) else if (iring .eq. 5) label = '5-Ring' if (iring .eq. 4) label = '4-Ring' if (iring .eq. 3) label = '3-Ring' write (iout,40) ia,ib,dp,ps,label 40 format (6x,2i4,5x,2f15.3,3x,a6) end if end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) if (ia .le. ib) then pt = pa//pb else pt = pb//pa end if if (iring .eq. 0) then do j = 1, maxnd if (kd(j).eq.blank .or. kd(j).eq.pt) then kd(j) = pt if (ia .le. ib) then dpl(j) = dp pos(j) = ps else dpl(j) = -dp pos(j) = 1.0d0 - ps end if goto 90 end if end do write (iout,50) 50 format (/,' KDIPOLE -- Too many Bond Dipole', & ' Moment Parameters') abort = .true. else if (iring .eq. 5) then do j = 1, maxnd5 if (kd5(j).eq.blank .or. kd5(j).eq.pt) then kd5(j) = pt if (ia .le. ib) then dpl5(j) = dp pos5(j) = ps else dpl5(j) = -dp pos5(j) = 1.0d0 - ps end if goto 90 end if end do write (iout,60) 60 format (/,' KDIPOLE -- Too many 5-Ring Bond', & ' Dipole Parameters') abort = .true. else if (iring .eq. 4) then do j = 1, maxnd4 if (kd4(j).eq.blank .or. kd4(j).eq.pt) then kd4(j) = pt if (ia .le. ib) then dpl4(j) = dp pos4(j) = ps else dpl4(j) = -dp pos4(j) = 1.0d0 - ps end if goto 90 end if end do write (iout,70) 70 format (/,' KDIPOLE -- Too many 4-Ring Bond', & ' Dipole Parameters') abort = .true. else if (iring .eq. 3) then do j = 1, maxnd3 if (kd3(j).eq.blank .or. kd3(j).eq.pt) then kd3(j) = pt if (ia .le. ib) then dpl3(j) = dp pos3(j) = ps else dpl3(j) = -dp pos3(j) = 1.0d0 - ps end if goto 90 end if end do write (iout,80) 80 format (/,' KDIPOLE -- Too many 3-Ring Bond', & ' Dipole Parameters') abort = .true. end if end if 90 continue end if end do c c determine the total number of forcefield parameters c nd = maxnd nd5 = maxnd5 nd4 = maxnd4 nd3 = maxnd3 do i = maxnd, 1, -1 if (kd(i) .eq. blank) nd = i - 1 end do do i = maxnd5, 1, -1 if (kd5(i) .eq. blank) nd5 = i - 1 end do do i = maxnd4, 1, -1 if (kd4(i) .eq. blank) nd4 = i - 1 end do do i = maxnd3, 1, -1 if (kd3(i) .eq. blank) nd3 = i - 1 end do use_ring = .false. if (min(nd5,nd4,nd3) .ne. 0) use_ring = .true. c c perform dynamic allocation of some global arrays c if (allocated(idpl)) deallocate (idpl) if (allocated(bdpl)) deallocate (bdpl) if (allocated(sdpl)) deallocate (sdpl) allocate (idpl(2,nbond)) allocate (bdpl(nbond)) allocate (sdpl(nbond)) c c find and store all the bond dipole moments c do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) ita = type(ia) itb = type(ib) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pt = pa//pb else pt = pb//pa end if bdpl(i) = 0.0d0 c c make a check for bonds contained inside small rings c iring = 0 if (use_ring) then call chkring (iring,ia,ib,0,0) if (iring .eq. 6) iring = 0 if (iring.eq.5 .and. nd5.eq.0) iring = 0 if (iring.eq.4 .and. nd4.eq.0) iring = 0 if (iring.eq.3 .and. nd3.eq.0) iring = 0 end if c c try to assign bond dipole parameters for the bond c if (iring .eq. 0) then do j = 1, nd if (kd(j) .eq. pt) then if (ita .le. itb) then idpl(1,i) = ia idpl(2,i) = ib else idpl(1,i) = ib idpl(2,i) = ia end if bdpl(i) = dpl(j) sdpl(i) = pos(j) goto 100 end if end do else if (iring .eq. 5) then do j = 1, nd5 if (kd5(j) .eq. pt) then if (ita .le. itb) then idpl(1,i) = ia idpl(2,i) = ib else idpl(1,i) = ib idpl(2,i) = ia end if bdpl(i) = dpl5(j) sdpl(i) = pos5(j) goto 100 end if end do else if (iring .eq. 4) then do j = 1, nd4 if (kd4(j) .eq. pt) then if (ita .le. itb) then idpl(1,i) = ia idpl(2,i) = ib else idpl(1,i) = ib idpl(2,i) = ia end if bdpl(i) = dpl4(j) sdpl(i) = pos4(j) goto 100 end if end do else if (iring .eq. 3) then do j = 1, nd3 if (kd3(j) .eq. pt) then if (ita .le. itb) then idpl(1,i) = ia idpl(2,i) = ib else idpl(1,i) = ib idpl(2,i) = ia end if bdpl(i) = dpl3(j) sdpl(i) = pos3(j) goto 100 end if end do end if 100 continue end do c c process keywords containing bond specific bond dipoles c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'DIPOLE ') then ia = 0 ib = 0 dp = 0.0d0 ps = 0.0d0 string = record(next:240) read (string,*,err=110,end=110) ia,ib,dp,ps 110 continue if (ia.lt.0 .and. ib.lt.0) then ia = -ia ib = -ib if (header .and. .not.silent) then header = .false. write (iout,120) 120 format (/,' Additional Bond Dipoles for', & ' Specific Bonds :', & //,5x,'Bonded Atoms',11x,'Moment', & 8x,'Position',/) end if do j = 1, n12(ia) if (i12(j,ia) .eq. ib) then k = bndlist(j,ia) if (ps .eq. 0.0d0) ps = 0.5d0 if (idpl(1,k) .eq. ib) then bdpl(k) = dp sdpl(k) = ps else bdpl(k) = -dp sdpl(k) = 1.0d0 - ps end if if (.not. silent) then write (iout,130) ia,ib,dp,ps 130 format (4x,i5,' -',i5,3x,2f15.3) end if goto 140 end if end do end if 140 continue end if end do c c remove zero bond dipoles from the list of dipoles c ndipole = 0 do i = 1, nbond if (bdpl(i) .ne. 0.0d0) then ndipole = ndipole + 1 idpl(1,ndipole) = idpl(1,i) idpl(2,ndipole) = idpl(2,i) bdpl(ndipole) = bdpl(i) sdpl(ndipole) = sdpl(i) end if end do c c turn off dipole-dipole and charge-dipole terms if not used c if (ndipole .eq. 0) then use_dipole = .false. use_chgdpl = .false. 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 kdisp -- dispersion parameter assignment ## c ## ## c ############################################################# c c c "kdisp" assigns C6 coefficients and damping parameters for c dispersion interactions and processes any new or changed c values for these parameters c c subroutine kdisp use atomid use atoms use disp use dsppot use inform use iounit use kdsp use keys use limits use potent use sizes implicit none integer i,k,ii,kk integer ia,ic,next real*8 cs,adsp real*8 csixi logical header character*20 keyword character*240 record character*240 string c c c process keywords containing damped dispersion parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:11) .eq. 'DISPERSION ') then k = 0 cs = 0.0d0 adsp = 0.0d0 call getnumb (record,k,next) string = record(next:240) read (string,*,err=10,end=10) cs,adsp 10 continue if (k .gt. 0) then if (header .and. .not.silent) then header = .false. write (iout,20) 20 format (/,' Additional Damped Dispersion', & ' Parameters :', & //,5x,'Atom Class',16x,'C6',12x,'Damp',/) end if if (k .le. maxclass) then dspsix(k) = cs dspdmp(k) = adsp if (.not. silent) then write (iout,30) k,cs,adsp 30 format (6x,i6,7x,f15.4,f15.4) end if else write (iout,40) 40 format (/,' KDISP -- Too many Damped', & ' Dispersion Parameters') abort = .true. end if end if end if end do c c perform dynamic allocation of some global arrays c if (allocated(idisp)) deallocate (idisp) if (allocated(csix)) deallocate (csix) if (allocated(adisp)) deallocate (adisp) allocate (idisp(n)) allocate (csix(n)) allocate (adisp(n)) c c assign the dispersion C6 values and alpha parameters c do i = 1, n csix(i) = 0.0d0 adisp(i) = 0.0d0 ic = class(i) if (ic .ne. 0) then csix(i) = dspsix(ic) adisp(i) = dspdmp(ic) end if end do c c process keywords containing atom specific dispersion parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:11) .eq. 'DISPERSION ') then ia = 0 cs = 0.0d0 adsp = 0.0d0 string = record(next:240) read (string,*,err=70,end=70) ia,cs,adsp if (ia.lt.0 .and. ia.ge.-n) then ia = -ia if (header .and. .not.silent) then header = .false. write (iout,50) 50 format (/,' Additional Dispersion Values for', & ' Specific Atoms :', & //,8x,'Atom',19x,'C6',12x,'Damp',/) end if if (.not. silent) then write (iout,60) ia,cs,adsp 60 format (6x,i6,7x,f15.4,f15.4) end if csix(ia) = cs adisp(ia) = adsp end if 70 continue end if end do c c remove zero and undefined dispersion sites from the list c ndisp = 0 do i = 1, n if (csix(i) .ne. 0.0d0) then ndisp = ndisp + 1 idisp(ndisp) = i end if end do c c compute pairwise sum of C6 coefficients needed for PME c csixpr = 0.0d0 if (use_dewald) then do ii = 1, ndisp i = idisp(ii) csixi = csix(i) do kk = 1, ndisp k = idisp(kk) csixpr = csixpr + csixi*csix(k) end do end do end if c c turn off the dispersion potential if not used c if (ndisp .eq. 0) use_disp = .false. return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################ c ## ## c ## module kdsp -- damped dispersion forcefield parameters ## c ## ## c ################################################################ c c c dspsix C6 dispersion coefficient for each atom class c dspdmp alpha dispersion parameter for each atom class c c module kdsp implicit none real*8, allocatable :: dspsix(:) real*8, allocatable :: dspdmp(:) save end c c c ################################################### c ## COPYRIGHT (C) 1999 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine kewald -- setup for particle mesh Ewald sum ## c ## ## c ################################################################ c c c "kewald" assigns particle mesh Ewald parameters and options c for a periodic system c c subroutine kewald use atoms use bound use boxes use chunks use ewald use fft use inform use iounit use keys use limits use openmp use pme use potent implicit none integer maxpower integer maxfft parameter (maxpower=63) parameter (maxfft=864) integer i,k,next integer nbig,minfft integer iefft1,idfft1 integer iefft2,idfft2 integer iefft3,idfft3 integer multi(maxpower) real*8 delta,rmax real*8 edens,ddens real*8 size,slope real*8 fft1,fft2,fft3 character*20 keyword character*240 record character*240 string c c PME grid size must be even with factors of only 2, 3 and 5 c data multi / 2, 4, 6, 8, 10, 12, 16, 18, 20, & 24, 30, 32, 36, 40, 48, 50, 54, 60, & 64, 72, 80, 90, 96, 100, 108, 120, 128, & 144, 150, 160, 162, 180, 192, 200, 216, 240, & 250, 256, 270, 288, 300, 320, 324, 360, 384, & 400, 432, 450, 480, 486, 500, 512, 540, 576, & 600, 640, 648, 720, 750, 768, 800, 810, 864 / c c c return if Ewald summation is not being used c if (.not.use_ewald .and. .not.use_dewald) return c c set default values for Ewald options and parameters c ffttyp = 'FFTPACK' if (nthread .gt. 1) ffttyp = 'FFTW' boundary = 'TINFOIL' bseorder = 5 bsporder = 5 bsdorder = 4 edens = 1.2d0 ddens = 0.8d0 aeewald = 0.4d0 apewald = 0.4d0 adewald = 0.4d0 minfft = 16 c c estimate optimal values for the Ewald coefficient c if (use_ewald) call ewaldcof (aeewald,ewaldcut) if (use_dewald) call ewaldcof (adewald,dewaldcut) if (use_ewald .and. use_polar) apewald = aeewald c c modify Ewald coefficient for small unitcell dimensions c if (use_polar .and. use_bounds) then size = min(xbox,ybox,zbox) if (size .lt. 6.0d0) then slope = (1.0d0-apewald) / 2.0d0 apewald = apewald + slope*(6.0d0-size) minfft = 64 if (verbose) then write (iout,10) 10 format (/,' KEWALD -- Warning, PME Grid Expanded', & ' due to Small Cell Size') end if end if end if c c set the system extent for nonperiodic Ewald summation c if (.not. use_bounds) then call extent (rmax) xbox = 2.0d0 * (rmax+max(ewaldcut,dewaldcut)) ybox = xbox zbox = xbox alpha = 90.0d0 beta = 90.0d0 gamma = 90.0d0 orthogonal = .true. call lattice boundary = 'NONE' edens = 0.7d0 ddens = 0.7d0 end if c c set defaults for electrostatic and dispersion grid sizes c nefft1 = 0 nefft2 = 0 nefft3 = 0 ndfft1 = 0 ndfft2 = 0 ndfft3 = 0 c c get default grid counts from periodic system dimensions c delta = 1.0d-8 iefft1 = int(xbox*edens-delta) + 1 iefft2 = int(ybox*edens-delta) + 1 iefft3 = int(zbox*edens-delta) + 1 idfft1 = int(xbox*ddens-delta) + 1 idfft2 = int(ybox*ddens-delta) + 1 idfft3 = int(zbox*ddens-delta) + 1 c c search keywords for Ewald summation commands c do i = 1, nkey record = keyline(i) next = 1 call upcase (record) call gettext (record,keyword,next) string = record(next:240) if (keyword(1:12) .eq. 'FFT-PACKAGE ') then call getword (record,ffttyp,next) else if (keyword(1:12) .eq. 'EWALD-ALPHA ') then read (string,*,err=40,end=40) aeewald else if (keyword(1:13) .eq. 'PEWALD-ALPHA ') then read (string,*,err=40,end=40) apewald else if (keyword(1:13) .eq. 'DEWALD-ALPHA ') then read (string,*,err=40,end=40) adewald else if (keyword(1:15) .eq. 'EWALD-BOUNDARY ') then boundary = 'VACUUM' else if (keyword(1:9) .eq. 'PME-GRID ') then fft1 = 0.0d0 fft2 = 0.0d0 fft3 = 0.0d0 read (string,*,err=20,end=20) fft1,fft2,fft3 20 continue iefft1 = nint(fft1) iefft2 = nint(fft2) iefft3 = nint(fft3) if (iefft2 .eq. 0) iefft2 = iefft1 if (iefft3 .eq. 0) iefft3 = iefft1 else if (keyword(1:10) .eq. 'DPME-GRID ') then fft1 = 0.0d0 fft2 = 0.0d0 fft3 = 0.0d0 read (string,*,err=30,end=30) fft1,fft2,fft3 30 continue idfft1 = nint(fft1) idfft2 = nint(fft2) idfft3 = nint(fft3) if (idfft2 .eq. 0) idfft2 = idfft1 if (idfft3 .eq. 0) idfft3 = idfft1 else if (keyword(1:10) .eq. 'PME-ORDER ') then read (string,*,err=40,end=40) bseorder else if (keyword(1:11) .eq. 'PPME-ORDER ') then read (string,*,err=40,end=40) bsporder else if (keyword(1:11) .eq. 'DPME-ORDER ') then read (string,*,err=40,end=40) bsdorder end if 40 continue end do c c determine electrostatic grid size from allowed values c if (use_ewald) then nefft1 = maxfft nefft2 = maxfft nefft3 = maxfft do i = maxpower, 1, -1 k = multi(i) if (k .le. maxfft) then if (k .ge. iefft1) nefft1 = k if (k .ge. iefft2) nefft2 = k if (k .ge. iefft3) nefft3 = k end if end do if (nefft1 .lt. minfft) nefft1 = minfft if (nefft2 .lt. minfft) nefft2 = minfft if (nefft3 .lt. minfft) nefft3 = minfft end if c c determine dispersion grid size from allowed values c if (use_dewald) then ndfft1 = maxfft ndfft2 = maxfft ndfft3 = maxfft do i = maxpower, 1, -1 k = multi(i) if (k .le. maxfft) then if (k .ge. idfft1) ndfft1 = k if (k .ge. idfft2) ndfft2 = k if (k .ge. idfft3) ndfft3 = k end if end do if (ndfft1 .lt. minfft) ndfft1 = minfft if (ndfft2 .lt. minfft) ndfft2 = minfft if (ndfft3 .lt. minfft) ndfft3 = minfft end if c c check the particle mesh Ewald grid dimensions c nbig = max(nefft1,nefft2,nefft3,ndfft1,ndfft2,ndfft3) if (nbig .gt. maxfft) then write (iout,50) 50 format (/,' KEWALD -- PME Grid Size Too Large;', & ' Increase MAXFFT') call fatal end if if (use_ewald .and. (nefft1.lt.iefft1.or. & nefft2.lt.iefft2.or.nefft3.lt.iefft3)) then write (iout,60) 60 format (/,' KEWALD -- Warning, Small Electrostatic', & 'PME Grid Size') end if if (use_dewald .and. (ndfft1.lt.idfft1.or. & ndfft2.lt.idfft2.or.ndfft3.lt.idfft3)) then write (iout,70) 70 format (/,' KEWALD -- Warning, Small Dispersion', & 'PME Grid Size') end if c c set maximum sizes for PME grid and B-spline order c nfft1 = max(nefft1,ndfft1) nfft2 = max(nefft2,ndfft2) nfft3 = max(nefft3,ndfft3) bsorder = max(bseorder,bsporder,bsdorder) c c perform dynamic allocation of some global arrays c if (allocated(bsmod1)) deallocate (bsmod1) if (allocated(bsmod2)) deallocate (bsmod2) if (allocated(bsmod3)) deallocate (bsmod3) if (allocated(bsbuild)) deallocate (bsbuild) if (allocated(thetai1)) deallocate (thetai1) if (allocated(thetai2)) deallocate (thetai2) if (allocated(thetai3)) deallocate (thetai3) if (allocated(pmetable)) deallocate (pmetable) allocate (bsmod1(nfft1)) allocate (bsmod2(nfft2)) allocate (bsmod3(nfft3)) allocate (bsbuild(bsorder,bsorder)) allocate (thetai1(4,bsorder,n)) allocate (thetai2(4,bsorder,n)) allocate (thetai3(4,bsorder,n)) allocate (pmetable(n,6*nthread)) c c print a message listing some of the Ewald parameters c if (verbose) then write (iout,80) 80 format (/,' Particle Mesh Ewald Parameters :', & //,5x,'Type',16x,'Ewald Alpha',4x,'Grid', & ' Dimensions',4x,'Spline Order',/) if (use_ewald) then write (iout,90) aeewald,nefft1,nefft2,nefft3,bseorder 90 format (3x,'Electrostatics',9x,f8.4,5x,3i5,7x,i5) if (use_polar) then write (iout,100) apewald,nefft1,nefft2,nefft3,bsporder 100 format (3x,'Polarization',11x,f8.4,5x,3i5,7x,i5) end if end if if (use_dewald) then write (iout,110) adewald,ndfft1,ndfft2,ndfft3,bsdorder 110 format (3x,'Dispersion',13x,f8.4,5x,3i5,7x,i5) end if end if return end c c c ################################################################ c ## ## c ## subroutine ewaldcof -- estimation of Ewald coefficient ## c ## ## c ################################################################ c c c "ewaldcof" finds an Ewald coefficient such that all terms c beyond the specified cutoff distance will have a value less c than a specified tolerance c c subroutine ewaldcof (alpha,cutoff) implicit none integer i,k real*8 alpha,cutoff,eps real*8 x,xlo,xhi,y real*8 ratio,erfc external erfc c c c set tolerance value; use of 1.0d-8 over 1.0d-6 gives c larger Ewald coefficients to ensure gradient continuity c eps = 1.0d-8 c c get approximate value from cutoff and tolerance c ratio = eps + 1.0d0 x = 0.5d0 i = 0 do while (ratio .ge. eps) i = i + 1 x = 2.0d0 * x y = x * cutoff ratio = erfc(y) / cutoff end do c c use a binary search to refine the coefficient c k = i + 60 xlo = 0.0d0 xhi = x do i = 1, k x = (xlo+xhi) / 2.0d0 y = x * cutoff ratio = erfc(y) / cutoff if (ratio .ge. eps) then xlo = x else xhi = x end if end do alpha = x return end c c c ################################################################ c ## ## c ## subroutine extent -- find maximum interatomic distance ## c ## ## c ################################################################ c c c "extent" finds the largest interatomic distance in a system c c subroutine extent (rmax) use atoms implicit none integer i,k real*8 xi,yi,zi real*8 xk,yk,zk real*8 r2,rmax c c c search all atom pairs to find the largest distance c rmax = 0.0d0 do i = 1, n-1 xi = x(i) yi = y(i) zi = z(i) do k = i+1, n xk = x(k) yk = y(k) zk = z(k) r2 = (xk-xi)**2 + (yk-yi)**2 + (zk-zi)**2 rmax = max(r2,rmax) end do end do rmax = sqrt(rmax) 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 ## module kexpl -- exch-polarization forcefield parameters ## c ## ## c ################################################################# c c c pepk exchange-polarization spring constant for atom classes c peppre exchange-polarization prefactor for atom classes c pepdmp exchange-polarization damping alpha for atom classes c pepl exchange-polarization logical flag for atom classes c c module kexpl implicit none real*8, allocatable :: pepk(:) real*8, allocatable :: peppre(:) real*8, allocatable :: pepdmp(:) logical, allocatable :: pepl(:) 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 kexpol -- exch-polar parameter assignment ## c ## ## c ############################################################## c c c "kexpol" assigns the constant prefactor and damping alpha for c exchange polarization interactions and processes any new or c changed values for these parameters c c subroutine kexpol use atomid use atoms use expol use inform use iounit use kexpl use keys use sizes implicit none integer i,k,ia,ic integer ilpr,next real*8 kpr,ppr,apr logical header logical lpr character*20 keyword character*240 record character*240 string c c c process keywords containing exchange polarization parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:8) .eq. 'EXCHPOL ') then k = 0 kpr = 0.0d0 ppr = 0.0d0 apr = 0.0d0 ilpr = 0 lpr = .false. call getnumb (record,k,next) string = record(next:240) read (string,*,err=10,end=10) kpr,ppr,apr,ilpr if (ilpr .ne. 0) lpr = .true. 10 continue if (k .gt. 0) then if (header .and. .not.silent) then header = .false. write (iout,20) 20 format (/,' Additional Exchange Polarization', & ' Parameters :', & //,5x,'Atom Class',7x,'Spring',8x,'Size', & 8x,'Damp',8x,'Use',/) end if if (k .le. maxclass) then pepk(k) = kpr peppre(k) = ppr pepdmp(k) = apr pepl(k) = lpr if (.not. silent) then write (iout,30) k,kpr,ppr,apr,lpr 30 format (6x,i6,4x,2f12.4,f12.3,9x,l1) end if else write (iout,40) 40 format (/,' KEXPOL -- Too many Exch Polarization', & ' Parameters') abort = .true. end if end if end if end do c c perform dynamic allocation of some global arrays c if (allocated(kpep)) deallocate (kpep) if (allocated(prepep)) deallocate (prepep) if (allocated(dmppep)) deallocate (dmppep) if (allocated(lpep)) deallocate (lpep) if (allocated(polscale)) deallocate (polscale) if (allocated(polinv)) deallocate (polinv) allocate (kpep(n)) allocate (prepep(n)) allocate (dmppep(n)) allocate (lpep(n)) allocate (polscale(3,3,n)) allocate (polinv(3,3,n)) c c assign the spring constant, prefactor and alpha parameters c do i = 1, n kpep(i) = 0.0d0 prepep(i) = 0.0d0 dmppep(i) = 0.0d0 lpep(i) = .false. ic = class(i) if (ic .ne. 0) then kpep(i) = pepk(ic) prepep(i) = peppre(ic) dmppep(i) = pepdmp(ic) lpep(i) = pepl(ic) end if end do c c process keywords containing atom specific exchange polarization c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:8) .eq. 'EXCHPOL ') then ia = 0 kpr = 0.0d0 ppr = 0.0d0 apr = 0.0d0 ilpr = 0 lpr = .false. string = record(next:240) read (string,*,err=70,end=70) ia,kpr,ppr,apr,ilpr if (ilpr .ne. 0) lpr = .true. if (ia.lt.0 .and. ia.ge.-n) then ia = -ia if (header .and. .not.silent) then header = .false. write (iout,50) 50 format (/,' Additional Exchange Polarization Values', & ' for Specific Atoms :', & //,8x,'Atom',10x,'Spring',8x,'Size', & 8x,'Damp',8x,'On'/) end if if (.not. silent) then write (iout,60) ia,kpr,ppr,apr,lpr 60 format (6x,i6,4x,2f12.4,f12.3,9x,l1) end if kpep(ia) = kpr prepep(ia) = ppr dmppep(ia) = apr lpep(ia) = lpr end if 70 continue end if end do return end c c c ################################################### c ## COPYRIGHT (C) 2012 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine kextra -- extra term parameter assignment ## c ## ## c ############################################################## c c c "kextra" assigns parameters to any additional user defined c potential energy contribution c c subroutine kextra implicit none c c c add any setup for user-defined extra potential below here c return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## module keys -- contents of the keyword control file ## c ## ## c ############################################################# c c c maxkey maximum number of lines in the keyword file c c nkey number of nonblank lines in the keyword file c keyline contents of each individual keyword file line c c module keys implicit none integer maxkey parameter (maxkey=25000) integer nkey character*240 keyline(maxkey) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine kgeom -- restraint term parameter assignment ## c ## ## c ################################################################# c c c "kgeom" asisgns parameters for geometric restraint terms c to be included in the potential energy calculation c c subroutine kgeom use atomid use atoms use bound use couple use group use iounit use keys use molcul use potent use restrn implicit none integer i,j,k,next integer ia,ib,ic,id real*8 p1,p2,p3,p4,p5 real*8 d1,d2,d3 real*8 a1,a2,a3 real*8 t1,t2,t3 real*8 g1,g2,g3 real*8 xr,yr,zr real*8 xcm,ycm,zcm real*8 geometry,weigh real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 c1,c2,c3 real*8 vol,ratio logical exist,keep logical intermol character*1 letter character*20 keyword character*240 record character*240 string c c c set the default values for the restraint variables c npfix = 0 ndfix = 0 nafix = 0 ntfix = 0 ngfix = 0 nchir = 0 depth = 0.0d0 width = 0.0d0 rflat = 0.0d0 rwall = 0.0d0 use_basin = .false. use_wall = .false. c c perform dynamic allocation of some global arrays c if (.not. allocated(ipfix)) allocate (ipfix(maxfix)) if (.not. allocated(kpfix)) allocate (kpfix(3,maxfix)) if (.not. allocated(idfix)) allocate (idfix(2,maxfix)) if (.not. allocated(iafix)) allocate (iafix(3,maxfix)) if (.not. allocated(itfix)) allocate (itfix(4,maxfix)) if (.not. allocated(igfix)) allocate (igfix(2,maxfix)) if (.not. allocated(xpfix)) allocate (xpfix(maxfix)) if (.not. allocated(ypfix)) allocate (ypfix(maxfix)) if (.not. allocated(zpfix)) allocate (zpfix(maxfix)) if (.not. allocated(pfix)) allocate (pfix(2,maxfix)) if (.not. allocated(dfix)) allocate (dfix(3,maxfix)) if (.not. allocated(afix)) allocate (afix(3,maxfix)) if (.not. allocated(tfix)) allocate (tfix(3,maxfix)) if (.not. allocated(gfix)) allocate (gfix(3,maxfix)) c c search the keywords for restraint 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 atom restrained to a specified position range c if (keyword(1:18) .eq. 'RESTRAIN-POSITION ') then ia = 0 ib = 0 p1 = 0.0d0 p2 = 0.0d0 p3 = 0.0d0 p4 = 0.0d0 p5 = 0.0d0 next = 1 call getnumb (string,ia,next) if (ia.ge.1 .and. ia.le.n) then p1 = x(ia) p2 = y(ia) p3 = z(ia) string = string(next:240) read (string,*,err=10,end=10) p1,p2,p3,p4,p5 10 continue if (p4 .eq. 0.0d0) p4 = 100.0d0 npfix = npfix + 1 if (npfix .gt. maxfix) then write (iout,20) 20 format (/,' KGEOM -- Too many Position Restraints;', & ' Increase MAXFIX') call fatal end if ipfix(npfix) = ia kpfix(1,npfix) = 1 kpfix(2,npfix) = 1 kpfix(3,npfix) = 1 xpfix(npfix) = p1 ypfix(npfix) = p2 zpfix(npfix) = p3 pfix(1,npfix) = p4 pfix(2,npfix) = p5 else if (ia.ge.-n .and. ia.le.-1) then ia = abs(ia) call getnumb (string,ib,next) ib = min(abs(ib),n) string = string(next:240) read (string,*,err=30,end=30) p1,p2 30 continue if (p1 .eq. 0.0d0) p1 = 100.0d0 if (npfix+ib-ia+1 .gt. maxfix) then write (iout,40) 40 format (/,' KGEOM -- Too many Position Restraints;', & ' Increase MAXFIX') call fatal end if do j = ia, ib npfix = npfix + 1 ipfix(npfix) = j kpfix(1,npfix) = 1 kpfix(2,npfix) = 1 kpfix(3,npfix) = 1 xpfix(npfix) = x(j) ypfix(npfix) = y(j) zpfix(npfix) = z(j) pfix(1,npfix) = p1 pfix(2,npfix) = p2 end do end if c c get atom restrained to a specified position range c else if (keyword(1:15) .eq. 'RESTRAIN-PLANE ') then letter = ' ' ia = 0 p1 = 0.0d0 p2 = 0.0d0 p3 = 0.0d0 next = 1 call getword (string,letter,next) call upcase (letter) string = string(next:240) read (string,*,err=50,end=50) ia,p1,p2,p3 50 continue if (p2 .eq. 0.0d0) p2 = 100.0d0 npfix = npfix + 1 if (npfix .gt. maxfix) then write (iout,60) 60 format (/,' KGEOM -- Too many Plane Restraints;', & ' Increase MAXFIX') call fatal end if ipfix(npfix) = ia kpfix(1,npfix) = 0 kpfix(2,npfix) = 0 kpfix(3,npfix) = 0 if (letter .eq. 'X') then kpfix(1,npfix) = 1 xpfix(npfix) = p1 else if (letter .eq. 'Y') then kpfix(2,npfix) = 1 ypfix(npfix) = p1 else if (letter .eq. 'Z') then kpfix(3,npfix) = 1 zpfix(npfix) = p1 end if pfix(1,npfix) = p2 pfix(2,npfix) = p3 c c get atoms restrained to a specified distance range c else if (keyword(1:18) .eq. 'RESTRAIN-DISTANCE ') then ia = 0 ib = 0 d1 = 100.0d0 d2 = 0.0d0 d3 = 0.0d0 exist = .false. read (string,*,err=70,end=70) ia,ib,d1,d2 exist = .true. 70 continue read (string,*,err=80,end=80) ia,ib,d1,d2,d3 80 continue if (.not. exist) 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) d2 = sqrt(xr*xr + yr*yr + zr*zr) end if if (d3 .eq. 0.0d0) d3 = d2 ndfix = ndfix + 1 if (ndfix .gt. maxfix) then write (iout,90) 90 format (/,' KGEOM -- Too many Distance Restraints;', & ' Increase MAXFIX') call fatal end if idfix(1,ndfix) = ia idfix(2,ndfix) = ib dfix(1,ndfix) = d1 dfix(2,ndfix) = d2 dfix(3,ndfix) = d3 c c get atoms restrained to a specified angle range c else if (keyword(1:15) .eq. 'RESTRAIN-ANGLE ') then ia = 0 ib = 0 ic = 0 a1 = 10.0d0 a2 = 0.0d0 a3 = 0.0d0 exist = .false. read (string,*,err=100,end=100) ia,ib,ic,a1,a2 exist = .true. 100 continue read (string,*,err=110,end=110) ia,ib,ic,a1,a2,a3 110 continue if (.not. exist) a2 = geometry (ia,ib,ic,0) if (a3 .eq. 0.0d0) a3 = a2 nafix = nafix + 1 if (nafix .gt. maxfix) then write (iout,120) 120 format (/,' KGEOM -- Too many Angle Restraints;', & ' Increase MAXFIX') call fatal end if iafix(1,nafix) = ia iafix(2,nafix) = ib iafix(3,nafix) = ic afix(1,nafix) = a1 afix(2,nafix) = a2 afix(3,nafix) = a3 c c get atoms restrained to a specified torsion range c else if (keyword(1:17).eq.'RESTRAIN-TORSION ') then ia = 0 ib = 0 ic = 0 id = 0 t1 = 1.0d0 t2 = 0.0d0 t3 = 0.0d0 exist = .false. read (string,*,err=130,end=130) ia,ib,ic,id,t1,t2 exist = .true. 130 continue read (string,*,err=140,end=140) ia,ib,ic,id,t1,t2,t3 exist = .true. 140 continue if (.not. exist) t2 = geometry (ia,ib,ic,id) if (t3 .eq. 0.0d0) t3 = t2 do while (t2 .gt. 180.0d0) t2 = t2 - 360.0d0 end do do while (t2 .lt. -180.0d0) t2 = t2 + 360.0d0 end do do while (t3 .gt. 180.0d0) t3 = t3 - 360.0d0 end do do while (t3 .lt. -180.0d0) t3 = t3 + 360.0d0 end do ntfix = ntfix + 1 if (ntfix .gt. maxfix) then write (iout,150) 150 format (/,' KGEOM -- Too many Torsion Restraints;', & ' Increase MAXFIX') call fatal end if itfix(1,ntfix) = ia itfix(2,ntfix) = ib itfix(3,ntfix) = ic itfix(4,ntfix) = id tfix(1,ntfix) = t1 tfix(2,ntfix) = t2 tfix(3,ntfix) = t3 c c get groups restrained to a specified distance range c else if (keyword(1:16) .eq. 'RESTRAIN-GROUPS ') then ia = 0 ib = 0 g1 = 100.0d0 g2 = 0.0d0 g3 = 0.0d0 exist = .false. read (string,*,err=160,end=160) ia,ib,g1,g2 exist = .true. 160 continue read (string,*,err=170,end=170) ia,ib,g1,g2,g3 170 continue if (.not. exist) then xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 do j = igrp(1,ia), igrp(2,ia) k = kgrp(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do weigh = max(1.0d0,grpmass(ia)) xr = xcm / weigh yr = ycm / weigh zr = zcm / weigh xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 do j = igrp(1,ib), igrp(2,ib) k = kgrp(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do weigh = max(1.0d0,grpmass(ib)) xr = xr - xcm/weigh yr = yr - ycm/weigh zr = zr - zcm/weigh intermol = (molcule(kgrp(igrp(1,ia))) .ne. & molcule(kgrp(igrp(1,ib)))) if (use_bounds .and. intermol) call image (xr,yr,zr) g2 = sqrt(xr*xr + yr*yr + zr*zr) end if if (g3 .eq. 0.0d0) g3 = g2 ngfix = ngfix + 1 if (ngfix .gt. maxfix) then write (iout,180) 180 format (/,' KGEOM -- Too many Group Restraints;', & ' Increase MAXFIX') call fatal end if igfix(1,ngfix) = ia igfix(2,ngfix) = ib gfix(1,ngfix) = g1 gfix(2,ngfix) = g2 gfix(3,ngfix) = g3 c c maintain chirality as found in the original input structure c else if (keyword(1:18) .eq. 'ENFORCE-CHIRALITY ') then if (.not. allocated(ichir)) allocate (ichir(4,n)) if (.not. allocated(chir)) allocate (chir(3,n)) do j = 1, n if (n12(j) .eq. 4) then ia = i12(1,j) ib = i12(2,j) ic = i12(3,j) id = i12(4,j) keep = .true. if (n12(ia) .eq. 1) then if (type(ia) .eq. type(ib)) keep = .false. if (type(ia) .eq. type(ic)) keep = .false. if (type(ia) .eq. type(id)) keep = .false. else if (n12(ib) .eq. 1) then if (type(ib) .eq. type(ic)) keep = .false. if (type(ib) .eq. type(id)) keep = .false. else if (n12(ic) .eq. 1) then if (type(ic) .eq. type(id)) keep = .false. end if if (keep) then nchir = nchir + 1 ichir(1,nchir) = ia ichir(2,nchir) = ib ichir(3,nchir) = ic ichir(4,nchir) = id 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 ratio = abs(vol/(xad*xbd*xcd)) chir(1,nchir) = 10.0d0 if (ratio .gt. 0.1d0) then chir(2,nchir) = 0.5d0 * vol chir(3,nchir) = 2.0d0 * vol else chir(2,nchir) = -2.0d0 * abs(vol) chir(3,nchir) = 2.0d0 * abs(vol) end if end if end if end do c c setup any shallow Gaussian basin restraint between atoms c else if (keyword(1:6) .eq. 'BASIN ') then depth = 0.0d0 width = 0.0d0 rflat = 0.0d0 read (string,*,err=190,end=190) depth,width,rflat 190 continue use_basin = .true. if (depth .eq. 0.0d0) use_basin = .false. if (width .eq. 0.0d0) use_basin = .false. if (depth .gt. 0.0d0) depth = -depth c c setup any spherical droplet restraint between atoms c else if (keyword(1:5) .eq. 'WALL ') then rwall = 0.0d0 read (string,*,err=200,end=200) rwall 200 continue if (rwall .gt. 0.0d0) use_wall = .true. end if end do c c turn off the geometric restraint potential if it is not used c if (max(npfix,ndfix,nafix,ntfix,ngfix,nchir).eq.0 .and. & .not.use_basin .and. .not.use_wall) use_geom = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1998 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module khbond -- H-bonding term forcefield parameters ## c ## ## c ############################################################### c c c maxnhb maximum number of hydrogen bonding pair entries c c radhb radius parameter for hydrogen bonding pairs c epshb well depth parameter for hydrogen bonding pairs c khb string of atom types for hydrogen bonding pairs c c module khbond implicit none integer maxnhb real*8, allocatable :: radhb(:) real*8, allocatable :: epshb(:) character*8, allocatable :: khb(:) save end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine kimprop -- improper dihedral parameters ## c ## ## c ############################################################ c c c "kimprop" assigns potential parameters to each improper c dihedral in the structure and processes any changed values c c subroutine kimprop use atomid use atoms use couple use improp use inform use iounit use keys use kiprop use potent use tors implicit none integer i,j,k,ndi integer ia,ib,ic,id integer ita,itb,itc,itd integer size,next real*8 tk,tv,symm logical header,done character*4 pa,pb,pc,pd character*8 zero8 character*12 zero12 character*16 blank,pti character*16 pt0,pt1 character*16 pt2,pt3 character*16 pt(6) character*20 keyword character*240 record character*240 string c c c process keywords containing improper dihedral parameters c blank = ' ' zero8 = '00000000' zero12 = '000000000000' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:9) .eq. 'IMPROPER ') then ia = 0 ib = 0 ic = 0 id = 0 tk = 0.0d0 tv = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,id,tk,tv 10 continue if (min(ia,ib,ic,id) .lt. 0) goto 50 size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) pti = pa//pb//pc//pd if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Improper Dihedral', & ' Parameters :', & //,5x,'Atom Classes',12x,'K(ID)', & 10x,'Angle',/) end if write (iout,30) ia,ib,ic,id,tk,tv 30 format (2x,4i4,4x,f12.3,f15.3) end if do j = 1, maxndi if (kdi(j).eq.blank .or. kdi(j).eq.pti) then kdi(j) = pti dcon(j) = tk tdi(j) = tv goto 50 end if end do write (iout,40) 40 format (/,' KIMPROP -- Too many Improper Dihedral', & ' Parameters') abort = .true. 50 continue end if end do c c determine the total number of forcefield parameters c ndi = maxndi do i = maxndi, 1, -1 if (kdi(i) .eq. blank) ndi = i - 1 end do c c perform dynamic allocation of some global arrays c if (allocated(iiprop)) deallocate (iiprop) if (allocated(kprop)) deallocate (kprop) if (allocated(vprop)) deallocate (vprop) allocate (iiprop(4,6*n)) allocate (kprop(6*n)) allocate (vprop(6*n)) c c assign improper dihedral parameters for each improper angle; c multiple symmetrical parameters are given partial weights c niprop = 0 if (ndi .ne. 0) then do i = 1, n if (n12(i) .eq. 3) then ia = i ib = i12(1,i) ic = i12(2,i) id = i12(3,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) pt(1) = pa//pb//pc//pd pt(2) = pa//pb//pd//pc pt(3) = pa//pc//pb//pd pt(4) = pa//pc//pd//pb pt(5) = pa//pd//pb//pc pt(6) = pa//pd//pc//pb pt3 = pa//pb//zero8 pt2 = pa//pc//zero8 pt1 = pa//pd//zero8 pt0 = pa//zero12 symm = 1.0d0 if (pb.eq.pc .or. pb.eq.pd .or. pc.eq.pd) symm = 2.0d0 if (pb.eq.pc .and. pb.eq.pd .and. pc.eq.pd) symm = 6.0d0 done = .false. do j = 1, ndi if (kdi(j)(1:4) .eq. pa) then do k = 1, 6 if (kdi(j) .eq. pt(k)) then niprop = niprop + 1 iiprop(1,niprop) = ia if (k .eq. 1) then iiprop(2,niprop) = ib iiprop(3,niprop) = ic iiprop(4,niprop) = id else if (k .eq. 2) then iiprop(2,niprop) = ib iiprop(3,niprop) = id iiprop(4,niprop) = ic else if (k .eq. 3) then iiprop(2,niprop) = ic iiprop(3,niprop) = ib iiprop(4,niprop) = id else if (k .eq. 4) then iiprop(2,niprop) = ic iiprop(3,niprop) = id iiprop(4,niprop) = ib else if (k .eq. 5) then iiprop(2,niprop) = id iiprop(3,niprop) = ib iiprop(4,niprop) = ic else if (k .eq. 6) then iiprop(2,niprop) = id iiprop(3,niprop) = ic iiprop(4,niprop) = ib end if kprop(niprop) = dcon(j) / symm vprop(niprop) = tdi(j) done = .true. end if end do end if end do if (.not. done) then do j = 1, ndi if (kdi(j) .eq. pt1) then symm = 3.0d0 do k = 1, 3 niprop = niprop + 1 iiprop(1,niprop) = ia if (k .eq. 1) then iiprop(2,niprop) = ib iiprop(3,niprop) = ic iiprop(4,niprop) = id else if (k .eq. 2) then iiprop(2,niprop) = ic iiprop(3,niprop) = id iiprop(4,niprop) = ib else if (k .eq. 3) then iiprop(2,niprop) = id iiprop(3,niprop) = ib iiprop(4,niprop) = ic end if kprop(niprop) = dcon(j) / symm vprop(niprop) = tdi(j) end do done = .true. else if (kdi(j) .eq. pt2) then symm = 3.0d0 do k = 1, 3 niprop = niprop + 1 iiprop(1,niprop) = ia if (k .eq. 1) then iiprop(2,niprop) = ib iiprop(3,niprop) = ic iiprop(4,niprop) = id else if (k .eq. 2) then iiprop(2,niprop) = ic iiprop(3,niprop) = id iiprop(4,niprop) = ib else if (k .eq. 3) then iiprop(2,niprop) = id iiprop(3,niprop) = ib iiprop(4,niprop) = ic end if kprop(niprop) = dcon(j) / symm vprop(niprop) = tdi(j) end do done = .true. else if (kdi(j) .eq. pt3) then symm = 3.0d0 do k = 1, 3 niprop = niprop + 1 iiprop(1,niprop) = ia if (k .eq. 1) then iiprop(2,niprop) = ib iiprop(3,niprop) = ic iiprop(4,niprop) = id else if (k .eq. 2) then iiprop(2,niprop) = ic iiprop(3,niprop) = id iiprop(4,niprop) = ib else if (k .eq. 3) then iiprop(2,niprop) = id iiprop(3,niprop) = ib iiprop(4,niprop) = ic end if kprop(niprop) = dcon(j) / symm vprop(niprop) = tdi(j) end do done = .true. end if end do end if if (.not. done) then do j = 1, ndi if (kdi(j) .eq. pt0) then symm = 3.0d0 do k = 1, 3 niprop = niprop + 1 iiprop(1,niprop) = ia if (k .eq. 1) then iiprop(2,niprop) = ib iiprop(3,niprop) = ic iiprop(4,niprop) = id else if (k .eq. 2) then iiprop(2,niprop) = ic iiprop(3,niprop) = id iiprop(4,niprop) = ib else if (k .eq. 3) then iiprop(2,niprop) = id iiprop(3,niprop) = ib iiprop(4,niprop) = ic end if kprop(niprop) = dcon(j) / symm vprop(niprop) = tdi(j) end do end if end do end if end if end do end if c c process keywords with improper dihedral specific parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:9) .eq. 'IMPROPER ') then ia = 0 ib = 0 ic = 0 id = 0 tk = 0.0d0 tv = 0.0d0 string = record(next:240) read (string,*,err=60,end=60) ia,ib,ic,id,tk,tv 60 continue if (min(ia,ib,ic,id) .lt. 0) then ia = abs(ia) ib = abs(ib) ic = abs(ic) id = abs(id) if (header .and. .not.silent) then header = .false. write (iout,70) 70 format (/,' Additional Improper Dihedral Specific', & ' Parameters :', & //,8x,'Atoms',16x,'K(ID)',10x,'Angle',/) end if if (.not. silent) then write (iout,80) ia,ib,ic,id,tk,tv 80 format (2x,4i4,4x,f12.3,f15.3) end if do j = 1, niprop ita = iiprop(1,j) itb = iiprop(2,j) itc = iiprop(3,j) itd = iiprop(4,j) if (ia.eq.ita .and. ib.eq.itb .and. & ic.eq.itc .and. id.eq.itd) then kprop(j) = tk vprop(j) = tv goto 90 end if end do end if 90 continue end if end do c c turn off the improper dihedral potential if it is not used c if (niprop .eq. 0) use_improp = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################### c ## ## c ## subroutine kimptor -- improper torsion parameters ## c ## ## c ########################################################### c c c "kimptor" assigns torsional parameters to each improper c torsion in the structure and processes any changed values c c subroutine kimptor use atomid use atoms use couple use imptor use inform use iounit use keys use kitors use math use potent use tors implicit none integer i,j,k,nti integer ia,ib,ic,id integer ita,itb,itc,itd integer size,next integer ft(6) real*8 angle,symm real*8 vt(6),st(6) logical header,done character*4 pa,pb,pc,pd character*4 zeros character*16 blank,pti character*16 pt0,pt1 character*16 pt2,pt3 character*16 pt(6) character*20 keyword character*240 record character*240 string c c c process keywords containing improper torsion parameters c blank = ' ' zeros = '0000' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:8) .eq. 'IMPTORS ') then ia = 0 ib = 0 ic = 0 id = 0 do j = 1, 6 vt(j) = 0.0d0 st(j) = 0.0d0 ft(j) = 0 end do string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,3) 10 continue if (min(ia,ib,ic,id) .lt. 0) goto 50 size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) pti = pa//pb//pc//pd call torphase (ft,vt,st) if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Improper Torsion Parameters :', & //,5x,'Atom Classes',11x,'1-Fold', & 9x,'2-Fold',9x,'3-Fold',/) end if write (iout,30) ia,ib,ic,id,(vt(j),st(j),j=1,3) 30 format (2x,4i4,3x,3(f9.3,f6.1)) end if do j = 1, maxnti if (kti(j).eq.blank .or. kti(j).eq.pti) then kti(j) = pti ti1(1,j) = vt(1) ti1(2,j) = st(1) ti2(1,j) = vt(2) ti2(2,j) = st(2) ti3(1,j) = vt(3) ti3(2,j) = st(3) goto 50 end if end do write (iout,40) 40 format (/,' KIMPTOR -- Too many Improper Torsion', & ' Parameters') abort = .true. 50 continue end if end do c c determine the total number of forcefield parameters c nti = maxnti do i = maxnti, 1, -1 if (kti(i) .eq. blank) nti = i - 1 end do c c perform dynamic allocation of some global arrays c if (allocated(iitors)) deallocate (iitors) if (allocated(itors1)) deallocate (itors1) if (allocated(itors2)) deallocate (itors2) if (allocated(itors3)) deallocate (itors3) allocate (iitors(4,6*n)) allocate (itors1(4,6*n)) allocate (itors2(4,6*n)) allocate (itors3(4,6*n)) c c assign improper torsion parameters for each improper torsion; c multiple symmetrical parameters are given partial weights c nitors = 0 if (nti .ne. 0) then do i = 1, n if (n12(i) .eq. 3) then ia = i12(1,i) ib = i12(2,i) ic = i id = i12(3,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) pt(1) = pa//pb//pc//pd pt(2) = pb//pa//pc//pd pt(3) = pa//pd//pc//pb pt(4) = pd//pa//pc//pb pt(5) = pb//pd//pc//pa pt(6) = pd//pb//pc//pa pt3 = zeros//zeros//pc//pd pt2 = zeros//zeros//pc//pb pt1 = zeros//zeros//pc//pa pt0 = zeros//zeros//pc//zeros symm = 1.0d0 if (pa.eq.pb .or. pa.eq.pd .or. pb.eq.pd) symm = 2.0d0 if (pa.eq.pb .and. pa.eq.pd .and. pb.eq.pd) symm = 6.0d0 done = .false. do j = 1, nti if (kti(j)(9:12) .eq. pc) then do k = 1, 6 if (kti(j) .eq. pt(k)) then nitors = nitors + 1 iitors(3,nitors) = ic if (k .eq. 1) then iitors(1,nitors) = ia iitors(2,nitors) = ib iitors(4,nitors) = id else if (k .eq. 2) then iitors(1,nitors) = ib iitors(2,nitors) = ia iitors(4,nitors) = id else if (k .eq. 3) then iitors(1,nitors) = ia iitors(2,nitors) = id iitors(4,nitors) = ib else if (k .eq. 4) then iitors(1,nitors) = id iitors(2,nitors) = ia iitors(4,nitors) = ib else if (k .eq. 5) then iitors(1,nitors) = ib iitors(2,nitors) = id iitors(4,nitors) = ia else if (k .eq. 6) then iitors(1,nitors) = id iitors(2,nitors) = ib iitors(4,nitors) = ia end if itors1(1,nitors) = ti1(1,j) / symm itors1(2,nitors) = ti1(2,j) itors2(1,nitors) = ti2(1,j) / symm itors2(2,nitors) = ti2(2,j) itors3(1,nitors) = ti3(1,j) / symm itors3(2,nitors) = ti3(2,j) done = .true. end if end do end if end do if (.not. done) then do j = 1, nti if (kti(j) .eq. pt1) then symm = 3.0d0 do k = 1, 3 nitors = nitors + 1 iitors(3,nitors) = ic if (k .eq. 1) then iitors(1,nitors) = ia iitors(2,nitors) = ib iitors(4,nitors) = id else if (k .eq. 2) then iitors(1,nitors) = ib iitors(2,nitors) = id iitors(4,nitors) = ia else if (k .eq. 3) then iitors(1,nitors) = id iitors(2,nitors) = ia iitors(4,nitors) = ib end if itors1(1,nitors) = ti1(1,j) / symm itors1(2,nitors) = ti1(2,j) itors2(1,nitors) = ti2(1,j) / symm itors2(2,nitors) = ti2(2,j) itors3(1,nitors) = ti3(1,j) / symm itors3(2,nitors) = ti3(2,j) end do done = .true. else if (kti(j) .eq. pt2) then symm = 3.0d0 do k = 1, 3 nitors = nitors + 1 iitors(3,nitors) = ic if (k .eq. 1) then iitors(1,nitors) = ia iitors(2,nitors) = ib iitors(4,nitors) = id else if (k .eq. 2) then iitors(1,nitors) = ib iitors(2,nitors) = id iitors(4,nitors) = ia else if (k .eq. 3) then iitors(1,nitors) = id iitors(2,nitors) = ia iitors(4,nitors) = ib end if itors1(1,nitors) = ti1(1,j) / symm itors1(2,nitors) = ti1(2,j) itors2(1,nitors) = ti2(1,j) / symm itors2(2,nitors) = ti2(2,j) itors3(1,nitors) = ti3(1,j) / symm itors3(2,nitors) = ti3(2,j) end do done = .true. else if (kti(j) .eq. pt3) then symm = 3.0d0 do k = 1, 3 nitors = nitors + 1 iitors(3,nitors) = ic if (k .eq. 1) then iitors(1,nitors) = ia iitors(2,nitors) = ib iitors(4,nitors) = id else if (k .eq. 2) then iitors(1,nitors) = ib iitors(2,nitors) = id iitors(4,nitors) = ia else if (k .eq. 3) then iitors(1,nitors) = id iitors(2,nitors) = ia iitors(4,nitors) = ib end if itors1(1,nitors) = ti1(1,j) / symm itors1(2,nitors) = ti1(2,j) itors2(1,nitors) = ti2(1,j) / symm itors2(2,nitors) = ti2(2,j) itors3(1,nitors) = ti3(1,j) / symm itors3(2,nitors) = ti3(2,j) end do done = .true. end if end do end if if (.not. done) then do j = 1, nti if (kti(j) .eq. pt0) then symm = 3.0d0 do k = 1, 3 nitors = nitors + 1 iitors(3,nitors) = ic if (k .eq. 1) then iitors(1,nitors) = ia iitors(2,nitors) = ib iitors(4,nitors) = id else if (k .eq. 2) then iitors(1,nitors) = ib iitors(2,nitors) = id iitors(4,nitors) = ia else if (k .eq. 3) then iitors(1,nitors) = id iitors(2,nitors) = ia iitors(4,nitors) = ib end if itors1(1,nitors) = ti1(1,j) / symm itors1(2,nitors) = ti1(2,j) itors2(1,nitors) = ti2(1,j) / symm itors2(2,nitors) = ti2(2,j) itors3(1,nitors) = ti3(1,j) / symm itors3(2,nitors) = ti3(2,j) end do end if end do end if end if end do end if c c process keywords with improper torsion specific parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:8) .eq. 'IMPTORS ') then ia = 0 ib = 0 ic = 0 id = 0 do j = 1, 6 vt(j) = 0.0d0 st(j) = 0.0d0 ft(j) = 0 end do string = record(next:240) read (string,*,err=60,end=60) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,3) 60 continue if (min(ia,ib,ic,id) .lt. 0) then ia = abs(ia) ib = abs(ib) ic = abs(ic) id = abs(id) call torphase (ft,vt,st) if (header .and. .not.silent) then header = .false. write (iout,70) 70 format (/,' Additional Improper Torsion Specific', & ' Parameters :', & //,8x,'Atoms',15x,'1-Fold',9x,'2-Fold', & 9x,'3-Fold',/) end if if (.not. silent) then write (iout,80) ia,ib,ic,id,(vt(j),st(j),j=1,3) 80 format (2x,4i4,3x,3(f9.3,f6.1)) end if do j = 1, nitors ita = iitors(1,j) itb = iitors(2,j) itc = iitors(3,j) itd = iitors(4,j) if (ia.eq.ita .and. ib.eq.itb .and. & ic.eq.itc .and. id.eq.itd) then itors1(1,j) = vt(1) itors1(2,j) = st(1) itors2(1,j) = vt(2) itors2(2,j) = st(2) itors3(1,j) = vt(3) itors3(2,i) = st(3) goto 90 end if end do end if 90 continue end if end do c c find the cosine and sine of the phase angle for each torsion c do i = 1, nitors angle = itors1(2,i) / radian itors1(3,i) = cos(angle) itors1(4,i) = sin(angle) angle = itors2(2,i) / radian itors2(3,i) = cos(angle) itors2(4,i) = sin(angle) angle = itors3(2,i) / radian itors3(3,i) = cos(angle) itors3(4,i) = sin(angle) end do c c turn off the improper torsion potential if it is not used c if (nitors .eq. 0) use_imptor = .false. return end c c c ############################################################### c ## COPYRIGHT (C) 2014 by Alex Albaugh & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################### c c ################################################################# c ## ## c ## subroutine kinetic -- compute kinetic energy components ## c ## ## c ################################################################# c c c "kinetic" computes the total kinetic energy and kinetic energy c contributions to the pressure tensor by summing over velocities c c subroutine kinetic (eksum,ekin,temp) use atomid use atoms use bath use group use mdstuf use moldyn use rgddyn use units use usage implicit none integer i,j,k,m integer start,stop real*8 eksum,temp real*8 weigh real*8 term,value real*8 xr,yr,zr real*8 x2,y2,z2 real*8 xcm,ycm,zcm real*8 ekin(3,3) real*8 inert(3,3) c c c zero out the temperature and kinetic energy components c temp = 0.0d0 eksum = 0.0d0 do i = 1, 3 do j = 1, 3 ekin(j,i) = 0.0d0 end do end do c c get the total kinetic energy and tensor for atomic sites c if (integrate .ne. 'RIGIDBODY') then do i = 1, nuse m = iuse(i) term = 0.5d0 * mass(m) / ekcal do j = 1, 3 do k = 1, 3 value = term * v(j,m) * v(k,m) ekin(k,j) = ekin(k,j) + value end do end do end do eksum = ekin(1,1) + ekin(2,2) + ekin(3,3) c c get the total kinetic energy and tensor for rigid bodies c else do i = 1, ngrp start = igrp(1,i) stop = igrp(2,i) xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 do j = start, stop k = kgrp(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do xcm = xcm / grpmass(i) ycm = ycm / grpmass(i) zcm = zcm / grpmass(i) c c find the inertial tensor relative to the center of mass c do j = 1, 3 do k = 1, 3 inert(k,j) = 0.0d0 end do end do do j = start, stop k = kgrp(j) xr = x(k) - xcm yr = y(k) - ycm zr = z(k) - zcm x2 = xr * xr y2 = yr * yr z2 = zr * zr weigh = mass(k) inert(1,1) = inert(1,1) + weigh*(y2+z2) inert(2,1) = inert(2,1) - weigh*xr*yr inert(3,1) = inert(3,1) - weigh*xr*zr inert(2,2) = inert(2,2) + weigh*(x2+z2) inert(3,2) = inert(3,2) - weigh*yr*zr inert(3,3) = inert(3,3) + weigh*(x2+y2) end do inert(1,2) = inert(2,1) inert(1,3) = inert(3,1) inert(2,3) = inert(3,2) c c increment the kinetic energy due to translational motion c term = 0.5d0 * grpmass(i) / ekcal do j = 1, 3 do k = 1, 3 value = term * vc(j,i) * vc(k,i) ekin(k,j) = ekin(k,j) + value if (j .eq. k) eksum = eksum + value end do end do c c increment the kinetic energy due to rotational motion c term = 0.5d0 / ekcal do j = 1, 3 do k = 1, 3 value = term * inert(k,j) * wc(j,i) * wc(k,i) eksum = eksum + value end do end do end do end if c c set the instantaneous temperature from total kinetic energy c temp = 2.0d0 * eksum / (dble(nfree) * gasconst) c c get the kinetic energy for Bussi-Parrinello barostat c if (isobaric .and. barostat.eq.'BUSSI') then term = dble(nfree) * gasconst * kelvin * taupres * taupres value = 0.5d0 * term * eta * eta do j = 1, 3 ekin(j,j) = ekin(j,j) + value/3.0d0 end do eksum = eksum + value end if return end c c c ############################################################## c ## ## c ## subroutine kinaux -- compute iEL dipole kinetic energy ## c ## ## c ############################################################## c c c "kinaux" computes the total kinetic energy and temperature c for auxiliary dipole variables used in iEL polarization c c subroutine kinaux (temp_aux,temp_auxp) use atoms use ielscf use usage implicit none integer i,j,k,m real*8 term real*8 vj,vjp real*8 vk,vkp real*8 temp_aux real*8 temp_auxp real*8 eksum_aux real*8 eksum_auxp real*8 ekaux(3,3) real*8 ekauxp(3,3) c c c zero out the temperature and kinetic energy components c temp_aux = 0.0d0 temp_auxp = 0.0d0 do i = 1, 3 do j = 1, 3 ekaux(j,i) = 0.0d0 ekauxp(j,i) = 0.0d0 end do end do c c get the kinetic energy tensor for auxiliary variables c do i = 1, nuse m = iuse(i) term = 0.5d0 do j = 1, 3 vj = vaux(j,m) vjp = vpaux(j,m) do k = 1, 3 vk = vaux(k,m) vkp = vpaux(k,m) ekaux(k,j) = ekaux(k,j) + term*vj*vk ekauxp(k,j) = ekauxp(k,j) + term*vjp*vkp end do end do end do c c find the total kinetic energy and auxiliary temperatures c eksum_aux = ekaux(1,1) + ekaux(2,2) + ekaux(3,3) eksum_auxp = ekauxp(1,1) + ekauxp(2,2) + ekauxp(3,3) if (nfree_aux .ne. 0) then temp_aux = 2.0d0 * eksum_aux / dble(nfree_aux) temp_auxp = 2.0d0 * eksum_auxp / dble(nfree_aux) 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 kiprop -- improper dihedral forcefield parameters ## c ## ## c ################################################################## c c c maxndi maximum number of improper dihedral parameter entries c c dcon force constant parameters for improper dihedrals c tdi ideal dihedral angle values for improper dihedrals c kdi string of atom classes for improper dihedral angles c c module kiprop implicit none integer maxndi real*8, allocatable :: dcon(:) real*8, allocatable :: tdi(:) character*16, allocatable :: kdi(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module kitors -- improper torsion forcefield parameters ## c ## ## c ################################################################# c c c maxnti maximum number of improper torsion parameter entries c c ti1 torsional parameters for improper 1-fold rotation c ti2 torsional parameters for improper 2-fold rotation c ti3 torsional parameters for improper 3-fold rotation c kti string of atom classes for improper torsional parameters c c module kitors implicit none integer maxnti real*8, allocatable :: ti1(:,:) real*8, allocatable :: ti2(:,:) real*8, allocatable :: ti3(:,:) character*16, allocatable :: kti(:) save end c c c ################################################### c ## COPYRIGHT (C) 2000 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine kmetal -- ligand field parameter assignment ## c ## ## c ################################################################ c c c "kmetal" assigns ligand field parameters to transition metal c atoms and processes any new or changed parameter values c c subroutine kmetal implicit none c c c add any setup for ligand field parameters below here c return end c c c ################################################### c ## COPYRIGHT (C) 1994 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine kmpole -- multipole parameter assignment ## c ## ## c ############################################################# c c c "kmpole" assigns atomic multipole moments to the atoms of c the structure and processes any new or changed values c c subroutine kmpole use atomid use atoms use chgpen use couple use inform use iounit use kcpen use keys use kmulti use math use mplpot use mpole use polar use polgrp use potent use units implicit none integer i,j,k,l,m integer ji,ki,li integer it,jt,kt,lt integer ic,imp,nmp integer size,next integer number integer kz,kx,ky integer ztyp,xtyp,ytyp integer polmax integer, allocatable :: mpt(:) integer, allocatable :: mpz(:) integer, allocatable :: mpx(:) integer, allocatable :: mpy(:) real*8 pel,pal real*8 mpl(13) logical header,path character*4 pa,pb,pc,pd character*8 axt character*16 blank,pt character*20 keyword character*240 record character*240 string c c c count the number of existing multipole parameters c blank = ' ' nmp = maxnmp do i = maxnmp, 1, -1 if (kmp(i) .eq. blank) nmp = i - 1 end do c c find and count new multipole parameters in the keyfile c imp = 0 do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:10) .eq. 'MULTIPOLE ') then k = 0 string = record(next:240) read (string,*,err=10,end=10) k,kz,kx,ky,mpl(1) goto 40 10 continue read (string,*,err=20,end=20) k,kz,kx,mpl(1) goto 40 20 continue read (string,*,err=30,end=30) k,kz,mpl(1) goto 40 30 continue read (string,*,err=50,end=50) k,mpl(1) 40 continue if (k .gt. 0) then record = keyline(i+1) read (record,*,err=50,end=50) mpl(2),mpl(3),mpl(4) record = keyline(i+2) read (record,*,err=50,end=50) mpl(5) record = keyline(i+3) read (record,*,err=50,end=50) mpl(8),mpl(9) record = keyline(i+4) read (record,*,err=50,end=50) mpl(11),mpl(12),mpl(13) imp = imp + 1 end if 50 continue end if end do c c check for too many combined parameter values c nmp = nmp + imp if (nmp .gt. maxnmp) then write (iout,60) 60 format (/,' KMPOLE -- Too many Atomic Multipole', & ' Parameters') abort = .true. end if c c move existing parameters to make room for new values c if (imp .ne. 0) then do j = nmp, imp+1, -1 k = j - imp kmp(j) = kmp(k) mpaxis(j) = mpaxis(k) do m = 1, 13 multip(m,j) = multip(m,k) end do end do end if c c process keywords containing atomic multipole parameters c imp = 0 header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:10) .eq. 'MULTIPOLE ') then k = 0 kz = 0 kx = 0 ky = 0 axt = 'Z-then-X' do j = 1, 13 mpl(j) = 0.0d0 end do string = record(next:240) read (string,*,err=70,end=70) k,kz,kx,ky,mpl(1) goto 100 70 continue ky = 0 read (string,*,err=80,end=80) k,kz,kx,mpl(1) goto 100 80 continue kx = 0 read (string,*,err=90,end=90) k,kz,mpl(1) goto 100 90 continue kz = 0 read (string,*,err=130,end=130) k,mpl(1) 100 continue if (k .gt. 0) then if (kz .eq. 0) axt = 'None' if (kz.ne.0 .and. kx.eq.0) axt = 'Z-Only' if (kz.lt.0 .or. kx.lt.0) axt = 'Bisector' if (kx.lt.0 .and. ky.lt.0) axt = 'Z-Bisect' if (max(kz,kx,ky) .lt. 0) axt = '3-Fold' kz = abs(kz) kx = abs(kx) ky = abs(ky) record = keyline(i+1) read (record,*,err=130,end=130) mpl(2),mpl(3),mpl(4) record = keyline(i+2) read (record,*,err=130,end=130) mpl(5) record = keyline(i+3) read (record,*,err=130,end=130) mpl(8),mpl(9) record = keyline(i+4) read (record,*,err=130,end=130) mpl(11),mpl(12),mpl(13) mpl(6) = mpl(8) mpl(7) = mpl(11) mpl(10) = mpl(12) if (header .and. .not.silent) then header = .false. write (iout,110) 110 format (/,' Additional Atomic Multipole Parameters :', & //,5x,'Atom Type',5x,'Coordinate Frame', & ' Definition',9x,'Multipole Moments') end if if (.not. silent) then write (iout,120) k,kz,kx,ky,axt,(mpl(j),j=1,5), & mpl(8),mpl(9),(mpl(j),j=11,13) 120 format (/,6x,i6,3x,i6,1x,i6,1x,i6,3x,a8,3x,f9.5, & /,49x,3f9.5,/,49x,f9.5, & /,49x,2f9.5,/,49x,3f9.5) end if size = 4 call numeral (k,pa,size) call numeral (kz,pb,size) call numeral (kx,pc,size) call numeral (ky,pd,size) pt = pa//pb//pc//pd imp = imp + 1 kmp(imp) = pt mpaxis(imp) = axt do j = 1, 13 multip(j,imp) = mpl(j) end do end if 130 continue end if end do c c perform dynamic allocation of some global arrays c if (allocated(ipole)) deallocate (ipole) if (allocated(polsiz)) deallocate (polsiz) if (allocated(pollist)) deallocate (pollist) if (allocated(zaxis)) deallocate (zaxis) if (allocated(xaxis)) deallocate (xaxis) if (allocated(yaxis)) deallocate (yaxis) if (allocated(pole)) deallocate (pole) if (allocated(rpole)) deallocate (rpole) if (allocated(mono0)) deallocate (mono0) if (allocated(polaxe)) deallocate (polaxe) if (allocated(np11)) deallocate (np11) if (allocated(np12)) deallocate (np12) if (allocated(np13)) deallocate (np13) if (allocated(np14)) deallocate (np14) allocate (ipole(n)) allocate (polsiz(n)) allocate (pollist(n)) allocate (zaxis(n)) allocate (xaxis(n)) allocate (yaxis(n)) allocate (pole(maxpole,n)) allocate (rpole(maxpole,n)) allocate (mono0(n)) allocate (polaxe(n)) allocate (np11(n)) allocate (np12(n)) allocate (np13(n)) allocate (np14(n)) c c zero out local axes, multipoles and polarization attachments c do i = 1, n ipole(i) = 0 polsiz(i) = 0 pollist(i) = 0 zaxis(i) = 0 xaxis(i) = 0 yaxis(i) = 0 polaxe(i) = 'None' do j = 1, 13 pole(j,i) = 0.0d0 end do mono0(i) = 0.0d0 np11(i) = 0 np12(i) = 0 np13(i) = 0 np14(i) = 0 end do c c perform dynamic allocation of some local arrays c allocate (mpt(maxnmp)) allocate (mpz(maxnmp)) allocate (mpx(maxnmp)) allocate (mpy(maxnmp)) c c store the atom types associated with each parameter c do i = 1, nmp mpt(i) = number(kmp(i)(1:4)) mpz(i) = number(kmp(i)(5:8)) mpx(i) = number(kmp(i)(9:12)) mpy(i) = number(kmp(i)(13:16)) end do c c assign multipole parameters via only 1-2 connected atoms c do i = 1, n it = type(i) do imp = 1, nmp if (it .eq. mpt(imp)) then ztyp = mpz(imp) xtyp = mpx(imp) ytyp = mpy(imp) do j = 1, n12(i) ji = i12(j,i) jt = type(ji) if (jt .eq. ztyp) then do k = 1, n12(i) ki = i12(k,i) kt = type(ki) if (kt.eq.xtyp .and. ki.ne.ji) then if (ytyp .eq. 0) then pollist(i) = i zaxis(i) = ji xaxis(i) = ki polaxe(i) = mpaxis(imp) do m = 1, 13 pole(m,i) = multip(m,imp) end do goto 140 end if do l = 1, n12(i) li = i12(l,i) lt = type(li) if (lt.eq.ytyp .and. li.ne.ji & .and. li.ne.ki) then pollist(i) = i zaxis(i) = ji xaxis(i) = ki yaxis(i) = li polaxe(i) = mpaxis(imp) do m = 1, 13 pole(m,i) = multip(m,imp) end do goto 140 end if end do end if end do end if end do end if end do c c assign multipole parameters via 1-2 and 1-3 connected atoms c do imp = 1, nmp if (it .eq. mpt(imp)) then ztyp = mpz(imp) xtyp = mpx(imp) ytyp = mpy(imp) do j = 1, n12(i) ji = i12(j,i) jt = type(ji) if (jt .eq. ztyp) then do k = 1, n13(i) ki = i13(k,i) kt = type(ki) path = .false. do m = 1, n12(ki) if (i12(m,ki) .eq. ji) path = .true. end do if (kt.eq.xtyp .and. path) then if (ytyp .eq. 0) then pollist(i) = i zaxis(i) = ji xaxis(i) = ki polaxe(i) = mpaxis(imp) do m = 1, 13 pole(m,i) = multip(m,imp) end do goto 140 end if do l = 1, n13(i) li = i13(l,i) lt = type(li) path = .false. do m = 1, n12(li) if (i12(m,li) .eq. ji) path = .true. end do if (lt.eq.ytyp .and. li.ne.ki & .and. path) then pollist(i) = i zaxis(i) = ji xaxis(i) = ki yaxis(i) = li polaxe(i) = mpaxis(imp) do m = 1, 13 pole(m,i) = multip(m,imp) end do goto 140 end if end do end if end do end if end do end if end do c c assign multipole parameters via only a z-defining atom c do imp = 1, nmp if (it .eq. mpt(imp)) then ztyp = mpz(imp) xtyp = mpx(imp) ytyp = mpy(imp) do j = 1, n12(i) ji = i12(j,i) jt = type(ji) if (jt .eq. ztyp) then if (xtyp .eq. 0) then pollist(i) = i zaxis(i) = ji polaxe(i) = mpaxis(imp) do m = 1, 13 pole(m,i) = multip(m,imp) end do goto 140 end if end if end do end if end do c c assign multipole parameters via no connected atoms c do imp = 1, nmp if (it .eq. mpt(imp)) then ztyp = mpz(imp) xtyp = mpx(imp) ytyp = mpy(imp) if (ztyp .eq. 0) then pollist(i) = i polaxe(i) = mpaxis(imp) do m = 1, 13 pole(m,i) = multip(m,imp) end do goto 140 end if end if end do 140 continue end do c c perform deallocation of some local arrays c deallocate (mpt) deallocate (mpz) deallocate (mpx) deallocate (mpy) c c process keywords with multipole parameters for specific atoms c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:10) .eq. 'MULTIPOLE ') then k = 0 kz = 0 kx = 0 ky = 0 axt = 'Z-then-X' do j = 1, 13 mpl(j) = 0.0d0 end do string = record(next:240) read (string,*,err=150,end=150) k,kz,kx,ky,mpl(1) goto 180 150 continue ky = 0 read (string,*,err=160,end=160) k,kz,kx,mpl(1) goto 180 160 continue kx = 0 read (string,*,err=170,end=170) k,kz,mpl(1) goto 180 170 continue kz = 0 read (string,*,err=210,end=210) k,mpl(1) 180 continue if (k.lt.0 .and. k.ge.-n) then k = -k if (kz .eq. 0) axt = 'None' if (kz.ne.0 .and. kx.eq.0) axt = 'Z-Only' if (kz.lt.0 .or. kx.lt.0) axt = 'Bisector' if (kx.lt.0 .and. ky.lt.0) axt = 'Z-Bisect' if (max(kz,kx,ky) .lt. 0) axt = '3-Fold' kz = abs(kz) kx = abs(kx) ky = abs(ky) record = keyline(i+1) read (record,*,err=210,end=210) mpl(2),mpl(3),mpl(4) record = keyline(i+2) read (record,*,err=210,end=210) mpl(5) record = keyline(i+3) read (record,*,err=210,end=210) mpl(8),mpl(9) record = keyline(i+4) read (record,*,err=210,end=210) mpl(11),mpl(12),mpl(13) mpl(6) = mpl(8) mpl(7) = mpl(11) mpl(10) = mpl(12) if (header .and. .not.silent) then header = .false. write (iout,190) 190 format (/,' Additional Atomic Multipoles', & ' for Specific Atoms :', & //,5x,'Atom',10x,'Coordinate Frame', & ' Definition',9x,'Multipole Moments') end if if (.not. silent) then write (iout,200) k,kz,kx,ky,axt,(mpl(j),j=1,5), & mpl(8),mpl(9),(mpl(j),j=11,13) 200 format (/,3x,i6,6x,i6,1x,i6,1x,i6,3x,a8,3x,f9.5, & /,49x,3f9.5,/,49x,f9.5, & /,49x,2f9.5,/,49x,3f9.5) end if pollist(k) = k zaxis(k) = kz xaxis(k) = kx yaxis(k) = ky polaxe(k) = axt do j = 1, 13 pole(j,k) = mpl(j) end do end if 210 continue end if end do c c convert the dipole and quadrupole moments to Angstroms, c quadrupole divided by 3 for use as traceless values c do i = 1, n do k = 2, 4 pole(k,i) = pole(k,i) * bohr end do do k = 5, 13 pole(k,i) = pole(k,i) * bohr**2 / 3.0d0 end do end do c c get the order of the multipole expansion at each site c npole = n polmax = 0 do i = 1, n size = 0 do k = 1, maxpole if (pole(k,i) .ne. 0.0d0) size = max(k,size) end do if (size .gt. 4) then size = 13 else if (size .gt. 1) then size = 4 end if polsiz(i) = size polmax = max(polmax,size) end do c c warn if there are sites with no atomic multipole values c if (polmax .ne. 0) then header = .true. do i = 1, n if (pollist(i) .eq. 0) then if (header) then header = .false. write (iout,220) 220 format (/,' Undefined Atomic Multipole', & ' Parameters :',/) end if write (iout,230) i 230 format (' Warning, No Multipole Parameters', & ' for Atom',i7) end if pollist(i) = 0 end do end if c c perform dynamic allocation of some global arrays c if (.not. use_polar) then if (allocated(uind)) deallocate (uind) if (allocated(uinp)) deallocate (uinp) if (allocated(uinds)) deallocate (uinds) if (allocated(uinps)) deallocate (uinps) allocate (uind(3,n)) allocate (uinp(3,n)) allocate (uinds(3,n)) allocate (uinps(3,n)) c c if polarization not used, zero out induced dipoles c do i = 1, n do j = 1, 3 uind(j,i) = 0.0d0 uinp(j,i) = 0.0d0 uinds(j,i) = 0.0d0 uinps(j,i) = 0.0d0 end do end do end if c c perform dynamic allocation of some global arrays c if (allocated(pcore)) deallocate (pcore) if (allocated(pval)) deallocate (pval) if (allocated(pval0)) deallocate (pval0) if (allocated(palpha)) deallocate (palpha) allocate (pcore(n)) allocate (pval(n)) allocate (pval0(n)) allocate (palpha(n)) c c find new charge penetration parameters in the keyfile c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'CHGPEN ') then k = 0 pel = 0.0d0 pal = 0.0d0 string = record(next:240) read (string,*,err=260,end=260) k,pel,pal cpele(k) = abs(pel) cpalp(k) = pal if (header .and. .not.silent) then header = .false. write (iout,240) 240 format (/,' Additional Charge Penetration Parameters :', & //,5x,'Atom Class',11x,'Core Chg',11x,'Damp',/) end if if (.not. silent) then write (iout,250) k,pel,pal 250 format (6x,i6,7x,f15.3,f15.4) end if 260 continue end if end do c c assign the charge penetration charge and alpha parameters c ncp = 0 do i = 1, n pcore(i) = 0.0d0 pval(i) = pole(1,i) pval0(i) = pval(i) palpha(i) = 0.0d0 ic = class(i) if (ic .ne. 0) then pcore(i) = cpele(ic) pval(i) = pole(1,i) - cpele(ic) pval0(i) = pval(i) palpha(i) = cpalp(ic) end if end do c c process keywords with charge penetration for specific atoms c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'CHGPEN ') then k = 0 pel = 0.0d0 pal = 0.0d0 string = record(next:240) read (string,*,err=290,end=290) k,pel,pal if (k.lt.0 .and. k.ge.-n) then k = -k pcore(k) = abs(pel) pval(k) = pole(1,k) - abs(pel) palpha(k) = pal if (header .and. .not.silent) then header = .false. write (iout,270) 270 format (/,' Additional Charge Penetration', & ' for Specific Atoms :', & //,5x,'Atom',17x,'Core Chg',11x,'Damp',/) end if if (.not. silent) then write (iout,280) k,pel,pal 280 format (6x,i6,7x,f15.3,f15.4) end if end if 290 continue end if end do c c remove zero or undefined electrostatic sites from the list c if ((use_mpole .or. use_repel .or. use_solv) .and. & .not.use_polar .and. .not.use_chgtrn) then npole = 0 ncp = 0 do i = 1, n if (polsiz(i) .ne. 0) then npole = npole + 1 ipole(npole) = i pollist(i) = npole mono0(i) = pole(1,i) if (palpha(i) .ne. 0.0d0) ncp = ncp + 1 end if end do end if c c test multipoles at chiral sites and invert if necessary c if (use_mpole .and. .not.use_polar .and. .not.use_chgtrn) & call chkpole c c turn off atomic multipole potentials if not used c if (npole .eq. 0) use_mpole = .false. if (ncp .ne. 0) use_chgpen = .true. return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module kmulti -- atomic multipole forcefield parameters ## c ## ## c ################################################################# c c c maxnmp maximum number of atomic multipole parameter entries c c multip atomic monopole, dipole and quadrupole values c mpaxis type of local axis definition for atomic multipoles c kmp string of atom types for atomic multipoles c c module kmulti implicit none integer maxnmp real*8, allocatable :: multip(:,:) character*8, allocatable :: mpaxis(:) character*16, allocatable :: kmp(:) save end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine kopbend -- out-of-plane bending parameters ## c ## ## c ############################################################### c c c "kopbend" assigns the force constants for out-of-plane bends c at trigonal centers via Wilson-Decius-Cross or Allinger angles; c also processes any new or changed parameter values c c subroutine kopbend use angbnd use atomid use atoms use couple use fields use inform use iounit use keys use kopbnd use opbend use potent use usage implicit none integer i,j,k,it integer ia,ib,ic,id integer ita,itb,itc,itd integer nopb,size integer next,number real*8 fopb logical header,done logical, allocatable :: jopb(:) character*4 pa,pb,pc,pd character*4 zero4 character*8 zero8 character*16 blank,pt character*16 pt0,pt1 character*20 keyword character*240 record character*240 string c c c process keywords containing out-of-plane bend parameters c blank = ' ' zero4 = '0000' zero8 = '00000000' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'OPBEND ') then ia = 0 ib = 0 ic = 0 id = 0 fopb = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,id,fopb 10 continue if (min(ia,ib,ic,id) .lt. 0) goto 50 size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) if (ic .le. id) then pt = pa//pb//pc//pd else pt = pa//pb//pd//pc end if if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Out-of-Plane Bend', & ' Parameters :', & //,5x,'Atom Classes',19x,'K(OPB)',/) end if write (iout,30) ia,ib,ic,id,fopb 30 format (4x,4i4,10x,f12.3) end if size = 4 do j = 1, maxnopb if (kopb(j).eq.blank .or. kopb(j).eq.pt) then kopb(j) = pt opbn(j) = fopb goto 50 end if end do write (iout,40) 40 format (/,' KOPBEND -- Too many Out-of-Plane', & ' Angle Bending Parameters') abort = .true. 50 continue end if end do c c perform dynamic allocation of some global arrays c if (allocated(iopb)) deallocate (iopb) if (allocated(opbk)) deallocate (opbk) allocate (iopb(nangle)) allocate (opbk(nangle)) c c use special out-of-plane bend parameter assignment for MMFF c if (forcefield .eq. 'MMFF94') then call kopbendm return end if c c determine the total number of forcefield parameters c nopb = maxnopb do i = maxnopb, 1, -1 if (kopb(i) .eq. blank) nopb = i - 1 end do c c perform dynamic allocation of some local arrays c allocate (jopb(maxclass)) c c make list of atom classes using out-of-plane bending c do i = 1, maxclass jopb(i) = .false. end do do i = 1, maxnopb if (kopb(i) .eq. blank) goto 60 it = number(kopb(i)(5:8)) jopb(it) = .true. end do 60 continue c c assign out-of-plane bending parameters for each angle c nopbend = 0 if (nopb .ne. 0) then header = .true. do i = 1, nangle ib = iang(2,i) itb = class(ib) if (jopb(itb) .and. n12(ib).eq.3) then ia = iang(1,i) ita = class(ia) ic = iang(3,i) itc = class(ic) id = iang(4,i) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (ita .le. itc) then pt = pd//pb//pa//pc else pt = pd//pb//pc//pa end if pt1 = pd//pb//zero8 pt0 = zero4//pb//zero8 done = .false. do j = 1, nopb if (kopb(j) .eq. pt) then nopbend = nopbend + 1 iopb(nopbend) = i opbk(nopbend) = opbn(j) done = .true. goto 70 end if end do do j = 1, nopb if (kopb(j) .eq. pt1) then nopbend = nopbend + 1 iopb(nopbend) = i opbk(nopbend) = opbn(j) done = .true. goto 70 end if end do do j = 1, nopb if (kopb(j) .eq. pt0) then nopbend = nopbend + 1 iopb(nopbend) = i opbk(nopbend) = opbn(j) done = .true. goto 70 end if end do 70 continue if (use_opbend .and. .not.done) then if (use(ia) .or. use(ib) .or. use(ic) .or. use(id)) & abort = .true. if (header) then header = .false. write (iout,80) 80 format (/,' Undefined Out-of-Plane Bend', & ' Parameters :', & //,' Type',24x,'Atom Names',24x, & 'Atom Classes',/) end if write (iout,90) id,name(id),ib,name(ib),ia,name(ia), & ic,name(ic),itd,itb,ita,itc 90 format (' Angle-OP',3x,4(i6,'-',a3),5x,4i5) end if else iang(4,i) = ib end if end do end if c c perform deallocation of some local arrays c deallocate (jopb) c c get keywords with out-of-plane bending specific params c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'OPBEND ') then ia = 0 ib = 0 ic = 0 id = 0 fopb = 0.0d0 string = record(next:240) read (string,*,err=100,end=100) ia,ib,ic,id,fopb 100 continue if (min(ia,ib,ic,id) .lt. 0) then ia = abs(ia) ib = abs(ib) ic = abs(ic) id = abs(id) if (.not.silent .and. header) then header = .false. write (iout,110) 110 format (/,' Additional Out-of-Plane Bending', & ' Parameters for Specific Atoms :', & //,8x,'Atoms',23x,'K(OPB)',/) end if if (.not. silent) then write (iout,120) ia,ib,ic,id,fopb 120 format (4x,4i4,10x,2f12.3) end if do j = 1, nopbend k = iopb(j) ita = iang(1,k) itb = iang(2,k) itc = iang(3,k) itd = iang(4,k) if (ia.eq.itd .and. ib.eq.itb) then if ((ic.eq.ita.and.id.eq.itc) .or. & (ic.eq.itc.and.id.eq.ita)) then opbk(j) = fopb goto 130 end if end if end do end if 130 continue end if end do c c turn off the out-of-plane bending term if it is not used c if (nopbend .eq. 0) use_opbend = .false. return end c c c ################################################################## c ## ## c ## subroutine kopbendm -- MMFF out-of-plane bend parameters ## c ## ## c ################################################################## c c c "kopbendm" assigns the force constants for out-of-plane bends c according to the Merck Molecular Force Field (MMFF) c c subroutine kopbendm use angbnd use atomid use atoms use kopbnd use merck use opbend use potent implicit none integer i,j,m integer nopb,size integer ia,ib,ic,id integer ita,itb,itc,itd integer itta,ittb integer ittc,ittd character*4 pa,pb,pc,pd character*16 blank,pt c c c determine the total number of forcefield parameters c blank = ' ' nopb = maxnopb do i = maxnopb, 1, -1 if (kopb(i) .eq. blank) nopb = i - 1 end do c c assign MMFF out-of-plane bending parameter values c nopbend = 0 if (nopb .ne. 0) then do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) id = iang(4,i) if (min(ia,ib,ic,id) .gt. 0) then itta = type(ia) ittb = type(ib) ittc = type(ic) ittd = type(id) m = 0 10 continue m = m + 1 if (m .eq. 1) then ita = eqclass(itta,1) itb = eqclass(ittb,1) itc = eqclass(ittc,1) itd = eqclass(ittd,1) else if (m .eq. 2) then ita = eqclass(itta,2) itb = eqclass(ittb,2) itc = eqclass(ittc,2) itd = eqclass(ittd,2) else if (m .eq. 3) then ita = eqclass(itta,3) itb = eqclass(ittb,2) itc = eqclass(ittc,3) itd = eqclass(ittd,3) else if (m .eq. 4) then ita = eqclass(itta,4) itb = eqclass(ittb,2) itc = eqclass(ittc,4) itd = eqclass(ittd,4) else if (m .eq. 5) then ita = eqclass(itta,5) itb = eqclass(ittb,2) itc = eqclass(ittc,5) itd = eqclass(ittd,5) end if if (m .gt. 5) then nopbend = nopbend + 1 iopb(nopbend) = i opbk(nopbend) = 0.0d0 else size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itd.le.ita .and. itd.le.itc) then if (ita .le. itc) then pt = pd//pb//pa//pc else pt = pd//pb//pc//pa end if else if (ita.le.itc .and. ita.le.itd) then if (itd .le. itc) then pt = pa//pb//pd//pc else pt = pa//pb//pc//pd end if else if (itc.le.ita .and. itc.le.itd) then if (ita .le. itd) then pt = pc//pb//pa//pd else pt = pc//pb//pd//pa end if end if do j = 1, nopb if (kopb(j) .eq. pt) then nopbend = nopbend + 1 iopb(nopbend) = i opbk(nopbend) = opbn(j) goto 20 end if end do if (class(ib).eq.8 .or. class(ib).eq.17 .or. & class(ib).eq.26 .or. class(ib).eq.43 .or. & class(ib).eq.49 .or. class(ib).eq.73 .or. & class(ib).eq.82) then nopbend = nopbend + 1 iopb(nopbend) = i opbk(nopbend) = 0.0d0 goto 20 end if goto 10 20 continue end if end if end do end if c c turn off the out-of-plane bending term if it is not used c if (nopbend .eq. 0) use_opbend = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module kopbnd -- out-of-plane bend forcefield parameters ## c ## ## c ################################################################## c c c maxnopb maximum number of out-of-plane bending entries c c opbn force constant parameters for out-of-plane bending c kopb string of atom classes for out-of-plane bending c c module kopbnd implicit none integer maxnopb real*8, allocatable :: opbn(:) character*16, allocatable :: kopb(:) save end c c c ################################################### c ## COPYRIGHT (C) 1999 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine kopdist -- out-of-plane distance parameters ## c ## ## c ################################################################ c c c "kopdist" assigns the force constants for out-of-plane c distance at trigonal centers via the central atom height; c also processes any new or changed parameter values c c subroutine kopdist use angbnd use atmlst use atomid use atoms use couple use inform use iounit use keys use kopdst use opdist use potent implicit none integer i,j,nopd integer ia,ib,ic,id integer ita,itb,itc,itd integer imin,itmin integer size,next real*8 fopd logical header character*4 pa,pb,pc,pd character*12 zeros character*16 blank character*16 pt,pt0 character*20 keyword character*240 record character*240 string c c c process keywords containing out-of-plane distance parameters c blank = ' ' zeros = '000000000000' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'OPDIST ') then ia = 0 ib = 0 ic = 0 id = 0 fopd = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,id,fopd 10 continue if (min(ia,ib,ic,id) .lt. 0) goto 50 size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) imin = min(ib,ic,id) if (ib .eq. imin) then if (ic .le. id) then pt = pa//pb//pc//pd else pt = pa//pb//pd//pc end if else if (ic .eq. imin) then if (ib .le. id) then pt = pa//pc//pb//pd else pt = pa//pc//pd//pb end if else if (id .eq. imin) then if (ib .le. ic) then pt = pa//pd//pb//pc else pt = pa//pd//pc//pb end if end if if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Out-of-Plane Distance', & ' Parameters :', & //,5x,'Atom Classes',19x,'K(OPD)',/) end if write (iout,30) ia,ib,ic,id,fopd 30 format (4x,4i4,10x,2f12.3) end if do j = 1, maxnopd if (kopd(j).eq.blank .or. kopd(j).eq.pt) then kopd(j) = pt opds(j) = fopd goto 50 end if end do write (iout,40) 40 format (/,' KOPDIST -- Too many Out-of-Plane Distance', & ' Parameters') abort = .true. 50 continue end if end do c c determine the total number of forcefield parameters c nopd = maxnopd do i = maxnopd, 1, -1 if (kopd(i) .eq. blank) nopd = i - 1 end do c c perform dynamic allocation of some global arrays c if (allocated(iopd)) deallocate (iopd) if (allocated(opdk)) deallocate (opdk) allocate (iopd(4,n)) allocate (opdk(n)) c c assign out-of-plane distance parameters for trigonal sites c nopdist = 0 if (nopd .ne. 0) then do i = 1, n if (n12(i) .eq. 3) then ia = i ib = i12(1,i) ic = i12(2,i) id = i12(3,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) itmin = min(itb,itc,itd) if (itb .eq. itmin) then if (itc .le. itd) then pt = pa//pb//pc//pd else pt = pa//pb//pd//pc end if else if (itc .eq. itmin) then if (itb .le. itd) then pt = pa//pc//pb//pd else pt = pa//pc//pd//pb end if else if (itd .eq. itmin) then if (itb .le. itc) then pt = pa//pd//pb//pc else pt = pa//pd//pc//pb end if end if pt0 = pa//zeros do j = 1, nopd if (kopd(j) .eq. pt) then nopdist = nopdist + 1 iopd(1,nopdist) = ia iopd(2,nopdist) = ib iopd(3,nopdist) = ic iopd(4,nopdist) = id opdk(nopdist) = opds(j) goto 60 end if end do do j = 1, nopd if (kopd(j) .eq. pt0) then nopdist = nopdist + 1 iopd(1,nopdist) = ia iopd(2,nopdist) = ib iopd(3,nopdist) = ic iopd(4,nopdist) = id opdk(nopdist) = opds(j) goto 60 end if end do 60 continue end if end do end if c c get keywords with out-of-plane distance specific params c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'OPDIST ') then ia = 0 ib = 0 ic = 0 id = 0 fopd = 0.0d0 string = record(next:240) read (string,*,err=70,end=70) ia,ib,ic,id,fopd 70 continue if (min(ia,ib,ic,id) .lt. 0) then ia = abs(ia) ib = abs(ib) ic = abs(ic) id = abs(id) if (.not.silent .and. header) then header = .false. write (iout,80) 80 format (/,' Additional Out-of-Plane Distance', & ' Parameters for Specific Atoms :', & //,8x,'Atoms',23x,'K(OPD)',/) end if if (.not. silent) then write (iout,90) ia,ib,ic,id,fopd 90 format (4x,4i4,10x,2f12.3) end if do j = 1, nopdist ita = iopd(1,j) itb = iopd(2,j) itc = iopd(3,j) itd = iopd(4,j) if (ia .eq. ita) then if (ib .eq. itb) then if ((ic.eq.itc.and.id.eq.itd) .or. & (ic.eq.itd.and.id.eq.itc)) then opdk(j) = fopd goto 100 end if else if (ic .eq. itb) then if ((ib.eq.itc.and.id.eq.itd) .or. & (ib.eq.itd.and.id.eq.itc)) then opdk(j) = fopd goto 100 end if else if (id .eq. itb) then if ((ib.eq.itc.and.ic.eq.itd) .or. & (ib.eq.itd.and.ic.eq.itc)) then opdk(j) = fopd goto 100 end if end if end if end do end if 100 continue end if end do c c turn off out-of-plane distance potential if it is not used c if (nopdist .eq. 0) use_opdist = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1999 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module kopdst -- out-of-plane distance forcefield params ## c ## ## c ################################################################## c c c maxnopd maximum number of out-of-plane distance entries c c opds force constant parameters for out-of-plane distance c kopd string of atom classes for out-of-plane distance c c module kopdst implicit none integer maxnopd real*8, allocatable :: opds(:) character*16, allocatable :: kopd(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine korbit -- conjugated pisystem orbital setup ## c ## ## c ################################################################ c c c "korbit" assigns pi-orbital parameters to conjugated systems c and processes any new or changed parameters c c subroutine korbit use atomid use atoms use bndstr use inform use iounit use keys use korbs use orbits use piorbs use pistuf use tors use units implicit none integer i,j,k,jt integer ia,ib,ita,itb integer npi,npi5,npi4 integer size,next,iring real*8 elect,ioniz real*8 repuls real*8 sslop,tslop logical header logical use_ring character*4 pa,pb character*6 label character*8 blank,pt character*20 keyword character*240 record character*240 string c c c process keywords containing pisystem atom parameters c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'PIATOM ') then ia = 0 elect = 0.0d0 ioniz = 0.0d0 repuls = 0.0d0 string = record(next:240) read (string,*,err=10) ia,elect,ioniz,repuls 10 continue if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Pisystem Atom Parameters :', & //,5x,'Atom Type',12x,'Electron', & 5x,'Ionization',6x,'Repulsion',/) end if write (iout,30) ia,elect,ioniz,repuls 30 format (6x,i6,10x,f12.3,3x,f12.3,3x,f12.3) end if if (ia.gt.0 .and. ia.le.maxclass) then electron(ia) = elect ionize(ia) = ioniz repulse(ia) = repuls else write (iout,40) 40 format (/,' KORBIT -- Too many Atom Classes;', & ' Increase MAXCLASS') abort = .true. end if end if end do c c process keywords containing pisystem bond parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) iring = -1 if (keyword(1:7) .eq. 'PIBOND ') iring = 0 if (keyword(1:8) .eq. 'PIBOND5 ') iring = 5 if (keyword(1:8) .eq. 'PIBOND4 ') iring = 4 if (iring .ge. 0) then ia = 0 ib = 0 sslop = 0.0d0 tslop = 0.0d0 string = record(next:240) read (string,*,err=50) ia,ib,sslop,tslop 50 continue if (.not. silent) then if (header) then header = .false. write (iout,60) 60 format (/,' Additional Pisystem Bond Parameters :', & //,5x,'Atom Types',12x,'d Force',7x, & 'd Length',/) end if if (iring .eq. 0) then write (iout,70) ia,ib,sslop,tslop 70 format (6x,2i4,8x,f12.3,3x,f12.3) else if (iring .eq. 5) label = '5-Ring' if (iring .eq. 4) label = '4-Ring' write (iout,80) ia,ib,sslop,tslop,label 80 format (6x,2i4,8x,f12.3,3x,f12.3,3x,a6) end if end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) if (ia .le. ib) then pt = pa//pb else pt = pb//pa end if if (iring .eq. 0) then do j = 1, maxnpi if (kpi(j).eq.blank .or. kpi(j).eq.pt) then kpi(j) = pt sslope(j) = sslop tslope(j) = tslop goto 100 end if end do write (iout,90) 90 format (/,' KORBIT -- Too many Pisystem Bond', & ' Type Parameters') abort = .true. 100 continue else if (iring .eq. 5) then do j = 1, maxnpi5 if (kpi5(j).eq.blank .or. kpi5(j).eq.pt) then kpi5(j) = pt sslope5(j) = sslop tslope5(j) = tslop goto 120 end if end do write (iout,110) 110 format (/,' KORBIT -- Too many 5-Ring Pisystem Bond', & ' Type Parameters') abort = .true. 120 continue else if (iring .eq. 4) then do j = 1, maxnpi4 if (kpi4(j).eq.blank .or. kpi4(j).eq.pt) then kpi4(j) = pt sslope4(j) = sslop tslope4(j) = tslop goto 140 end if end do write (iout,130) 130 format (/,' KORBIT -- Too many 4-Ring Pisystem Bond', & ' Type Parameters') abort = .true. 140 continue end if end if end do c c determine the total number of forcefield parameters c npi = maxnpi npi5 = maxnpi5 npi4 = maxnpi4 do i = maxnpi, 1, -1 if (kpi(i) .eq. blank) npi = i - 1 end do do i = maxnpi5, 1, -1 if (kpi5(i) .eq. blank) npi5 = i - 1 end do do i = maxnpi4, 1, -1 if (kpi4(i) .eq. blank) npi4 = i - 1 end do use_ring = .false. if (min(npi5,npi4) .ne. 0) use_ring = .true. c c perform dynamic allocation of some global arrays c if (allocated(qorb)) deallocate (qorb) if (allocated(worb)) deallocate (worb) if (allocated(emorb)) deallocate (emorb) if (allocated(bkpi)) deallocate (bkpi) if (allocated(blpi)) deallocate (blpi) if (allocated(kslope)) deallocate (kslope) if (allocated(lslope)) deallocate (lslope) if (allocated(torsp2)) deallocate (torsp2) allocate (qorb(n)) allocate (worb(n)) allocate (emorb(n)) allocate (bkpi(nbond)) allocate (blpi(nbond)) allocate (kslope(nbond)) allocate (lslope(nbond)) allocate (torsp2(ntors)) c c assign the values characteristic of the piatom types c do i = 1, norbit j = iorbit(i) jt = type(j) qorb(j) = electron(jt) worb(j) = ionize(jt) / evolt emorb(j) = repulse(jt) / evolt end do c c assign parameters for all bonds between piatoms; c store the original bond lengths and force constants c do i = 1, nbpi j = ibpi(1,i) ia = iorbit(ibpi(2,i)) ib = iorbit(ibpi(3,i)) ita = class(ia) itb = class(ib) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pt = pa//pb else pt = pb//pa end if c c make a check for bonds contained inside small rings c iring = 0 if (use_ring) then call chkring (iring,ia,ib,0,0) if (iring .eq. 6) iring = 0 if (iring.eq.5 .and. npi5.eq.0) iring = 0 if (iring.eq.4 .and. npi4.eq.0) iring = 0 if (iring .eq. 3) iring = 0 end if c c assign conjugated bond parameters for each pibond c if (iring .eq. 0) then do k = 1, npi if (kpi(k) .eq. pt) then bkpi(j) = bk(j) blpi(j) = bl(j) kslope(j) = sslope(k) lslope(j) = tslope(k) goto 170 end if end do c c assign bond parameters for 5-membered ring pibonds c else if (iring .eq. 5) then do k = 1, npi5 if (kpi5(k) .eq. pt) then bkpi(j) = bk(j) blpi(j) = bl(j) kslope(j) = sslope5(k) lslope(j) = tslope5(k) goto 170 end if end do c c assign bond parameters for 4-membered ring pibonds c else if (iring .eq. 4) then do k = 1, npi4 if (kpi4(k) .eq. pt) then bkpi(j) = bk(j) blpi(j) = bl(j) kslope(j) = sslope4(k) lslope(j) = tslope4(k) goto 170 end if end do end if c c warning if suitable conjugated pibond parameters not found c abort = .true. if (header) then header = .false. write (iout,150) 150 format (/,' Undefined Conjugated Pibond Parameters :', & //,' Type',13x,'Atom Names',11x, & 'Atom Classes',/) end if label = 'Pibond' if (iring .eq. 5) label = '5-Ring' if (iring .eq. 4) label = '4-Ring' write (iout,160) label,ia,name(ia),ib,name(ib),ita,itb 160 format (1x,a6,5x,i6,'-',a3,i6,'-',a3,7x,2i5) 170 continue end do c c store original 2-fold torsional constants across pibonds c do i = 1, ntors torsp2(i) = tors2(1,i) 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 korbs -- pisystem orbital forcefield parameters ## c ## ## c ################################################################ c c c maxnpi maximum number of pisystem bond parameter entries c maxnpi5 maximum number of 5-membered ring pibond entries c maxnpi4 maximum number of 4-membered ring pibond entries c c electron number of pi-electrons for each atom class c ionize ionization potential for each atom class c repulse repulsion integral value for each atom class c sslope slope for bond stretch vs. pi-bond order c sslope5 slope for 5-ring bond stretch vs. pi-bond order c sslope4 slope for 4-ring bond stretch vs. pi-bond order c tslope slope for 2-fold torsion vs. pi-bond order c tslope5 slope for 5-ring 2-fold torsion vs. pi-bond order c tslope4 slope for 4-ring 2-fold torsion vs. pi-bond order c kpi string of atom classes for pisystem bonds c kpi5 string of atom classes for 5-ring pisystem bonds c kpi4 string of atom classes for 4-ring pisystem bonds c c module korbs implicit none integer maxnpi integer maxnpi5 integer maxnpi4 real*8, allocatable :: electron(:) real*8, allocatable :: ionize(:) real*8, allocatable :: repulse(:) real*8, allocatable :: sslope(:) real*8, allocatable :: sslope5(:) real*8, allocatable :: sslope4(:) real*8, allocatable :: tslope(:) real*8, allocatable :: tslope5(:) real*8, allocatable :: tslope4(:) character*8, allocatable :: kpi(:) character*8, allocatable :: kpi5(:) character*8, allocatable :: kpi4(:) save end c c c ################################################### c ## COPYRIGHT (C) 2003 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module kpitor -- pi-system torsion forcefield parameters ## c ## ## c ################################################################## c c c maxnpt maximum number of pi-system torsion parameter entries c c ptcon force constant parameters for pi-system torsions c kpt string of atom classes for pi-system torsion terms c c module kpitor implicit none integer maxnpt real*8, allocatable :: ptcon(:) character*8, allocatable :: kpt(:) save end c c c ################################################### c ## COPYRIGHT (C) 2003 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine kpitors -- find pi-system torsion parameters ## c ## ## c ################################################################# c c c "kpitors" assigns pi-system torsion parameters to torsions c needing them, and processes any new or changed values c c subroutine kpitors use atomid use atoms use bndstr use couple use inform use iounit use keys use kpitor use pitors use potent use tors implicit none integer i,j,npt integer ia,ib integer ita,itb integer size,next real*8 tp logical header character*4 pa,pb character*8 blank,pt character*20 keyword character*240 record character*240 string c c c process keywords containing pi-system torsion parameters c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'PITORS ') then ia = 0 ib = 0 tp = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,tp 10 continue if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Pi-Orbital Torsion', & ' Parameters :', & //,5x,'Atom Classes',7x,'2-Fold',/) end if write (iout,30) ia,ib,tp 30 format (6x,2i4,4x,f12.3) end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) if (ia .le. ib) then pt = pa//pb else pt = pb//pa end if do j = 1, maxnpt if (kpt(j).eq.blank .or. kpt(j).eq.pt) then kpt(j) = pt ptcon(j) = tp goto 50 end if end do write (iout,40) 40 format (/,' KPITORS -- Too many Pi-Orbital Torsion', & ' Parameters') abort = .true. 50 continue end if end do c c determine the total number of forcefield parameters c npt = maxnpt do i = maxnpt, 1, -1 if (kpt(i) .eq. blank) npt = i - 1 end do c c perform dynamic allocation of some global arrays c if (allocated(ipit)) deallocate (ipit) if (allocated(kpit)) deallocate (kpit) allocate (ipit(6,ntors)) allocate (kpit(ntors)) c c assign pi-system torsion parameters as required c npitors = 0 if (npt .ne. 0) then do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (n12(ia).eq.3 .and. n12(ib).eq.3) then ita = class(ia) itb = class(ib) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pt = pa//pb else pt = pb//pa end if do j = 1, npt if (kpt(j) .eq. pt) then npitors = npitors + 1 kpit(npitors) = ptcon(j) ipit(1,npitors) = i12(1,ia) ipit(2,npitors) = i12(2,ia) ipit(3,npitors) = ia ipit(4,npitors) = ib ipit(5,npitors) = i12(1,ib) ipit(6,npitors) = i12(2,ib) if (i12(1,ia) .eq. ib) & ipit(1,npitors) = i12(3,ia) if (i12(2,ia) .eq. ib) & ipit(2,npitors) = i12(3,ia) if (i12(1,ib) .eq. ia) & ipit(5,npitors) = i12(3,ib) if (i12(2,ib) .eq. ia) & ipit(6,npitors) = i12(3,ib) goto 60 end if end do end if 60 continue end do end if c c turn off the pi-system torsion potential if it is not used c if (npitors .eq. 0) use_pitors = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1995 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine kpolar -- assign polarizability parameters ## c ## ## c ############################################################### c c c "kpolar" assigns atomic dipole polarizabilities to the atoms c within the structure and processes any new or changed values c c literature references: c c A. C. Simmonett, F. C. Pickard IV, J. W. Ponder and B. R. Brooks, c "An Empirical Extrapolation Scheme for Efficient Treatment of c Induced Dipoles", Journal of Chemical Physics, 145, 164101 (2016) c [OPT method] c c F. Aviat, L. Lagardere and J.-P. Piquemal, "The Truncated c Conjugate Gradient (TCG), a Non-Iterative/Fixed-Cost Strategy for c Computing Polarization in Molecular Dynamics: Fast Evaluation of c Analytical Forces", Journal of Chemical Physics, 147, 161724 c (2018) [TCG method] c c subroutine kpolar use atoms use chgpen use expol use inform use iounit use keys use kpolpr use kpolr use mplpot use mpole use polar use polopt use polpot use polpcg use poltcg use potent implicit none integer i,j,k integer ii,kk integer ia,ib,it integer next,size integer nlist,npg integer number integer pg(maxval) integer, allocatable :: list(:) integer, allocatable :: rlist(:) real*8 pol,thl,thd real*8 sixth logical header character*4 pa,pb character*8 blank,pt character*20 keyword character*20 text character*240 record character*240 string c c c set the default values for polarization variables c polprt = .false. c c set defaults for PCG induced dipole parameters c pcgprec = .true. pcgguess = .true. pcgpeek = 1.0d0 c c set defaults for TCG induced dipole parameters c tcgorder = 0 tcgguess = .true. tcgpeek = 1.0d0 if (poltyp .eq. 'TCG ') poltyp = 'TCG2 ' if (poltyp .eq. 'TCG0 ') then poltyp = 'DIRECT' else if (poltyp .eq. 'TCG1 ') then poltyp = 'TCG ' tcgorder = 1 else if (poltyp(1:3) .eq. 'TCG') then poltyp = 'TCG ' tcgorder = 2 end if c c perform dynamic allocation of some global arrays c if (allocated(copt)) deallocate (copt) if (allocated(copm)) deallocate (copm) allocate (copt(0:maxopt)) allocate (copm(0:maxopt)) c c set defaults for OPT induced dipole coefficients c optorder = 0 do i = 0, maxopt copt(i) = 0.0d0 copm(i) = 0.0d0 end do if (poltyp .eq. 'OPT ') poltyp = 'OPT4 ' if (poltyp .eq. 'OPT1 ') then copt(0) = 0.530d0 copt(1) = 0.604d0 else if (poltyp .eq. 'OPT2 ') then copt(0) = 0.042d0 copt(1) = 0.635d0 copt(2) = 0.414d0 else if (poltyp .eq. 'OPT3 ') then copt(0) = -0.132d0 copt(1) = 0.218d0 copt(2) = 0.637d0 copt(3) = 0.293d0 else if (poltyp .eq. 'OPT4 ') then copt(0) = -0.071d0 copt(1) = -0.096d0 copt(2) = 0.358d0 copt(3) = 0.587d0 copt(4) = 0.216d0 else if (poltyp .eq. 'OPT5 ') then copt(0) = -0.005d0 copt(1) = -0.129d0 copt(2) = -0.026d0 copt(3) = 0.465d0 copt(4) = 0.528d0 copt(5) = 0.161d0 else if (poltyp .eq. 'OPT6 ') then copt(0) = 0.014d0 copt(1) = -0.041d0 copt(2) = -0.172d0 copt(3) = 0.073d0 copt(4) = 0.535d0 copt(5) = 0.467d0 copt(6) = 0.122d0 end if c c perform dynamic allocation of some local arrays c allocate (list(n)) c c set defaults for numbers and lists of polarizable atoms c nlist = 0 do i = 1, n list(i) = 0 end do c c get keywords containing polarization-related options c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:12) .eq. 'POLARIZABLE ') then read (string,*,err=10,end=10) (list(j),j=nlist+1,n) 10 continue do while (list(nlist+1) .ne. 0) nlist = nlist + 1 end do else if (keyword(1:12) .eq. 'POLAR-PRINT ') then polprt = .true. else if (keyword(1:12) .eq. 'PCG-PRECOND ') then pcgprec = .true. else if (keyword(1:14) .eq. 'PCG-NOPRECOND ') then pcgprec = .false. else if (keyword(1:10) .eq. 'PCG-GUESS ') then pcgguess = .true. else if (keyword(1:12) .eq. 'PCG-NOGUESS ') then pcgguess = .false. else if (keyword(1:9) .eq. 'PCG-PEEK ') then read (string,*,err=20,end=20) pcgpeek else if (keyword(1:10) .eq. 'TCG-GUESS ') then tcgguess = .true. else if (keyword(1:12) .eq. 'TCG-NOGUESS ') then tcgguess = .false. else if (keyword(1:9) .eq. 'TCG-PEEK ') then read (string,*,err=20,end=20) tcgpeek else if (keyword(1:10) .eq. 'OPT-COEFF ') then do j = 0, maxopt copt(j) = 0.0d0 end do read (string,*,err=20,end=20) (copt(j),j=0,maxopt) end if 20 continue end do c c get maximum coefficient order for OPT induced dipoles c if (poltyp(1:3) .eq. 'OPT') then poltyp = 'OPT ' do i = 1, maxopt if (copt(i) .ne. 0.0d0) optorder = max(i,optorder) end do do i = 0, optorder do j = optorder, i, -1 copm(i) = copm(i) + copt(j) end do end do end if c c perform dynamic allocation of some global arrays c if (allocated(ipolar)) deallocate (ipolar) if (allocated(polarity)) deallocate (polarity) if (allocated(thole)) deallocate (thole) if (allocated(tholed)) deallocate (tholed) if (allocated(pdamp)) deallocate (pdamp) if (allocated(udir)) deallocate (udir) if (allocated(udirp)) deallocate (udirp) if (allocated(uind)) deallocate (uind) if (allocated(uinp)) deallocate (uinp) if (allocated(douind)) deallocate (douind) allocate (ipolar(n)) allocate (polarity(n)) allocate (thole(n)) allocate (tholed(n)) allocate (pdamp(n)) allocate (udir(3,n)) allocate (udirp(3,n)) allocate (uind(3,n)) allocate (uinp(3,n)) allocate (douind(n)) if (allocated(uopt)) deallocate (uopt) if (allocated(uoptp)) deallocate (uoptp) if (allocated(fopt)) deallocate (fopt) if (allocated(foptp)) deallocate (foptp) if (poltyp .eq. 'OPT') then allocate (uopt(0:optorder,3,n)) allocate (uoptp(0:optorder,3,n)) allocate (fopt(0:optorder,10,n)) allocate (foptp(0:optorder,10,n)) end if c c set the atoms allowed to have nonzero induced dipoles c do i = 1, n douind(i) = .true. end do i = 1 do while (list(i) .ne. 0) if (i .eq. 1) then do j = 1, n douind(j) = .false. end do end if if (list(i).gt.0 .and. list(i).le.n) then j = list(i) if (.not. douind(j)) then douind(j) = .true. end if else if (list(i).lt.0 .and. list(i).ge.-n) then do j = abs(list(i)), abs(list(i+1)) if (.not. douind(j)) then douind(j) = .true. end if end do i = i + 1 end if i = i + 1 end do c c perform dynamic allocation of some local arrays c deallocate (list) c c process keywords containing polarizability parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:9) .eq. 'POLARIZE ') then k = 0 pol = 0.0d0 thl = -1.0d0 thd = -1.0d0 do j = 1, maxval pg(j) = 0 end do call getnumb (record,k,next) call gettext (record,text,next) read (text,*,err=30,end=30) pol call gettext (record,text,next) j = 1 call getnumb (text,pg(1),j) if (pg(1) .eq. 0) then read (text,*,err=30,end=30) thl call gettext (record,text,next) j = 1 call getnumb (text,pg(1),j) string = record(next:240) if (pg(1) .eq. 0) then read (text,*,err=30,end=30) thd read (string,*,err=30,end=30) (pg(j),j=1,maxval) else read (string,*,err=30,end=30) (pg(j),j=2,maxval) end if else string = record(next:240) read (string,*,err=30,end=30) (pg(j),j=2,maxval) end if 30 continue if (k .gt. 0) then if (header .and. .not.silent) then header = .false. write (iout,40) 40 format (/,' Additional Atomic Dipole', & ' Polarizability Parameters :') if (thd .ge. 0.0d0) then write (iout,50) 50 format (/,5x,'Atom Type',11x,'Alpha',7x, & 'Thole',6x,'TholeD',5x, & 'Group Atom Types',/) else if (thl .ge. 0.0d0) then write (iout,60) 60 format (/,5x,'Atom Type',11x,'Alpha',7x, & 'Thole',5x,'Group Atom Types',/) else write (iout,70) 70 format (/,5x,'Atom Type',11x,'Alpha',5x, & 'Group Atom Types',/) end if end if if (k .le. maxtyp) then polr(k) = pol athl(k) = max(0.0d0,thl) dthl(k) = max(0.0d0,thd) do j = 1, maxval pgrp(j,k) = pg(j) if (pg(j) .eq. 0) then npg = j - 1 goto 80 end if end do 80 continue if (.not. silent) then if (thd .ge. 0.0d0) then write (iout,90) k,pol,thl,thd,(pg(j),j=1,npg) 90 format (4x,i8,8x,f10.3,2x,f10.3,2x,f10.3, & 7x,20i5) else if (thl .ge. 0.0d0) then write (iout,100) k,pol,thl,(pg(j),j=1,npg) 100 format (4x,i8,8x,f10.3,2x,f10.3,7x,20i5) else write (iout,110) k,pol,(pg(j),j=1,npg) 110 format (4x,i8,8x,f10.3,7x,20i5) end if end if else write (iout,120) 120 format (/,' KPOLAR -- Too many Dipole', & ' Polarizability Parameters') abort = .true. end if end if end if end do c c process keywords with specific pair polarization values c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:8) .eq. 'POLPAIR ') then ia = 0 ib = 0 thl = -1.0d0 thd = -1.0d0 string = record(next:240) read (string,*,err=130,end=130) ia,ib,thl,thd 130 continue if (header .and. .not.silent) then header = .false. write (iout,140) 140 format (/,' Additional Polarization Parameters', & ' for Specific Pairs :') if (thd .ge. 0.0d0) then write (iout,150) 150 format (/,5x,'Atom Types',14x,'Thole', & 9x,'TholeD',/) else if (thl .ge. 0.0d0) then write (iout,160) 160 format (/,5x,'Atom Types',14x,'Thole',/) end if end if if (thd.ge.0.0d0 .and. .not.silent) then write (iout,170) ia,ib,thl,thd 170 format (6x,2i4,5x,2f15.4) else if (thl.ge.0.0d0 .and. .not.silent) then write (iout,180) ia,ib,thl 180 format (6x,2i4,5x,f15.4) end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) if (ia .le. ib) then pt = pa//pb else pt = pb//pa end if do k = 1, maxnpp if (kppr(k).eq.blank .or. kppr(k).eq.pt) then kppr(k) = pt thlpr(k) = max(thl,0.0d0) thdpr(k) = max(thd,0.0d0) goto 200 end if end do write (iout,190) 190 format (/,' KPOLAR -- Too many Special Pair', & ' Thole Parameters') abort = .true. 200 continue end if end do c c find and store the atomic dipole polarizability parameters c sixth = 1.0d0 / 6.0d0 npolar = n do i = 1, n polarity(i) = 0.0d0 thole(i) = 0.0d0 tholed(i) = 0.0d0 pdamp(i) = 0.0d0 it = type(i) if (it .ne. 0) then polarity(i) = polr(it) thole(i) = athl(it) tholed(i) = dthl(it) pdamp(i) = polarity(i)**sixth end if end do c c perform dynamic allocation of some global arrays c if (allocated(jpolar)) deallocate (jpolar) allocate (jpolar(n)) c c perform dynamic allocation of some local arrays c allocate (list(n)) allocate (rlist(maxtyp)) c c set atom type index into condensed pair Thole matrices c nlist = n do i = 1, n list(i) = type(i) jpolar(i) = list(i) end do call sort8 (nlist,list) do i = 1, maxtyp rlist(i) = 0 end do do i = 1, n j = jpolar(i) if (rlist(j) .eq. 0) then do k = 1, nlist if (list(k) .eq. j) rlist(j) = k end do end if end do do i = 1, n jpolar(i) = rlist(type(i)) end do c c perform dynamic allocation of some global arrays c if (allocated(thlval)) deallocate (thlval) if (allocated(thdval)) deallocate (thdval) allocate (thlval(nlist,nlist)) allocate (thdval(nlist,nlist)) c c use combination rules for pairwise Thole damping values c do ii = 1, nlist i = list(ii) do kk = ii, nlist k = list(kk) thl = min(athl(i),athl(k)) if (thl .eq. 0.0d0) thl = max(athl(i),athl(k)) thd = min(dthl(i),dthl(k)) if (thd .eq. 0.0d0) thd = max(dthl(i),dthl(k)) thlval(ii,kk) = thl thlval(kk,ii) = thl thdval(ii,kk) = thd thdval(kk,ii) = thd end do end do c c apply Thole damping values for special atom type pairs c do i = 1, maxnpp if (kppr(i) .eq. blank) goto 210 ia = rlist(number(kppr(i)(1:4))) ib = rlist(number(kppr(i)(5:8))) if (ia.ne.0 .and. ib.ne.0) then thlval(ia,ib) = thlpr(i) thlval(ib,ia) = thlpr(i) thdval(ia,ib) = thdpr(i) thdval(ib,ia) = thdpr(i) end if end do 210 continue c c perform deallocation of some local arrays c deallocate (list) deallocate (rlist) c c setup exchange polarization via variable polarizability c call kexpol c c remove zero or undefined electrostatic sites from the list c if ((use_polar .or. use_repel .or. use_solv) & .and. .not.use_chgtrn) then npole = 0 ncp = 0 npolar = 0 nexpol = 0 do i = 1, n if (polarity(i) .eq. 0.0d0) douind(i) = .false. if (polsiz(i).ne.0 .or. polarity(i).ne.0.0d0) then npole = npole + 1 ipole(npole) = i pollist(i) = npole mono0(i) = pole(1,i) if (palpha(i) .ne. 0.0d0) ncp = ncp + 1 if (polarity(i) .ne. 0.0d0) then npolar = npolar + 1 ipolar(npolar) = i douind(i) = .true. end if if (tholed(i) .ne. 0.0d0) use_tholed = .true. if (kpep(i) .ne. 0.0d0) nexpol = nexpol + 1 end if end do end if c c test multipoles at chiral sites and invert if necessary c if (use_polar .and. .not.use_chgtrn) call chkpole c c assign polarization group connectivity of each atom c call polargrp c c turn off polarizable multipole potentials if not used c if (npole .eq. 0) use_mpole = .false. if (ncp .ne. 0) use_chgpen = .true. if (npolar .eq. 0) use_polar = .false. if (ncp .ne. 0) use_thole = .false. if (use_tholed) use_thole = .true. if (nexpol .ne. 0) use_expol = .true. return end c c c ################################################################ c ## ## c ## subroutine polargrp -- polarization group connectivity ## c ## ## c ################################################################ c c c "polargrp" generates members of the polarization group of c each atom and separate lists of the 1-2, 1-3 and 1-4 group c connectivities c c subroutine polargrp use atoms use couple use iounit use kpolr use polgrp implicit none integer i,j,k,m integer it,jt integer jj,kk integer start,stop integer nkeep,nlist integer maxkeep,maxlist integer, allocatable :: keep(:) integer, allocatable :: list(:) integer, allocatable :: mask(:) logical done,abort c c c perform dynamic allocation of some global arrays c if (allocated(np11)) deallocate (np11) if (allocated(np12)) deallocate (np12) if (allocated(np13)) deallocate (np13) if (allocated(np14)) deallocate (np14) if (allocated(ip11)) deallocate (ip11) if (allocated(ip12)) deallocate (ip12) if (allocated(ip13)) deallocate (ip13) if (allocated(ip14)) deallocate (ip14) allocate (np11(n)) allocate (np12(n)) allocate (np13(n)) allocate (np14(n)) allocate (ip11(maxp11,n)) allocate (ip12(maxp12,n)) allocate (ip13(maxp13,n)) allocate (ip14(maxp14,n)) c c initialize size and connectivity of polarization groups c do i = 1, n np11(i) = 1 ip11(1,i) = i np12(i) = 0 np13(i) = 0 np14(i) = 0 end do c c set termination flag and temporary group storage c abort = .false. maxkeep = 100 maxlist = 10000 c c find the directly connected group members for each atom c do i = 1, n it = type(i) if (it .ne. 0) then do j = 1, n12(i) jj = i12(j,i) jt = type(jj) do k = 1, maxval kk = pgrp(k,it) if (kk .eq. 0) goto 20 if (pgrp(k,it) .eq. jt) then if (np11(i) .lt. maxp11) then np11(i) = np11(i) + 1 ip11(np11(i),i) = jj else write (iout,10) 10 format (/,' POLARGRP -- Too many Atoms', & ' in Polarization Group') abort = .true. goto 30 end if end if end do 20 continue end do end if end do 30 continue c c make sure all connected group members are bidirectional c do i = 1, n do j = 1, np11(i) k = ip11(j,i) do m = 1, np11(k) if (ip11(m,k) .eq. i) goto 50 end do write (iout,40) min(i,k),max(i,k) 40 format (/,' POLARGRP -- Check Polarization Groups for', & ' Atoms',i9,' and',i9) abort = .true. 50 continue end do end do c c perform dynamic allocation of some local arrays c allocate (keep(maxkeep)) allocate (list(maxlist)) allocate (mask(n)) c c find any other group members for each atom in turn c do i = 1, n mask(i) = 0 end do do i = 1, n done = .false. start = 1 stop = np11(i) do j = start, stop jj = ip11(j,i) if (jj .lt. i) then done = .true. np11(i) = np11(jj) do k = 1, np11(i) ip11(k,i) = ip11(k,jj) end do else mask(jj) = i end if end do do while (.not. done) done = .true. do j = start, stop jj = ip11(j,i) do k = 1, np11(jj) kk = ip11(k,jj) if (mask(kk) .ne. i) then if (np11(i) .lt. maxp11) then np11(i) = np11(i) + 1 ip11(np11(i),i) = kk else write (iout,60) 60 format (/,' POLARGRP -- Too many Atoms', & ' in Polarization Group') abort = .true. goto 70 end if mask(kk) = i end if end do end do if (np11(i) .ne. stop) then done = .false. start = stop + 1 stop = np11(i) end if end do call sort (np11(i),ip11(1,i)) end do 70 continue if (abort) call fatal c c loop over atoms finding all the 1-2 group relationships c do i = 1, n mask(i) = 0 end do do i = 1, n do j = 1, np11(i) jj = ip11(j,i) mask(jj) = i end do nkeep = 0 do j = 1, np11(i) jj = ip11(j,i) do k = 1, n12(jj) kk = i12(k,jj) if (mask(kk) .ne. i) then nkeep = nkeep + 1 keep(nkeep) = kk end if end do end do nlist = 0 do j = 1, nkeep jj = keep(j) do k = 1, np11(jj) kk = ip11(k,jj) nlist = nlist + 1 list(nlist) = kk end do end do call sort8 (nlist,list) if (nlist .le. maxp12) then np12(i) = nlist do j = 1, nlist ip12(j,i) = list(j) end do else write (iout,80) 80 format (/,' POLARGRP -- Too many Atoms', & ' in 1-2 Polarization Group') abort = .true. goto 90 end if end do 90 continue c c loop over atoms finding all the 1-3 group relationships c do i = 1, n mask(i) = 0 end do do i = 1, n do j = 1, np11(i) jj = ip11(j,i) mask(jj) = i end do do j = 1, np12(i) jj = ip12(j,i) mask(jj) = i end do nlist = 0 do j = 1, np12(i) jj = ip12(j,i) do k = 1, np12(jj) kk = ip12(k,jj) if (mask(kk) .ne. i) then nlist = nlist + 1 list(nlist) = kk end if end do end do call sort8 (nlist,list) if (nlist .le. maxp13) then np13(i) = nlist do j = 1, nlist ip13(j,i) = list(j) end do else write (iout,100) 100 format (/,' POLARGRP -- Too many Atoms', & ' in 1-3 Polarization Group') abort = .true. goto 110 end if end do 110 continue c c loop over atoms finding all the 1-4 group relationships c do i = 1, n mask(i) = 0 end do do i = 1, n do j = 1, np11(i) jj = ip11(j,i) mask(jj) = i end do do j = 1, np12(i) jj = ip12(j,i) mask(jj) = i end do do j = 1, np13(i) jj = ip13(j,i) mask(jj) = i end do nlist = 0 do j = 1, np13(i) jj = ip13(j,i) do k = 1, np12(jj) kk = ip12(k,jj) if (mask(kk) .ne. i) then nlist = nlist + 1 list(nlist) = kk end if end do end do call sort8 (nlist,list) if (nlist .le. maxp14) then np14(i) = nlist do j = 1, nlist ip14(j,i) = list(j) end do else write (iout,120) 120 format (/,' POLARGRP -- Too many Atoms', & ' in 1-4 Polarization Group') abort = .true. goto 130 end if end do 130 continue if (abort) call fatal c c perform deallocation of some local arrays c deallocate (keep) deallocate (list) deallocate (mask) return end c c c ################################################### c ## COPYRIGHT (C) 2022 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module kpolpr -- special Thole forcefield parameters ## c ## ## c ############################################################## c c c maxnpp maximum number of special pair polarization entries c c thlpr Thole damping values for special polarization pairs c thdpr Thole direct damping for special polarization pairs c kppr string of atom types for special polarization pairs c c module kpolpr implicit none integer maxnpp real*8, allocatable :: thlpr(:) real*8, allocatable :: thdpr(:) character*8, allocatable :: kppr(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module kpolr -- polarizability forcefield parameters ## c ## ## c ############################################################## c c c pgrp connected types in polarization group of each atom type c polr dipole polarizability parameters for each atom type c athl Thole polarization damping value for each atom type c dthl alternate Thole direct polarization damping values c c module kpolr implicit none integer, allocatable :: pgrp(:,:) real*8, allocatable :: polr(:) real*8, allocatable :: athl(:) real*8, allocatable :: dthl(:) save end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ############################################################## c ## ## c ## subroutine krepel -- Pauli repulsion term assignment ## c ## ## c ############################################################## c c c "krepel" assigns the size values, exponential parameter and c number of valence electrons for Pauli repulsion interactions c and processes any new or changed values for these parameters c c subroutine krepel use atomid use atoms use inform use iounit use krepl use keys use mpole use potent use repel use reppot use sizes implicit none integer i,j,k integer ia,ic,next real*8 spr,apr,epr logical header character*20 keyword character*240 record character*240 string c c c process keywords containing Pauli repulsion parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:10) .eq. 'REPULSION ') then k = 0 spr = 0.0d0 apr = 0.0d0 epr = 0.0d0 call getnumb (record,k,next) string = record(next:240) read (string,*,err=10,end=10) spr,apr,epr 10 continue if (k .gt. 0) then if (header .and. .not.silent) then header = .false. write (iout,20) 20 format (/,' Additional Pauli Repulsion', & ' Parameters :', & //,5x,'Atom Class',15x,'Size',11x,'Damp', & 8x,'Valence'/) end if if (k .le. maxclass) then prsiz(k) = spr prdmp(k) = apr prele(k) = -abs(epr) if (.not. silent) then write (iout,30) k,spr,apr,epr 30 format (6x,i6,7x,2f15.4,f15.3) end if else write (iout,40) 40 format (/,' KREPEL -- Too many Pauli Repulsion', & ' Parameters') abort = .true. end if end if end if end do c c perform dynamic allocation of some global arrays c if (allocated(irep)) deallocate (irep) if (allocated(replist)) deallocate (replist) if (allocated(sizpr)) deallocate (sizpr) if (allocated(dmppr)) deallocate (dmppr) if (allocated(elepr)) deallocate (elepr) if (allocated(repole)) deallocate (repole) if (allocated(rrepole)) deallocate (rrepole) allocate (irep(n)) allocate (replist(n)) allocate (sizpr(n)) allocate (dmppr(n)) allocate (elepr(n)) allocate (repole(maxpole,n)) allocate (rrepole(maxpole,n)) c c assign the repulsion size, alpha and valence parameters c do i = 1, n irep(i) = 0 replist(i) = 0 sizpr(i) = 0.0d0 dmppr(i) = 0.0d0 elepr(i) = 0.0d0 ic = class(i) if (ic .ne. 0) then sizpr(i) = prsiz(ic) dmppr(i) = prdmp(ic) elepr(i) = prele(ic) end if end do c c process keywords containing atom specific Pauli repulsion c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:10) .eq. 'REPULSION ') then ia = 0 spr = 0.0d0 apr = 0.0d0 epr = 0.0d0 string = record(next:240) read (string,*,err=70,end=70) ia,spr,apr,epr if (ia.lt.0 .and. ia.ge.-n) then ia = -ia if (header .and. .not.silent) then header = .false. write (iout,50) 50 format (/,' Additional Pauli Repulsion Values', & ' for Specific Atoms :', & //,8x,'Atom',17x,'Size',12x,'Damp', & 8x,'Valence'/) end if if (.not. silent) then write (iout,60) ia,spr,apr,epr 60 format (6x,i6,7x,2f15.4,f15.3) end if sizpr(ia) = spr dmppr(ia) = apr elepr(ia) = -abs(epr) end if 70 continue end if end do c c condense repulsion sites to the list of multipole sites c nrep = 0 if (use_repel) then do i = 1, n if (sizpr(i) .ne. 0.0d0) then nrep = nrep + 1 irep(nrep) = i replist(i) = nrep do j = 1, maxpole repole(j,i) = pole(j,i) end do end if end do end if c c test multipoles at chiral sites and invert if necessary c call chkpole c c turn off the Pauli repulsion potential if not used c if (nrep .eq. 0) use_repel = .false. return end c c c ############################################################ c ## COPYRIGHT (C) 2018 by Joshua Rackers & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################ c c ############################################################### c ## ## c ## module krepl -- Pauli repulsion forcefield parameters ## c ## ## c ############################################################### c c c prsiz Pauli repulsion size value for each atom class c prdmp alpha Pauli repulsion parameter for each atom class c prele number of valence electrons for each atom class c c module krepl implicit none real*8, allocatable :: prsiz(:) real*8, allocatable :: prdmp(:) real*8, allocatable :: prele(:) save end c c c ################################################### c ## COPYRIGHT (C) 2020 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module ksolut -- solvation term forcefield parameters ## c ## ## c ############################################################### c c c pbr Poisson-Boltzmann radius value for each atom type c csr ddCOSMO solvation radius value for each atom type c gkr Generalized Kirkwood radius value for each atom type c snk neck correction scale factor for each atom type c c module ksolut implicit none real*8, allocatable :: pbr(:) real*8, allocatable :: csr(:) real*8, allocatable :: gkr(:) real*8, allocatable :: snk(:) save end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine ksolv -- solvation parameter assignment ## c ## ## c ############################################################ c c c "ksolv" assigns implicit solvation energy parameters for c the surface area, generalized Born, generalized Kirkwood, c Poisson-Boltzmann, cavity-dispersion and HPMF models c c subroutine ksolv use sizes use atomid use atoms use inform use iounit use keys use ksolut use potent use solpot use solute implicit none integer i,k,next real*8 pbrd,csrd real*8 gkrd,snek logical header character*20 keyword character*20 value character*240 record character*240 string c c c defaults for implicit solvation term and parameters c use_solv = .false. use_born = .false. solvtyp = ' ' borntyp = ' ' doffset = 0.09d0 onipr = 0.0d0 c c search keywords for implicit solvation commands c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:8) .eq. 'SOLVATE ') then use_solv = .true. use_born = .false. solvtyp = 'ASP' call getword (record,value,next) call upcase (value) if (value(1:3) .eq. 'ASP') then solvtyp = 'ASP' else if (value(1:4) .eq. 'SASA') then solvtyp = 'SASA' else if (value(1:5) .eq. 'ONION') then use_born = .true. solvtyp = 'GB' borntyp = 'ONION' else if (value(1:5) .eq. 'STILL') then use_born = .true. solvtyp = 'GB' borntyp = 'STILL' else if (value(1:3) .eq. 'HCT') then use_born = .true. solvtyp = 'GB' borntyp = 'HCT' else if (value(1:3) .eq. 'OBC') then use_born = .true. solvtyp = 'GB' borntyp = 'OBC' else if (value(1:3) .eq. 'ACE') then use_born = .true. solvtyp = 'GB' borntyp = 'ACE' else if (value(1:7) .eq. 'GB-HPMF') then use_born = .true. solvtyp = 'GB-HPMF' borntyp = 'STILL' else if (value(1:2) .eq. 'GB') then use_born = .true. solvtyp = 'GB' borntyp = 'STILL' else if (value(1:7) .eq. 'GK-HPMF') then use_born = .true. solvtyp = 'GK-HPMF' borntyp = 'GRYCUK' else if (value(1:2) .eq. 'GK') then use_born = .true. solvtyp = 'GK' borntyp = 'GRYCUK' else if (value(1:7) .eq. 'PB-HPMF') then solvtyp = 'PB-HPMF' else if (value(1:2) .eq. 'PB') then solvtyp = 'PB' end if else if (keyword(1:12) .eq. 'BORN-RADIUS ') then call getword (record,value,next) call upcase (value) if (value(1:5) .eq. 'ONION') then borntyp = 'ONION' else if (value(1:5) .eq. 'STILL') then borntyp = 'STILL' else if (value(1:3) .eq. 'HCT') then borntyp = 'HCT' else if (value(1:3) .eq. 'OBC') then borntyp = 'OBC' else if (value(1:3) .eq. 'ACE') then borntyp = 'ACE' else if (value(1:6) .eq. 'GRYCUK') then borntyp = 'GRYCUK' else if (value(1:6) .eq. 'GONION') then borntyp = 'GONION' else if (value(1:7) .eq. 'PERFECT') then borntyp = 'PERFECT' end if else if (keyword(1:12) .eq. 'ONION-PROBE ') then read (string,*,err=10,end=10) onipr else if (keyword(1:18) .eq. 'DIELECTRIC-OFFSET ') then read (string,*,err=10,end=10) doffset if (doffset .lt. 0.0d0) doffset = -doffset end if 10 continue end do c c process keywords containing solvation parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'SOLUTE ') then call getnumb (record,k,next) if (k.ge.1 .and. k.le.maxtyp) then pbrd = 0.0d0 csrd = 0.0d0 gkrd = 0.0d0 snek = 0.0d0 string = record(next:240) read (string,*,err=20,end=20) pbrd,csrd,gkrd,snek 20 continue if (header .and. .not.silent) then header = .false. write (iout,30) 30 format (/,' Additional Solvation Parameters :', & //,5x,'Atom Type',13x,'PB Size',5x,'CS Size', & 5x,'GK Size',6x,'S-Neck',/) end if pbr(k) = 0.5d0 * pbrd csr(k) = 0.5d0 * csrd gkr(k) = 0.5d0 * gkrd snk(k) = snek if (.not. silent) then write (iout,40) k,pbrd,csrd,gkrd,snek 40 format (6x,i6,10x,4f12.4) end if else if (k .gt. maxtyp) then write (iout,50) maxtyp 50 format (/,' KSOLV -- Only Atom Types through',i5, & ' are Allowed') abort = .true. end if end if end do c c perform dynamic allocation of some global arrays c if (allocated(rsolv)) deallocate (rsolv) allocate (rsolv(n)) c c invoke the setup needed for perfect Born radius model c if (borntyp .eq. 'PERFECT') call kpb c c invoke the setup needed for specific solvation models c if (solvtyp.eq.'ASP' .or. solvtyp.eq.'SASA') then call ksa else if (solvtyp .eq. 'GB-HPMF') then call kgb call khpmf else if (solvtyp .eq. 'GB') then call kgb else if (solvtyp .eq. 'GK-HPMF') then call kgk call khpmf else if (solvtyp .eq. 'GK') then call kgk call knp else if (solvtyp .eq. 'PB-HPMF') then call kpb call khpmf else if (solvtyp .eq. 'PB') then call kpb call knp end if return end c c c ################################################################# c ## ## c ## subroutine ksa -- set surface area solvation parameters ## c ## ## c ################################################################# c c c "ksa" initializes parameters needed for surface area-based c implicit solvation models including ASP and SASA c c literature references: c c L. Wesson and D. Eisenberg, "Atomic Solvation Parameters c Applied to Molecular Dynamics of Proteins in Solution", c Protein Science, 1, 227-235 (1992) (Eisenberg-McLachlan ASP) c c T. Ooi, M. Oobatake, G. Nemethy and H. A. Scheraga, "Accessible c Surface Areas as a Measure of the Thermodynamic Parameters of c Hydration of Peptides", PNAS, 84, 3086-3090 (1987) (SASA) c c subroutine ksa use sizes use atomid use atoms use couple use solpot use solute implicit none integer i,j,k integer atmnum c c c perform dynamic allocation of some global arrays c if (allocated(asolv)) deallocate (asolv) allocate (asolv(n)) c c assign the Eisenberg-McLachlan ASP solvation parameters; c parameters only available for protein-peptide groups c if (solvtyp .eq. 'ASP') then do i = 1, n atmnum = atomic(i) if (atmnum .eq. 6) then rsolv(i) = 1.9d0 asolv(i) = 0.004d0 else if (atmnum .eq. 7) then rsolv(i) = 1.7d0 asolv(i) = -0.113d0 if (n12(i) .eq. 4) then asolv(i) = -0.169d0 end if else if (atmnum .eq. 8) then rsolv(i) = 1.4d0 asolv(i) = -0.113d0 if (n12(i).eq.1 .and. atomic(i12(1,i)).eq.6) then do j = 1, n13(i) k = i13(j,i) if (n12(k).eq.1 .and. atomic(k).eq.8) then asolv(i) = -0.166d0 end if end do end if do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 15) asolv(i) = -0.140d0 end do else if (atmnum .eq. 15) then rsolv(i) = 1.9d0 asolv(i) = -0.140d0 else if (atmnum .eq. 16) then rsolv(i) = 1.8d0 asolv(i) = -0.017d0 else rsolv(i) = 0.0d0 asolv(i) = 0.0d0 end if end do end if c c assign the Ooi-Scheraga SASA solvation parameters; c parameters only available for protein-peptide groups c if (solvtyp .eq. 'SASA') then do i = 1, n atmnum = atomic(i) if (atmnum .eq. 6) then rsolv(i) = 2.0d0 asolv(i) = 0.008d0 if (n12(i) .eq. 3) then rsolv(i) = 1.75d0 asolv(i) = -0.008d0 do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 8) then rsolv(i) = 1.55d0 asolv(i) = 0.427d0 end if end do end if else if (atmnum .eq. 7) then rsolv(i) = 1.55d0 asolv(i) = -0.132d0 if (n12(i) .eq. 4) asolv(i) = -1.212d0 else if (atmnum .eq. 8) then rsolv(i) = 1.4d0 if (n12(i) .eq. 1) then asolv(i) = -0.038d0 if (atomic(i12(1,i)) .eq. 6) then do j = 1, n13(i) k = i13(j,i) if (n12(k).eq.1 .and. atomic(k).eq.8) then asolv(i) = -0.770d0 end if end do end if else if (n12(i) .eq. 2) then asolv(i) = -0.172d0 end if do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 15) asolv(i) = -0.717d0 end do else if (atmnum .eq. 15) then rsolv(i) = 2.1d0 asolv(i) = 0.0d0 else if (atmnum .eq. 16) then rsolv(i) = 2.0d0 asolv(i) = -0.021d0 else if (atmnum .eq. 17) then rsolv(i) = 2.0d0 asolv(i) = 0.012d0 else rsolv(i) = 0.0d0 asolv(i) = 0.0d0 end if end do end if return end c c c ############################################################## c ## ## c ## subroutine kgb -- assign generalized Born parameters ## c ## ## c ############################################################## c c c "kgb" initializes parameters needed for the generalized c Born implicit solvation models c c literature references: c c M. Schaefer, C. Bartels, F. Leclerc and M. Karplus, "Effective c Atom Volumes for Implicit Solvent Models: Comparison between c Voronoi Volumes and Minimum Fluctuations Volumes", Journal of c Computational Chemistry, 22, 1857-1879 (2001) (ACE) c c subroutine kgb use sizes use angbnd use atmlst use atomid use atoms use bndstr use chgpot use couple use math use potent use solpot use solute implicit none integer i,j,k,m integer mm,nh,kc integer ia,ib,ic,id integer atmnum,atmmas real*8 ri,ri2,rk,rk2 real*8 c1,c2,c3,pi2 real*8 r,r2,r4,rab,rbc real*8 cosine,factor real*8 h,ratio,term real*8 width,qterm,temp real*8 alpha,alpha2,alpha4 real*8 vk,prod2,prod4 real*8 fik,tik2,qik,uik real*8 s2ik,s3ik,omgik logical amide c c c perform dynamic allocation of some global arrays c if (.not. allocated(wace)) allocate (wace(maxclass,maxclass)) if (.not. allocated(s2ace)) allocate (s2ace(maxclass,maxclass)) if (.not. allocated(uace)) allocate (uace(maxclass,maxclass)) if (allocated(asolv)) deallocate (asolv) if (allocated(rborn)) deallocate (rborn) if (allocated(drb)) deallocate (drb) if (allocated(drobc)) deallocate (drobc) if (allocated(gpol)) deallocate (gpol) if (allocated(shct)) deallocate (shct) if (allocated(aobc)) deallocate (aobc) if (allocated(bobc)) deallocate (bobc) if (allocated(gobc)) deallocate (gobc) if (allocated(vsolv)) deallocate (vsolv) allocate (asolv(n)) allocate (rborn(n)) allocate (drb(n)) allocate (drobc(n)) allocate (gpol(n)) allocate (shct(n)) allocate (aobc(n)) allocate (bobc(n)) allocate (gobc(n)) allocate (vsolv(n)) c c set offset and scaling values for analytical Still method c if (borntyp .eq. 'STILL') then p1 = 0.073d0 p2 = 0.921d0 p3 = 6.211d0 p4 = 15.236d0 p5 = 1.254d0 if (.not. use_bond) call kbond if (.not. use_angle) call kangle end if c c set overlap scale factors for HCT and OBC methods c if (borntyp.eq.'HCT' .or. borntyp.eq.'OBC') then do i = 1, n shct(i) = 0.80d0 atmnum = atomic(i) if (atmnum .eq. 1) shct(i) = 0.85d0 if (atmnum .eq. 6) shct(i) = 0.72d0 if (atmnum .eq. 7) shct(i) = 0.79d0 if (atmnum .eq. 8) shct(i) = 0.85d0 if (atmnum .eq. 9) shct(i) = 0.88d0 if (atmnum .eq. 15) shct(i) = 0.86d0 if (atmnum .eq. 16) shct(i) = 0.96d0 if (atmnum .eq. 26) shct(i) = 0.88d0 end do end if c c set rescaling coefficients for the OBC method c if (borntyp .eq. 'OBC') then do i = 1, n aobc(i) = 1.00d0 bobc(i) = 0.80d0 gobc(i) = 4.85d0 end do end if c c set the Gaussian width factor for the ACE method c if (borntyp .eq. 'ACE') then width = 1.2d0 end if c c assign surface area factors for nonpolar solvation c if (borntyp .eq. 'ONION') then do i = 1, n asolv(i) = 0.0072d0 end do else if (borntyp .eq. 'STILL') then do i = 1, n asolv(i) = 0.0049d0 end do else if (borntyp .eq. 'HCT') then do i = 1, n asolv(i) = 0.0054d0 end do else if (borntyp .eq. 'OBC') then do i = 1, n asolv(i) = 0.0054d0 end do else if (borntyp .eq. 'ACE') then do i = 1, n asolv(i) = 0.0030d0 end do end if c c assign standard radii for GB/SA methods other than ACE; c taken from Macromodel and OPLS-AA, except for hydrogens c if (borntyp .ne. 'ACE') then do i = 1, n atmnum = atomic(i) if (atmnum .eq. 1) then rsolv(i) = 1.25d0 k = i12(1,i) if (atomic(k) .eq. 7) rsolv(i) = 1.15d0 if (atomic(k) .eq. 8) rsolv(i) = 1.05d0 else if (atmnum .eq. 3) then rsolv(i) = 1.432d0 else if (atmnum .eq. 6) then rsolv(i) = 1.90d0 if (n12(i) .eq. 3) rsolv(i) = 1.875d0 if (n12(i) .eq. 2) rsolv(i) = 1.825d0 else if (atmnum .eq. 7) then rsolv(i) = 1.7063d0 if (n12(i) .eq. 4) rsolv(i) = 1.625d0 if (n12(i) .eq. 1) rsolv(i) = 1.60d0 else if (atmnum .eq. 8) then rsolv(i) = 1.535d0 if (n12(i) .eq. 1) rsolv(i) = 1.48d0 else if (atmnum .eq. 9) then rsolv(i) = 1.47d0 else if (atmnum .eq. 10) then rsolv(i) = 1.39d0 else if (atmnum .eq. 11) then rsolv(i) = 1.992d0 else if (atmnum .eq. 12) then rsolv(i) = 1.70d0 else if (atmnum .eq. 14) then rsolv(i) = 1.80d0 else if (atmnum .eq. 15) then rsolv(i) = 1.87d0 else if (atmnum .eq. 16) then rsolv(i) = 1.775d0 else if (atmnum .eq. 17) then rsolv(i) = 1.735d0 else if (atmnum .eq. 18) then rsolv(i) = 1.70d0 else if (atmnum .eq. 19) then rsolv(i) = 2.123d0 else if (atmnum .eq. 20) then rsolv(i) = 1.817d0 else if (atmnum .eq. 35) then rsolv(i) = 1.90d0 else if (atmnum .eq. 36) then rsolv(i) = 1.812d0 else if (atmnum .eq. 37) then rsolv(i) = 2.26d0 else if (atmnum .eq. 53) then rsolv(i) = 2.10d0 else if (atmnum .eq. 54) then rsolv(i) = 1.967d0 else if (atmnum .eq. 55) then rsolv(i) = 2.507d0 else if (atmnum .eq. 56) then rsolv(i) = 2.188d0 else rsolv(i) = 2.0d0 end if end do end if c c compute the atomic volumes for the analytical Still method c if (borntyp .eq. 'STILL') then do i = 1, n vsolv(i) = (4.0d0*pi/3.0d0) * rsolv(i)**3 ri = rsolv(i) ri2 = ri * ri do j = 1, n12(i) k = i12(j,i) rk = rsolv(k) r = 1.01d0 * bl(bndlist(j,i)) ratio = (rk*rk-ri2-r*r) / (2.0d0*ri*r) h = ri * (1.0d0+ratio) term = (pi/3.0d0) * h * h * (3.0d0*ri-h) vsolv(i) = vsolv(i) - term end do end do c c get self-, 1-2 and 1-3 polarization for analytical Still method c do i = 1, n gpol(i) = -0.5d0 * electric / (rsolv(i)-doffset+p1) end do do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) r = bl(i) r4 = r**4 gpol(ia) = gpol(ia) + p2*vsolv(ib)/r4 gpol(ib) = gpol(ib) + p2*vsolv(ia)/r4 end do do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) factor = 1.0d0 do j = 1, n12(ia) id = i12(j,ia) if (id .eq. ic) then factor = 0.0d0 else if (id .ne. ib) then do k = 1, n12(ic) if (i12(k,ic) .eq. id) then factor = 0.5d0 end if end do end if end do do j = 1, n12(ib) if (i12(j,ib) .eq. ia) then rab = bl(bndlist(j,ib)) else if (i12(j,ib) .eq. ic) then rbc = bl(bndlist(j,ib)) end if end do cosine = cos(anat(i)/radian) r2 = rab**2 + rbc**2 - 2.0d0*rab*rbc*cosine r4 = r2 * r2 gpol(ia) = gpol(ia) + factor*p3*vsolv(ic)/r4 gpol(ic) = gpol(ic) + factor*p3*vsolv(ia)/r4 end do end if c c assign the atomic radii and volumes for the ACE method; c volumes taken from average Voronoi values with hydrogens c if (borntyp .eq. 'ACE') then do i = 1, n atmnum = atomic(i) atmmas = nint(mass(i)) if (atmnum .eq. 1) then rsolv(i) = 1.468d0 vsolv(i) = 11.0d0 k = i12(1,i) if (atomic(k).eq.6 .and. n12(k).eq.4) then vsolv(i) = 11.895d0 else if (atomic(k).eq.6 .and. n12(k).eq.3) then vsolv(i) = 13.242d0 else if (atomic(k).eq.7 .and. n12(k).eq.4) then rsolv(i) = 0.60d0 vsolv(i) = 9.138d0 else if (atomic(k).eq.7 .or. atomic(k).eq.8) then rsolv(i) = 0.60d0 vsolv(i) = 9.901d0 else if (atomic(k).ne.16) then rsolv(i) = 1.468d0 vsolv(i) = 13.071d0 end if else if (atmnum .eq. 6) then rsolv(i) = 2.49d0 vsolv(i) = 7.0d0 nh = 0 do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 1) nh = nh + 1 end do if (n12(i) .eq. 4) then if (nh .eq. 3) then vsolv(i) = 3.042d0 else if (nh .eq. 2) then vsolv(i) = 3.743d0 else if (nh .eq. 1) then vsolv(i) = 4.380d0 end if else if (n12(i) .eq. 3) then if (nh .eq. 1) then rsolv(i) = 2.10d0 vsolv(i) = 7.482d0 else if (nh .eq. 0) then rsolv(i) = 2.10d0 vsolv(i) = 8.288d0 end if do j = 1, n12(i) k = i12(1,j) if (atomic(k).eq.8 .and. n12(k).eq.1) then rsolv(i) = 2.10d0 vsolv(i) = 7.139d0 end if end do end if if (atmmas .eq. 15) then rsolv(i) = 2.165d0 vsolv(i) = 33.175d0 else if (atmmas .eq. 14) then rsolv(i) = 2.235d0 vsolv(i) = 20.862d0 else if (atmmas.eq.13 .and. n12(i).eq.2) then rsolv(i) = 2.10d0 vsolv(i) = 20.329d0 else if (atmmas .eq. 13) then rsolv(i) = 2.365d0 vsolv(i) = 11.784d0 end if else if (atmnum .eq. 7) then rsolv(i) = 1.60d0 vsolv(i) = 6.0d0 nh = 0 do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 1) nh = nh + 1 end do if (n12(i) .eq. 4) then if (nh .eq. 3) then vsolv(i) = 2.549d0 else if (nh .eq. 2) then vsolv(i) = 3.304d0 end if else if (n12(i) .eq. 3) then amide = .false. do j = 1, n12(i) m = i12(j,i) if (atomic(m) .eq. 6) then do k = 1, n12(m) mm = i12(k,m) if (atomic(mm).eq.8 .and. n12(mm).eq.1) then amide = .true. end if end do end if end do if (amide) then if (nh .eq. 0) then vsolv(i) = 7.189d0 else if (nh .eq. 1) then vsolv(i) = 6.030d0 else if (nh .eq. 2) then vsolv(i) = 5.693d0 end if else if (nh .eq. 2) then vsolv(i) = 5.677d0 else if (nh .eq. 2) then vsolv(i) = 6.498d0 end if end if end if else if (atmnum .eq. 8) then rsolv(i) = 1.60d0 vsolv(i) = 12.0d0 if (n12(i) .eq. 1) then vsolv(i) = 13.532d0 k = i12(1,i) if (atomic(k) .eq. 15) then vsolv(i) = 17.202d0 else do j = 1, n13(i) k = i13(j,i) if (atomic(j).eq.8 .and. n12(j).eq.1) then vsolv(i) = 15.400d0 end if end do end if else if (n12(i) .eq. 2) then vsolv(i) = 10.642d0 do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 15) vsolv(i) = 11.416d0 end do end if else if (atmnum .eq. 12) then rsolv(i) = 1.0d0 vsolv(i) = 15.235d0 else if (atmnum .eq. 15) then rsolv(i) = 1.89d0 vsolv(i) = 6.131d0 else if (atmnum .eq. 16) then rsolv(i) = 1.89d0 vsolv(i) = 17.232d0 do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 16) vsolv(i) = 18.465d0 end do else if (atmnum .eq. 26) then rsolv(i) = 0.65d0 vsolv(i) = 9.951d0 else rsolv(i) = 0.0d0 vsolv(i) = 0.0d0 end if end do c c calculate the pairwise parameters for the ACE method c c1 = 4.0d0 / (3.0d0*pi) c2 = 77.0d0 * pi * root2 / 512.0d0 c3 = 2.0d0 * pi * rootpi pi2 = 1.0d0 / (pi*pi) do i = 1, n ic = class(i) ri = rsolv(i) ri2 = ri * ri do k = 1, n kc = class(k) rk = rsolv(k) vk = vsolv(kc) rk2 = rk * rk alpha = max(width,ri/rk) alpha2 = alpha * alpha alpha4 = alpha2 * alpha2 prod2 = alpha2 * rk2 prod4 = prod2 * prod2 ratio = alpha2 * rk2 / ri2 tik2 = 0.5d0 * pi * ratio temp = 1.0d0 / (1.0d0+2.0d0*tik2) fik = 2.0d0/(1.0d0+tik2) - temp qik = tik2 * sqrt(temp) qterm = qik - atan(qik) if (k .ne. i) then omgik = vk * qterm * pi2 / prod4 else omgik = c1 * qterm / (alpha4 * ri) end if s2ik = 3.0d0 * qterm * prod2 & / ((3.0d0+fik)*qik-4.0d0*atan(qik)) s3ik = s2ik * sqrt(s2ik) uik = c2 * ri / (1.0d0-(c3*s3ik*ri*omgik/vk)) wace(ic,kc) = omgik s2ace(ic,kc) = s2ik uace(ic,kc) = uik end do end do end if return end c c c ############################################################### c ## ## c ## subroutine kgk -- set generalized Kirkwood parameters ## c ## ## c ############################################################### c c c "kgk" initializes parameters needed for the generalized c Kirkwood implicit solvation model c c subroutine kgk use sizes use atomid use atoms use couple use gkstuf use keys use kvdws use polar use polopt use polpot use ptable use solute use vdw implicit none integer i,it,next integer atmnum real*8 dhct logical descreen logical omithyd logical atomhct character*10 radtyp character*20 keyword character*20 value character*240 record character*240 string c c c perform dynamic allocation of some global arrays c if (allocated(rsolv)) deallocate (rsolv) if (allocated(rdescr)) deallocate (rdescr) if (allocated(rborn)) deallocate (rborn) if (allocated(drb)) deallocate (drb) if (allocated(drbp)) deallocate (drbp) if (allocated(drobc)) deallocate (drobc) if (allocated(shct)) deallocate (shct) if (allocated(udirs)) deallocate (udirs) if (allocated(udirps)) deallocate (udirps) if (allocated(uinds)) deallocate (uinds) if (allocated(uinps)) deallocate (uinps) if (allocated(uopts)) deallocate (uopts) if (allocated(uoptps)) deallocate (uoptps) if (allocated(sneck)) deallocate (sneck) if (allocated(bornint)) deallocate (bornint) allocate (rsolv(n)) allocate (rdescr(n)) allocate (rborn(n)) allocate (drb(n)) allocate (drbp(n)) allocate (drobc(n)) allocate (shct(n)) allocate (udirs(3,n)) allocate (udirps(3,n)) allocate (uinds(3,n)) allocate (uinps(3,n)) allocate (sneck(n)) allocate (bornint(n)) if (poltyp .eq. 'OPT') then allocate (uopts(0:optorder,3,n)) allocate (uoptps(0:optorder,3,n)) end if c c set default value for exponent in the GB/GK function c gkc = 2.455d0 dhct = 0.72d0 descoff = 0.30d0 radtyp = 'SOLUTE' descreen = .true. omithyd = .true. atomhct = .true. useneck = .true. usetanh = .true. c c get any altered generalized Kirkwood values from keyfile c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:4) .eq. 'GKC ') then read (string,*,err=10,end=10) gkc 10 continue else if (keyword(1:10) .eq. 'GK-RADIUS ') then call getword (record,value,next) call upcase (value) if (value(1:3) .eq. 'VDW') then radtyp = 'VDW' else if (value(1:10) .eq. 'MACROMODEL') then radtyp = 'MACROMODEL' else if (value(1:6) .eq. 'AMOEBA') then radtyp = 'AMOEBA' else if (value(1:5) .eq. 'BONDI') then radtyp = 'BONDI' else if (value(1:6) .eq. 'TOMASI') then radtyp = 'TOMASI' else if (value(1:6) .eq. 'SOLUTE') then radtyp = 'SOLUTE' end if else if (keyword(1:11) .eq. 'NODESCREEN ') then descreen = .false. else if (keyword(1:18) .eq. 'DESCREEN-HYDROGEN ') then omithyd = .false. else if (keyword(1:16) .eq. 'DESCREEN-OFFSET ') then read (string,*,err=20,end=20) descoff 20 continue else if (keyword(1:10) .eq. 'HCT-SCALE ') then read (string,*,err=30,end=30) dhct 30 continue else if (keyword(1:12) .eq. 'HCT-ELEMENT ') then call getword (record,value,next) call upcase (value) if (value(1:5) .eq. 'FALSE') then atomhct = .false. end if else if (keyword(1:16) .eq. 'NECK-CORRECTION ') then call getword (record,value,next) call upcase(value) if (value(1:5) .eq. 'FALSE') then useneck = .false. end if else if (keyword(1:16) .eq. 'TANH-CORRECTION ') then call getword (record,value,next) call upcase(value) if (value(1:5) .eq. 'FALSE') then usetanh = .false. end if end if end do c c determine the solute atomic radii values to be used c call setrad (radtyp) c c assign generic value for the overlap scale factor c do i = 1, n shct(i) = dhct rdescr(i) = rsolv(i) if (descreen) then it = jvdw(i) rdescr(i) = 0.5d0 * radmin(it,it) end if c c use overlap scale factors for specific elements c if (atomhct) then atmnum = atomic(i) if (atmnum .eq. 1) shct(i) = 0.72d0 if (atmnum .eq. 6) shct(i) = 0.695d0 if (atmnum .eq. 7) shct(i) = 0.7673d0 if (atmnum .eq. 8) shct(i) = 0.7965d0 if (atmnum .eq. 15) shct(i) = 0.6117d0 if (atmnum .eq. 16) shct(i) = 0.7204d0 end if c c remove hydrogen descreening if it is not to be used c if (omithyd) then atmnum = atomic(i) if (atmnum .eq. 1) shct(i) = 0.0d0 end if end do c c set optimal overlap scale factors for Macromodel radii c if (radtyp .eq. 'MACROMODEL') then do i = 1, n shct(i) = 0.80d0 atmnum = atomic(i) if (atmnum .eq. 1) shct(i) = 0.85d0 if (atmnum .eq. 6) shct(i) = 0.72d0 if (atmnum .eq. 7) shct(i) = 0.79d0 if (atmnum .eq. 8) shct(i) = 0.85d0 if (atmnum .eq. 9) shct(i) = 0.88d0 if (atmnum .eq. 15) shct(i) = 0.86d0 if (atmnum .eq. 16) shct(i) = 0.96d0 if (atmnum .eq. 26) shct(i) = 0.88d0 end do end if return end c c c ############################################################### c ## ## c ## subroutine kpb -- assign Poisson-Boltzmann parameters ## c ## ## c ############################################################### c c c "kpb" assigns parameters needed for the Poisson-Boltzmann c implicit solvation model implemented via APBS c c subroutine kpb use sizes use atomid use atoms use bath use couple use gkstuf use inform use iounit use keys use kvdws use math use nonpol use pbstuf use polar use polopt use polpot use potent use ptable use solute implicit none integer i,j integer nx,ny,nz integer maxgrd,next integer pbtyplen,pbsolnlen integer bcfllen,chgmlen integer srfmlen,pbionq integer trimtext real*8 ri,spacing real*8 gx,gy,gz real*8 xcm,ycm,zcm real*8 total,weigh real*8 xmin,xmax,ymin real*8 ymax,zmin,zmax real*8 xlen,ylen,zlen,minlen real*8 pbionc,pbionr character*10 radtyp character*20 keyword character*20 value character*240 record character*240 string c c c perform dynamic allocation of some global arrays c if (allocated(shct)) deallocate (shct) if (allocated(udirs)) deallocate (udirs) if (allocated(udirps)) deallocate (udirps) if (allocated(uinds)) deallocate (uinds) if (allocated(uinps)) deallocate (uinps) if (allocated(uopts)) deallocate (uopts) if (allocated(uoptps)) deallocate (uoptps) allocate (shct(n)) allocate (udirs(3,n)) allocate (udirps(3,n)) allocate (uinds(3,n)) allocate (uinps(3,n)) if (poltyp .eq. 'OPT') then allocate (uopts(0:optorder,3,n)) allocate (uoptps(0:optorder,3,n)) end if c c assign some default APBS configuration parameters c pbtyp = 'LPBE' pbsoln = 'MG-MANUAL' radtyp = 'SOLUTE' chgm = 'SPL4' srfm = 'MOL ' bcfl = 'MDH' kelvin = 298.0d0 pdie = 1.0d0 sdie = 78.3d0 srad = 0.0d0 swin = 0.3d0 sdens = 10.0d0 smin = 3.0d0 ionn = 0 do i = 1, maxion ionc(i) = 0.0d0 ionq(i) = 1 ionr(i) = 2.0d0 end do spacing = 0.5d0 maxgrd = 513 c c compute the position of the center of mass c total = 0.0d0 xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 do i = 1, n weigh = mass(i) total = total + weigh xcm = xcm + x(i)*weigh ycm = ycm + y(i)*weigh zcm = zcm + z(i)*weigh end do xcm = xcm / total ycm = ycm / total zcm = zcm / total gcent(1) = xcm gcent(2) = ycm gcent(3) = zcm c c set default APBS grid dimension based on system extent c xmin = xcm ymin = ycm zmin = zcm xmax = xcm ymax = ycm zmax = zcm do i = 1, n ri = 1.0 xmin = min(xmin,x(i)-ri) ymin = min(ymin,y(i)-ri) zmin = min(zmin,z(i)-ri) xmax = max(xmax,x(i)+ri) ymax = max(ymax,y(i)+ri) zmax = max(zmax,z(i)+ri) end do xlen = 2.0d0 * (max(xcm-xmin,xmax-xcm)+smin) ylen = 2.0d0 * (max(ycm-ymin,ymax-ycm)+smin) zlen = 2.0d0 * (max(zcm-zmin,zmax-zcm)+smin) dime(1) = int(xlen/spacing) + 1 dime(2) = int(ylen/spacing) + 1 dime(3) = int(zlen/spacing) + 1 c c get any altered APBS parameters from the keyfile c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:13) .eq. 'APBS-MG-AUTO ') then pbsoln = 'MG-AUTO' else if (keyword(1:15) .eq. 'APBS-MG-MANUAL ') then pbsoln = 'MG-MANUAL' else if (keyword(1:10) .eq. 'APBS-GRID ') then nx = dime(1) ny = dime(2) nz = dime(3) read (string,*,err=10,end=10) nx, ny, nz 10 continue if (nx .ge. 33) dime(1) = nx if (ny .ge. 33) dime(2) = ny if (nz .ge. 33) dime(3) = nz else if (keyword(1:11) .eq. 'APBS-RADII ') then call getword (record,value,next) call upcase (value) if (value(1:3) .eq. 'VDW') then radtyp = 'VDW' else if (value(1:10) .eq. 'MACROMODEL') then radtyp = 'MACROMODEL' else if (value(1:5) .eq. 'BONDI') then radtyp = 'BONDI' else if (value(1:6) .eq. 'TOMASI') then radtyp = 'TOMASI' else if (value(1:6) .eq. 'SOLUTE') then radtyp = 'SOLUTE' end if else if (keyword(1:11) .eq. 'APBS-SDENS ') then read (string,*,err=20,end=20) sdens 20 continue else if (keyword(1:10) .eq. 'APBS-PDIE ') then read (string,*,err=30,end=30) pdie 30 continue else if (keyword(1:10) .eq. 'APBS-SDIE ') then read (string,*,err=40,end=40) sdie 40 continue else if (keyword(1:10) .eq. 'APBS-SRAD ') then read (string,*,err=50,end=50) srad 50 continue else if (keyword(1:10) .eq. 'APBS-SWIN ') then read (string,*,err=60,end=60) swin 60 continue else if (keyword(1:10) .eq. 'APBS-SMIN ') then read (string,*,err=70,end=70) smin 70 continue else if (keyword(1:7) .eq. 'PBTYPE ') then call getword (record,value,next) call upcase (value) if (value(1:4) .eq. 'LPBE') then pbtyp = 'LPBE' else if (value(1:4) .eq. 'NPBE') then pbtyp = 'NPBE' end if else if (keyword(1:10) .eq. 'APBS-CHGM ') then call getword (record,value,next) call upcase (value) if (value(1:4) .eq. 'SPL0') then chgm = 'SPL0' else if (value(1:4) .eq. 'SPL2') then chgm = 'SPL2' else if (value(1:4) .eq. 'SPL4') then chgm = 'SPL4' end if else if (keyword(1:10) .eq. 'APBS-SRFM ') then call getword (record,value,next) call upcase (value) if (value(1:3) .eq. 'MOL') then srfm = 'MOL' else if (value(1:4) .eq. 'SMOL') then srfm = 'SMOL' else if (value(1:4) .eq. 'SPL2') then srfm = 'SPL2' else if (value(1:4) .eq. 'SPL4') then srfm = 'SPL4' end if else if (keyword(1:10) .eq. 'APBS-BCFL ') then call getword (record,value,next) call upcase (value) if (value(1:3) .eq. 'ZERO') then bcfl = 'ZERO' else if (value(1:3) .eq. 'MDH') then bcfl = 'MDH' else if (value(1:3) .eq. 'SDH') then bcfl = 'SDH' end if else if (keyword(1:9) .eq. 'APBS-ION ') then pbionc = 0.0d0 pbionq = 1 pbionr = 2.0d0 read (string,*,err=80,end=80) pbionq,pbionc,pbionr 80 continue if (pbionq.ne.0 .and. pbionc.ge.0.0d0 & .and. pbionr.ge.0.0d0) then ionn = ionn + 1 ionc(ionn) = pbionc ionq(ionn) = pbionq ionr(ionn) = pbionr end if end if end do c c set APBS grid spacing for the chosen grid dimension c xlen = 2.0d0 * (max(xcm-xmin,xmax-xcm)+smin) ylen = 2.0d0 * (max(ycm-ymin,ymax-ycm)+smin) zlen = 2.0d0 * (max(zcm-zmin,zmax-zcm)+smin) grid(1) = xlen / dime(1) grid(2) = ylen / dime(2) grid(3) = zlen / dime(3) c c grid spacing must be equal to maintain traceless quadrupoles c grid(1) = min(grid(1),grid(2),grid(3)) grid(2) = grid(1) grid(3) = grid(1) c c set the grid dimensions to the smallest multiples of 32 c dime(1) = 33 dime(2) = 33 dime(3) = 33 c c use minimum side length to maintain equal grid spacing c minlen = min(xlen,ylen,zlen) do while (grid(1)*dime(1) .lt. minlen) dime(1) = dime(1) + 32 end do do while (grid(2)*dime(2) .lt. minlen) dime(2) = dime(2) + 32 end do do while (grid(3)*dime(3) .lt. minlen) dime(3) = dime(3) + 32 end do c c limit the grid dimensions and recompute the grid spacing c dime(1) = min(dime(1),maxgrd) dime(2) = min(dime(2),maxgrd) dime(3) = min(dime(3),maxgrd) grid(1) = xlen / dime(1) grid(2) = ylen / dime(2) grid(3) = zlen / dime(3) c c grid spacing must be equal to maintain traceless quadrupoles c grid(1) = max(grid(1),grid(2),grid(3)) grid(2) = grid(1) grid(3) = grid(1) c c if this is an "mg-auto" (focusing) calculation, set the c fine grid to the default size, and the coarse grid to c twice its original size; currently, all energies and c forces need to be evaluated at the same resolution c if (pbsoln .eq. 'MG-AUTO') then fgrid(1) = grid(1) fgrid(2) = grid(2) fgrid(3) = grid(3) fgcent(1) = gcent(1) fgcent(2) = gcent(2) fgcent(3) = gcent(3) cgrid(1) = 2.0d0 * grid(1) cgrid(2) = 2.0d0 * grid(2) cgrid(3) = 2.0d0 * grid(3) end if c c get any custom APBS grid parameters from the keyfile c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:10) .eq. 'APBS-DIME ') then read (string,*,err=90,end=90) nx,ny,nz dime(1) = nx dime(2) = ny dime(3) = nz 90 continue do j = 1, 3 if (mod(dime(j),32) .ne. 1) then dime(j) = 32*(1+(dime(j)-1)/32) + 1 end if end do else if (keyword(1:11) .eq. 'APBS-AGRID ') then read (string,*,err=100,end=100) gx,gy,gz grid(1) = gx grid(2) = gy grid(3) = gz 100 continue else if (keyword(1:11) .eq. 'APBS-CGRID ') then read (string,*,err=110,end=110) gx,gy,gz cgrid(1) = gx cgrid(2) = gy cgrid(3) = gz 110 continue else if (keyword(1:11) .eq. 'APBS-FGRID ') then read (string,*,err=120,end=120) gx,gy,gz fgrid(1) = gx fgrid(2) = gy fgrid(3) = gz 120 continue else if (keyword(1:11) .eq. 'APBS-GCENT ') then read (string,*,err=130,end=130) gx,gy,gz gcent(1) = gx gcent(2) = gy gcent(3) = gz 130 continue else if (keyword(1:12) .eq. 'APBS-CGCENT ') then read (string,*,err=140,end=140) gx,gy,gz cgcent(1) = gx cgcent(2) = gy cgcent(3) = gz 140 continue else if (keyword(1:12) .eq. 'APBS-FGCENT ') then read (string,*,err=150,end=150) gx,gy,gz fgcent(1) = gx fgcent(2) = gy fgcent(3) = gz 150 continue end if end do c c determine the solute atomic radii values to be used c call setrad (radtyp) c c assign generic value for the HCT overlap scale factor c do i = 1, n shct(i) = 0.69d0 end do c c determine the length of the character arguments c pbtyplen = trimtext (pbtyp) pbsolnlen = trimtext (pbsoln) bcfllen = trimtext (bcfl) chgmlen = trimtext (chgm) srfmlen = trimtext (srfm) c c make call needed to initialize the APBS calculation c call apbsinitial (dime,grid,gcent,cgrid,cgcent,fgrid,fgcent, & pdie,sdie,srad,swin,sdens,kelvin,ionn,ionc, & ionq,ionr,pbtyp,pbtyplen,pbsoln,pbsolnlen, & bcfl,bcfllen,chgm,chgmlen,srfm,srfmlen) c c print out the APBS grid dimensions and spacing c if (verbose) then write (iout,160) (dime(i),i=1,3),grid(1) 160 format (/,' APBS Grid Dimensions and Spacing :', & //,10x,3i8,10x,f10.4) end if return end c c c ############################################################### c ## ## c ## subroutine knp -- assign cavity-dispersion parameters ## c ## ## c ############################################################### c c c "knp" initializes parameters needed for the cavity-plus- c dispersion nonpolar implicit solvation model c c subroutine knp use sizes use atomid use atoms use couple use keys use kvdws use math use nonpol use potent use solpot use solute use vdwpot implicit none integer i,next real*8 cross,ah,ao real*8 rmini,epsi real*8 rmixh,rmixh3 real*8 rmixh7,emixh real*8 rmixo,rmixo3 real*8 rmixo7,emixo real*8 ri,ri3,ri7,ri11 character*20 keyword character*240 record character*240 string c c c set probe radius, solvent pressure and surface tension c cavprb = 1.4d0 solvprs = 0.0334d0 surften = 0.103d0 c c get any altered parameter values from the keyfile c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:13) .eq. 'CAVITY-PROBE ') then read (string,*,err=10,end=10) cavprb else if (keyword(1:17) .eq. 'SOLVENT-PRESSURE ') then read (string,*,err=10,end=10) solvprs else if (keyword(1:16) .eq. 'SURFACE-TENSION ') then read (string,*,err=10,end=10) surften end if 10 continue end do c c set switching function values for pressure and tension c cross = 9.251 = 3.0 * 0.103 / 0.0334 c cross = 3.0d0 * surften / solvprs spcut = cross - 3.5d0 spoff = cross + 3.5d0 c c The SASA term is switched on 0.2 Angtroms after c the cross-over point to give a smooth transition c stcut = cross + 3.5d0 + 0.2d0 stoff = cross - 3.5d0 + 0.2d0 c c perform dynamic allocation of some global arrays c if (allocated(asolv)) deallocate (asolv) if (allocated(radcav)) deallocate (radcav) if (allocated(raddsp)) deallocate (raddsp) if (allocated(epsdsp)) deallocate (epsdsp) if (allocated(cdsp)) deallocate (cdsp) allocate (asolv(n)) allocate (radcav(n)) allocate (raddsp(n)) allocate (epsdsp(n)) allocate (cdsp(n)) c c assign surface area factors for nonpolar solvation c do i = 1, n asolv(i) = surften end do c c set cavity and dispersion radii for nonpolar solvation c do i = 1, n if (vdwindex .eq. 'CLASS') then radcav(i) = rad(class(i)) raddsp(i) = rad(class(i)) epsdsp(i) = eps(class(i)) else radcav(i) = rad(type(i)) raddsp(i) = rad(type(i)) epsdsp(i) = eps(type(i)) end if if (solvtyp .ne. 'PB') radcav(i) = radcav(i) + cavprb end do c c compute maximum dispersion energies for each atom c do i = 1, n epsi = epsdsp(i) rmini = raddsp(i) if (rmini.gt.0.0d0 .and. epsi.gt.0.0d0) then emixo = 4.0d0 * epso * epsi / ((sqrt(epso)+sqrt(epsi))**2) rmixo = 2.0d0 * (rmino**3+rmini**3) / (rmino**2+rmini**2) rmixo3 = rmixo**3 rmixo7 = rmixo**7 ao = emixo * rmixo7 emixh = 4.0d0 * epsh * epsi / ((sqrt(epsh)+sqrt(epsi))**2) rmixh = 2.0d0 * (rminh**3+rmini**3) / (rminh**2+rmini**2) rmixh3 = rmixh**3 rmixh7 = rmixh**7 ah = emixh * rmixh7 ri = 0.5d0*rmixh + dspoff ri3 = ri**3 ri7 = ri**7 ri11 = ri**11 if (ri .lt. rmixh) then cdsp(i) = -4.0d0*pi*emixh*(rmixh3-ri3)/3.0d0 cdsp(i) = cdsp(i) - emixh*18.0d0/11.0d0*rmixh3*pi else cdsp(i) = 2.0d0*pi*(2.0d0*rmixh7-11.0d0*ri7)*ah cdsp(i) = cdsp(i) / (11.0d0*ri11) end if cdsp(i) = 2.0d0 * cdsp(i) ri = 0.5d0*rmixo + dspoff ri3 = ri**3 ri7 = ri**7 ri11 = ri**11 if (ri .lt. rmixo) then cdsp(i) = cdsp(i) - 4.0d0*pi*emixo*(rmixo3-ri3)/3.0d0 cdsp(i) = cdsp(i) - emixo*18.0d0/11.0d0*rmixo3*pi else cdsp(i) = cdsp(i) + 2.0d0*pi*(2.0d0*rmixo7-11.0d0*ri7) & * ao/(11.0d0*ri11) end if end if cdsp(i) = slevy * awater * cdsp(i) end do return end c c c ############################################################### c ## ## c ## subroutine khpmf -- assign hydrophobic PMF parameters ## c ## ## c ############################################################### c c c "khpmf" initializes parameters needed for the hydrophobic c potential of mean force nonpolar implicit solvation model c c literature reference: c c M. S. Lin, N. L. Fawzi and T. Head-Gordon, "Hydrophobic c Potential of Mean Force as a Solvation Function for Protein c Structure Prediction", Structure, 15, 727-740 (2007) c c subroutine khpmf use sizes use atomid use atoms use couple use hpmf use ptable implicit none integer i,j,k integer nh,atn logical keep c c c perform dynamic allocation of some global arrays c if (allocated(ipmf)) deallocate (ipmf) if (allocated(rpmf)) deallocate (rpmf) if (allocated(acsa)) deallocate (acsa) allocate (ipmf(n)) allocate (rpmf(n)) allocate (acsa(n)) c c get carbons for PMF and set surface area screening values c npmf = 0 do i = 1, n if (atomic(i) .eq. 6) then keep = .true. nh = 0 if (n12(i) .le. 2) keep = .false. do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 1) nh = nh + 1 if (n12(i).eq.3 .and. atomic(k).eq.8) keep = .false. end do if (keep) then npmf = npmf + 1 ipmf(npmf) = i acsa(i) = 1.0d0 if (n12(i).eq.3 .and. nh.eq.0) acsa(i) = 1.554d0 if (n12(i).eq.3 .and. nh.eq.1) acsa(i) = 1.073d0 if (n12(i).eq.4 .and. nh.eq.1) acsa(i) = 1.276d0 if (n12(i).eq.4 .and. nh.eq.2) acsa(i) = 1.045d0 if (n12(i).eq.4 .and. nh.eq.3) acsa(i) = 0.880d0 acsa(i) = acsa(i) * safact/acsurf end if end if end do c c assign HPMF atomic radii from consensus vdw values c do i = 1, n rpmf(i) = 1.0d0 atn = atomic(i) if (atn .eq. 0) then rpmf(i) = 0.00d0 else rpmf(i) = vdwrad(atn) end if if (atn .eq. 5) rpmf(i) = 1.80d0 if (atn .eq. 8) rpmf(i) = 1.50d0 if (atn .eq. 35) rpmf(i) = 1.85d0 end do return end c c c ################################################################ c ## ## c ## subroutine setrad -- assign solute radii for PB and GK ## c ## ## c ################################################################ c c c "setrad" chooses a set of solute atom atomic radii to use c during Generalized Kirkwood and Poission-Boltzmann implicit c solvation calculations c c subroutine setrad (radtyp) use sizes use atomid use atoms use bath use couple use inform use iounit use keys use ksolut use kvdws use math use nonpol use polar use potent use ptable use vdw use solpot use solute implicit none integer i,j,k,l,m integer it integer atmnum integer nheavy real*8 rscale real*8 offset character*10 radtyp c c c assign default solute radii from consensus vdw values c do i = 1, n atmnum = atomic(i) if (atmnum .eq. 0) rsolv(i) = 0.0d0 rsolv(i) = vdwrad(atmnum) end do c c assign solute atomic radii from force field vdw values c if (radtyp .eq. 'VDW') then do i = 1, n k = jvdw(i) rsolv(i) = 2.0d0 if (k .ne. 0) then rsolv(i) = 0.5d0 * radmin(k,k) end if end do c c assign solute radii from parametrized solvation values c else if (radtyp .eq. 'SOLUTE') then if (solvtyp(1:2) .eq. 'GK') then do i = 1, n it = type(i) if (it .ne. 0) then if (gkr(it) .ne. 0.0d0) then rsolv(i) = gkr(type(i)) end if end if end do else if (solvtyp(1:2) .eq. 'PB') then do i = 1, n it = type(i) if (it .ne. 0) then if (pbr(it) .ne. 0.0d0) then rsolv(i) = pbr(type(i)) end if end if end do end if c c set and store neck correction ranges and parameters c call initneck c c get neck correction via a bonded connectivity scheme c if (useneck) then do i = 1, n it = type(i) atmnum = atomic(i) if (atmnum .gt. 1) then nheavy = 0 do j = 1, n12(i) if (atomic(i12(j,i)) .gt. 1) then nheavy = nheavy + 1 end if end do if (nheavy .eq. 0) then sneck(i) = 1.0 else sneck(i) = snk(it) * (5.0d0-nheavy)/4.0d0 end if end if end do c c hydrogen neck contribution same as bound heavy atom c do i = 1, n do k = 1, n12(i) if (atomic(i12(k,i)) .eq. 1) then sneck(i12(k,i)) = sneck(i) end if end do end do end if c c assign solute atomic radii adapted from Macromodel c else if (radtyp .eq. 'MACROMODEL') then do i = 1, n atmnum = atomic(i) if (atmnum .eq. 0) rsolv(i) = 0.0d0 rsolv(i) = vdwrad(atmnum) if (atmnum .eq. 1) then rsolv(i) = 1.25d0 k = i12(1,i) if (atomic(k) .eq. 7) rsolv(i) = 1.15d0 if (atomic(k) .eq. 8) rsolv(i) = 1.05d0 else if (atmnum .eq. 3) then rsolv(i) = 1.432d0 else if (atmnum .eq. 6) then rsolv(i) = 1.90d0 if (n12(i) .eq. 3) rsolv(i) = 1.875d0 if (n12(i) .eq. 2) rsolv(i) = 1.825d0 else if (atmnum .eq. 7) then rsolv(i) = 1.7063d0 if (n12(i) .eq. 4) rsolv(i) = 1.625d0 if (n12(i) .eq. 1) rsolv(i) = 1.60d0 else if (atmnum .eq. 8) then rsolv(i) = 1.535d0 if (n12(i) .eq. 1) rsolv(i) = 1.48d0 else if (atmnum .eq. 9) then rsolv(i) = 1.47d0 else if (atmnum .eq. 10) then rsolv(i) = 1.39d0 else if (atmnum .eq. 11) then rsolv(i) = 1.992d0 else if (atmnum .eq. 12) then rsolv(i) = 1.70d0 else if (atmnum .eq. 14) then rsolv(i) = 1.80d0 else if (atmnum .eq. 15) then rsolv(i) = 1.87d0 else if (atmnum .eq. 16) then rsolv(i) = 1.775d0 else if (atmnum .eq. 17) then rsolv(i) = 1.735d0 else if (atmnum .eq. 18) then rsolv(i) = 1.70d0 else if (atmnum .eq. 19) then rsolv(i) = 2.123d0 else if (atmnum .eq. 20) then rsolv(i) = 1.817d0 else if (atmnum .eq. 35) then rsolv(i) = 1.90d0 else if (atmnum .eq. 36) then rsolv(i) = 1.812d0 else if (atmnum .eq. 37) then rsolv(i) = 2.26d0 else if (atmnum .eq. 53) then rsolv(i) = 2.10d0 else if (atmnum .eq. 54) then rsolv(i) = 1.967d0 else if (atmnum .eq. 55) then rsolv(i) = 2.507d0 else if (atmnum .eq. 56) then rsolv(i) = 2.188d0 end if end do c c assign solute atomic radii as modified Bondi values c else if (radtyp .eq. 'AMOEBA') then do i = 1, n atmnum = atomic(i) if (atmnum .eq. 0) rsolv(i) = 0.0d0 rsolv(i) = vdwrad(atmnum) if (atmnum .eq. 1) then rsolv(i) = 1.32d0 k = i12(1,i) if (atomic(k) .eq. 7) rsolv(i) = 1.10d0 if (atomic(k) .eq. 8) rsolv(i) = 1.05d0 end if if (atmnum .eq. 3) rsolv(i) = 1.50d0 if (atmnum .eq. 6) then rsolv(i) = 2.00d0 if (n12(i) .eq. 3) rsolv(i) = 2.05d0 if (n12(i) .eq. 4) then do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 7) rsolv(i) = 1.75d0 if (atomic(k) .eq. 8) rsolv(i) = 1.75d0 end do end if end if if (atmnum .eq. 7) then rsolv(i) = 1.60d0 end if if (atmnum .eq. 8) then rsolv(i) = 1.55d0 if (n12(i) .eq. 2) rsolv(i) = 1.45d0 end if end do c c make Tomasi-style modifications to the solute radii values c else if (radtyp .eq. 'TOMASI') then do i = 1, n offset = 0.0d0 atmnum = atomic(i) if (atomic(i) .eq. 1) then do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 6) then do l = 1, n12(k) m = i12(l,k) if (atomic(m) .eq. 7) offset = -0.05d0 if (atomic(m) .eq. 8) offset = -0.10d0 end do end if if (atomic(k) .eq. 7) offset = -0.25d0 if (atomic(k) .eq. 8) offset = -0.40d0 if (atomic(k) .eq. 16) offset = -0.10d0 end do else if (atomic(i) .eq. 6) then if (n12(i) .eq. 4) offset = 0.05d0 if (n12(i) .eq. 3) offset = 0.02d0 if (n12(i) .eq. 2) offset = -0.03d0 do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 6) offset = offset - 0.07d0 end do do j = 1, n12(i) k = i12(j,i) if (atomic(k).eq.7 .and. n12(k).eq.4) & offset = -0.20d0 if (atomic(k).eq.7 .and. n12(k).eq.3) & offset = -0.25d0 if (atomic(k) .eq. 8) offset = -0.20d0 end do else if (atomic(i) .eq. 7) then if (n12(i) .eq. 3) then offset = -0.10d0 do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 6) offset = offset - 0.24d0 end do else offset = -0.20d0 do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 6) offset = offset - 0.16d0 end do end if else if (atomic(i) .eq. 8) then if (n12(i) .eq. 2) then offset = -0.21d0 do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 6) offset = -0.36d0 end do else offset = -0.25d0 end if else if (atomic(i) .eq. 16) then offset = -0.03d0 do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 6) offset = offset - 0.10d0 end do end if rsolv(i) = rsolv(i) + offset end do end if c c apply an overall scale factor to the solute atomic radii c rscale = 1.0d0 if (radtyp .eq. 'MACROMODEL') rscale = 1.15d0 if (radtyp .eq. 'BONDI') rscale = 1.21d0 if (radtyp .eq. 'TOMASI') rscale = 1.47d0 do i = 1, n rsolv(i) = rsolv(i) * rscale 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 kstbnd -- stretch-bend forcefield parameters ## c ## ## c ############################################################# c c c maxnsb maximum number of stretch-bend parameter entries c c stbn force constant parameters for stretch-bend terms c ksb string of atom classes for stretch-bend terms c c module kstbnd implicit none integer maxnsb real*8, allocatable :: stbn(:,:) character*12, allocatable :: ksb(:) save end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine kstrbnd -- assign stretch-bend parameters ## c ## ## c ############################################################## c c c "kstrbnd" assigns parameters for stretch-bend interactions c and processes new or changed parameter values c c subroutine kstrbnd use angbnd use angpot use atmlst use atomid use atoms use couple use fields use inform use iounit use keys use kstbnd use potent use strbnd implicit none integer i,j,k,nsb integer ia,ib,ic integer ita,itb,itc integer nba,nbc integer size,next real*8 sb1,sb2,temp logical header character*4 pa,pb,pc character*12 blank,pt character*20 keyword character*240 record character*240 string c c c process keywords containing stretch-bend parameters c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'STRBND ') then ia = 0 ib = 0 ic = 0 sb1 = 0.0d0 sb2 = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,sb1,sb2 10 continue if (min(ia,ib,ic) .lt. 0) goto 50 if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Stretch-Bend Parameters :', & //,5x,'Atom Classes',10x,'K(SB)-1',8x, & 'K(SB)-2',/) end if write (iout,30) ia,ib,ic,sb1,sb2 30 format (4x,3i4,3x,2f15.3) end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) if (ia .le. ic) then pt = pa//pb//pc else pt = pc//pb//pa temp = sb1 sb1 = sb2 sb2 = temp end if do j = 1, maxnsb if (ksb(j).eq.blank .or. ksb(j).eq.pt) then ksb(j) = pt stbn(1,j) = sb1 stbn(2,j) = sb2 goto 50 end if end do write (iout,40) 40 format (/,' KSTRBND -- Too many Stretch-Bend', & ' Interaction Parameters') abort = .true. 50 continue end if end do c c determine the total number of forcefield parameters c nsb = maxnsb do i = maxnsb, 1, -1 if (ksb(i) .eq. blank) nsb = i - 1 end do c c perform dynamic allocation of some global arrays c if (allocated(isb)) deallocate (isb) if (allocated(sbk)) deallocate (sbk) allocate (isb(3,nangle)) allocate (sbk(2,nangle)) c c use special stretch-bend parameter assignment method for MMFF c if (forcefield .eq. 'MMFF94') then call kstrbndm return end if c c assign the stretch-bend parameters for each angle c nstrbnd = 0 if (nsb .ne. 0) then do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pt = pa//pb//pc else pt = pc//pb//pa end if do j = 1, nsb if (ksb(j) .eq. pt) then nstrbnd = nstrbnd + 1 do k = 1, n12(ib) if (i12(k,ib) .eq. ia) nba = bndlist(k,ib) if (i12(k,ib) .eq. ic) nbc = bndlist(k,ib) end do isb(1,nstrbnd) = i isb(2,nstrbnd) = nba isb(3,nstrbnd) = nbc if (ita .le. itc) then sbk(1,nstrbnd) = stbn(1,j) sbk(2,nstrbnd) = stbn(2,j) else sbk(1,nstrbnd) = stbn(2,j) sbk(2,nstrbnd) = stbn(1,j) end if goto 60 end if end do 60 continue end do end if c c process keywords containing stretch-bend specific parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'STRBND ') then ia = 0 ib = 0 ic = 0 sb1 = 0.0d0 sb2 = 0.0d0 string = record(next:240) read (string,*,err=70,end=70) ia,ib,ic,sb1,sb2 70 continue if (min(ia,ib,ic) .lt. 0) then ia = abs(ia) ib = abs(ib) ic = abs(ic) if (header .and. .not.silent) then header = .false. write (iout,80) 80 format (/,' Additional Stretch-Bend Parameters :', & ' for Specific Angles :', & //,8x,'Atoms',14x,'K(SB)-1',8x,'K(SB)-2',/) end if if (.not. silent) then write (iout,90) ia,ib,ic,sb1,sb2 90 format (4x,3i4,3x,2f15.3) end if do j = 1, nstrbnd k = isb(1,j) ita = iang(1,k) itb = iang(2,k) itc = iang(3,k) if (ib .eq. itb) then if ((ia.eq.ita .and. ic.eq.itc) .or. & (ia.eq.itc .and. ic.eq.ita)) then sbk(1,j) = sb1 sbk(2,j) = sb2 goto 100 end if end if end do end if 100 continue end if end do c c turn off the stretch-bend potential if it is not used c if (nstrbnd .eq. 0) use_strbnd = .false. return end c c c ############################################################### c ## ## c ## subroutine kstrbndm -- assign MMFF str-bnd parameters ## c ## ## c ############################################################### c c c "kstrbndm" assigns parameters for stretch-bend interactions c according to the Merck Molecular Force Field (MMFF) c c note "stbnt" is the MMFF stretch-bend type for angle "a-b-c", c where atom "a" has a smaller class number than atom "c" c c if the BT of a-b = 1, then stbnt = 1 c if the BT of b-c = 1, then stbnt = 2 c if both = 1, then stbnt = 3 c if 4-membered ring, then stbnt = 4 c if 3-membered ring, then stbnt = 5 c if 3-membered ring with BT of a-b = 1, then stbnt = 6 c if 3-membered ring with BT of b-c = 1, then stbnt = 7 c if 3-membered ring with BT of both = 1, then stbnt = 8 c if 4-membered ring with BT of a-b = 1, then stbnt = 9 c if 4-membered ring with BT of b-c = 1, then stbnt = 10 c if 4-membered ring with BT of both = 1, then stbnt = 11 c else, if all BT = 0 and no small ring, then stbnt = 0 c c literature references: c c T. A. Halgren, "Merck Molecular Force Field. I. Basis, Form, c Scope, Parametrization, and Performance of MMFF94", Journal of c Computational Chemistry, 17, 490-519 (1995) c c T. A. Halgren, "Merck Molecular Force Field. V. Extension of c MMFF94 Using Experimental Data, Additional Computational Data, c and Empirical Rules", Journal of Computational Chemistry, 17, c 616-641 (1995) c c subroutine kstrbndm use angbnd use atmlst use atomid use couple use merck use potent use ring use strbnd implicit none integer i,j,k,l,m integer ia,ib,ic integer ita,itb,itc integer ina,inb,inc integer ira,irb,irc integer nb1,nb2 integer stbnt,ab,bc logical ring3,ring4 c c c assign stretch-bend parameters for each angle c nstrbnd = 0 do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) c c stretch-bend interactions are omitted for linear angles c if (lin(class(ib)) .eq. 0) then ita = class(ia) itb = class(ib) itc = class(ic) ina = atomic(ia) inb = atomic(ib) inc = atomic(ic) sbk(1,nstrbnd+1) = 0.0d0 sbk(2,nstrbnd+1) = 0.0d0 do k = 1, n12(ib) if (i12(k,ib) .eq. ia) nb1 = bndlist(k,ib) if (i12(k,ib) .eq. ic) nb2 = bndlist(k,ib) end do stbnt = 0 ab = 0 bc = 0 c c check if the atoms belong to a single 3- or 4-membered ring c ring3 = .false. ring4 = .false. do j = 1, nring3 do k = 1, 3 if (ia .eq. iring3(k,j)) then do l = 1, 3 if (ib .eq. iring3(l,j)) then do m = 1, 3 if (ic .eq. iring3(m,j)) & ring3 = .true. end do end if end do end if end do end do if (.not. ring3) then do j = 1, nring4 do k = 1, 4 if (ia .eq. iring4(k,j)) then do l = 1, 4 if (ib .eq. iring4(l,j)) then do m = 1, 4 if (ic .eq. iring4(m,j)) & ring4 = .true. end do end if end do end if end do end do end if c c determine the MMFF stretch-bend type for the current angle c if (ita .lt. itc) then do j = 1, nligne if (((ia.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or. & (ib.eq.bt_1(j,1).and.ia.eq.bt_1(j,2)))) then ab = 1 end if if (((ic.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or. & (ib.eq.bt_1(j,1).and.ic.eq.bt_1(j,2)))) then bc = 1 end if end do if (ab.eq.1 .and. bc.eq.0) stbnt = 1 if (ab.eq.0 .and. bc.eq.1) stbnt = 2 if (ab.eq.1 .and. bc.eq.1) stbnt = 3 if (stbnt.eq.0 .AND. ring3) then stbnt = 5 else if (stbnt.eq.1 .and. ring3) then stbnt = 6 else if (stbnt.eq.2 .and. ring3) then stbnt = 7 else if (stbnt.eq.3 .and. ring3) then stbnt = 8 else if (stbnt.eq.0 .and. ring4) then stbnt = 4 else if (stbnt.eq.1 .and. ring4) then stbnt = 9 else if (stbnt.eq.2 .and. ring4) then stbnt = 10 else if (stbnt.eq.3 .and. ring4) then stbnt = 11 end if else if (ita .gt. itc) then do j = 1, nligne if (((ia.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or. & (ib.eq.bt_1(j,1).and.ia.eq.bt_1(j,2)))) then ab = 1 end if if (((ic.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or. & (ib.eq.bt_1(j,1).and.ic.eq.bt_1(j,2)))) then bc = 1 end if end do if (ab.eq.1 .and. bc.eq.0) stbnt = 2 if (ab.eq.0 .and. bc.eq.1) stbnt = 1 if (ab.eq.1 .and. bc.eq.1) stbnt = 3 if (stbnt.eq.0 .and. ring3) then stbnt = 5 else if (stbnt.eq.1 .and. ring3) then stbnt = 6 else if (stbnt.eq.2 .and. ring3) then stbnt = 7 else if (stbnt.eq.3 .and. ring3) then stbnt = 8 else if (stbnt.eq.0 .and. ring4) then stbnt = 4 else if (stbnt.eq.1 .and. ring4) then stbnt = 9 else if (stbnt.eq.2 .and. ring4) then stbnt = 10 else if (stbnt.eq.3 .and. ring4) then stbnt = 11 end if else if (ita .eq. itc) then do j = 1, nligne if (((ic.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or. & (ib.eq.bt_1(j,1).and.ic.eq.bt_1(j,2)))) then bc = 1 end if if (((ia.eq.bt_1(j,1).and.ib.eq.bt_1(j,2)) .or. & (ib.eq.bt_1(j,1).and.ia.eq.bt_1(j,2)))) then ab = 1 end if end do if (ab.eq.1 .and. bc.eq.0) stbnt = 1 if (ab.eq.0 .and. bc.eq.1) stbnt = 2 if (ab.eq.1 .and. bc.eq.1) stbnt = 3 if (stbnt.eq.0 .and. ring3) then stbnt = 5 else if (stbnt.eq.1 .and. ring3) then stbnt = 6 else if (stbnt.eq.2 .and. ring3) then stbnt = 7 else if (stbnt.eq.3 .and. ring3) then stbnt = 8 else if (stbnt.eq.0 .and. ring4) then stbnt = 4 else if (stbnt.eq.1 .and. ring4) then stbnt = 9 else if (stbnt.eq.2 .and. ring4) then stbnt = 10 else if (stbnt.eq.3 .and. ring4) then stbnt = 11 end if end if c c find the periodic table row for the atoms in the angle c if (ina .eq. 1) ira = 0 if (ina.ge.3 .and. ina.le.10) ira = 1 if (ina.ge.11 .and. ina.le.18) ira = 2 if (ina.ge.19 .and. ina.le.36) ira = 3 if (ina.ge.37 .and. ina.le.54) ira = 4 if (inb .eq. 1) irb = 0 if (inb.ge.3 .and. inb.le.10) irb = 1 if (inb.ge.11 .and. inb.le.18) irb = 2 if (inb.ge.19 .and. inb.le.36) irb = 3 if (inb.ge.37 .and. inb.le.54) irb = 4 if (inc .eq. 1) irc = 0 if (inc.ge.3 .and. inc.le.10) irc = 1 if (inc.ge.11 .and. inc.le.18) irc = 2 if (inc.ge.19 .and. inc.le.36) irc = 3 if (inc.ge.37 .and. inc.le.54) irc = 4 c c assign parameters via explicit values or empirical rules c if (stbnt .eq. 11) then if ((stbn_abc11(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba11(ita,itb,itc).ne.1000.0d0)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc11(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba11(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 10) then if ((stbn_abc10(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba10(ita,itb,itc).ne.1000.0d0)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc10(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba10(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 9) then if ((stbn_abc9(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba9(ita,itb,itc).ne.1000.0d0)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc9(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba9(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 8) then if ((stbn_abc8(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba3(ita,itb,itc).ne.1000.0d0)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc8(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba8(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 7) then if ((stbn_abc7(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba7(ita,itb,itc).ne.1000.0d0)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc7(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba7(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 6) then if ((stbn_abc6(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba3(ita,itb,itc).ne.1000.0d0)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc6(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba6(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 5) then if (((stbn_abc5(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba3(ita,itb,itc).ne.1000.0d0)) & .or. (ita.eq.22.and.itb.eq.22.and.itc.eq.22)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc5(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba5(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 4) then if ((stbn_abc4(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba4(ita,itb,itc).ne.1000.0d0)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc4(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba4(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 3) then if ((stbn_abc3(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba3(ita,itb,itc).ne.1000.0d0)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc3(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba3(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 2) then if ((stbn_abc2(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba2(ita,itb,itc).ne.1000.0d0)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc2(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba2(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 1) then if ((stbn_abc1(ita,itb,itc).ne.1000.0d0) .and. & (stbn_cba1(ita,itb,itc).ne.1000.0d0)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc1(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba1(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if else if (stbnt .eq. 0) then if (((stbn_abc(ita,itb,itc) .ne. 1000.0d0) .and. & (stbn_cba(ita,itb,itc) .ne. 1000.0d0)) & .or. (ita.eq.12.AND.itb.eq.20.AND.itc.eq.20) & .or. (ita.eq.20.AND.itb.eq.20.AND.itc.eq.12)) then nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = stbn_abc(ita,itb,itc) sbk(2,nstrbnd) = stbn_cba(ita,itb,itc) else nstrbnd = nstrbnd + 1 isb(1,nstrbnd) = i isb(2,nstrbnd) = nb1 isb(3,nstrbnd) = nb2 sbk(1,nstrbnd) = defstbn_abc(ira,irb,irc) sbk(2,nstrbnd) = defstbn_cba(ira,irb,irc) end if end if end if end do c c turn off the stretch-bend potential if it is not used c if (nstrbnd .eq. 0) use_strbnd = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine kstrtor -- find stretch-torsion parameters ## c ## ## c ############################################################### c c c "kstrtor" assigns stretch-torsion parameters to torsions c needing them, and processes any new or changed values c c subroutine kstrtor use atmlst use atomid use atoms use couple use inform use iounit use keys use ksttor use potent use strtor use tors implicit none integer i,j,k,nbt integer ia,ib,ic,id integer ita,itb,itc,itd integer size,next real*8 bt1,bt2,bt3 real*8 bt4,bt5,bt6 real*8 bt7,bt8,bt9 logical header,swap character*4 pa,pb,pc,pd character*4 zeros character*16 blank character*16 pt,pt0 character*20 keyword character*240 record character*240 string c c c process keywords containing stretch-torsion parameters c blank = ' ' zeros = '0000' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:8) .eq. 'STRTORS ') then ia = 0 ib = 0 ic = 0 id = 0 bt1 = 0.0d0 bt2 = 0.0d0 bt3 = 0.0d0 bt4 = 0.0d0 bt5 = 0.0d0 bt6 = 0.0d0 bt7 = 0.0d0 bt8 = 0.0d0 bt9 = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,id,bt1,bt2,bt3, & bt4,bt5,bt6,bt7,bt8,bt9 10 continue size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) if (ib .lt. ic) then pt = pa//pb//pc//pd swap = .false. else if (ic .lt. ib) then pt = pd//pc//pb//pa swap = .true. else if (ia .le. id) then pt = pa//pb//pc//pd swap = .false. else if (id .lt. ia) then pt = pd//pc//pb//pa swap = .true. end if if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Stretch-Torsion Parameters :', & //,5x,'Atom Classes',10x,'Stretch', & 9x,'1-Fold',6x,'2-Fold',6x,'3-Fold',/) end if write (iout,30) ia,ib,ic,id,bt1,bt2,bt3, & bt4,bt5,bt6,bt7,bt8,bt9 30 format (2x,4i4,8x,'1st Bond',3x,3f12.3, & /,26x,'2nd Bond',3x,3f12.3, & /,26x,'3rd Bond',3x,3f12.3) end if do j = 1, maxnbt if (kbt(j).eq.blank .or. kbt(j).eq.pt) then kbt(j) = pt btcon(4,j) = bt4 btcon(5,j) = bt5 btcon(6,j) = bt6 if (swap) then btcon(1,j) = bt7 btcon(2,j) = bt8 btcon(3,j) = bt9 btcon(7,j) = bt1 btcon(8,j) = bt2 btcon(9,j) = bt3 else btcon(1,j) = bt1 btcon(2,j) = bt2 btcon(3,j) = bt3 btcon(7,j) = bt7 btcon(8,j) = bt8 btcon(9,j) = bt9 end if goto 50 end if end do write (iout,40) 40 format (/,' KSTRTOR -- Too many Stretch-Torsion', & ' Parameters') abort = .true. 50 continue end if end do c c determine the total number of forcefield parameters c nbt = maxnbt do i = maxnbt, 1, -1 if (kbt(i) .eq. blank) nbt = i - 1 end do c c perform dynamic allocation of some global arrays c if (allocated(ist)) deallocate (ist) if (allocated(kst)) deallocate (kst) allocate (ist(4,ntors)) allocate (kst(9,ntors)) c c assign the stretch-torsion parameters for each torsion c nstrtor = 0 if (nbt .ne. 0) then do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .lt. itc) then pt = pa//pb//pc//pd swap = .false. else if (itc .lt. itb) then pt = pd//pc//pb//pa swap = .true. else if (ita .le. itd) then pt = pa//pb//pc//pd swap = .false. else if (itd .lt. ita) then pt = pd//pc//pb//pa swap = .true. end if pt0 = zeros//pt(5:12)//zeros do j = 1, nbt if (kbt(j) .eq. pt) then nstrtor = nstrtor + 1 kst(4,nstrtor) = btcon(4,j) kst(5,nstrtor) = btcon(5,j) kst(6,nstrtor) = btcon(6,j) if (swap) then kst(1,nstrtor) = btcon(7,j) kst(2,nstrtor) = btcon(8,j) kst(3,nstrtor) = btcon(9,j) kst(7,nstrtor) = btcon(1,j) kst(8,nstrtor) = btcon(2,j) kst(9,nstrtor) = btcon(3,j) else kst(1,nstrtor) = btcon(1,j) kst(2,nstrtor) = btcon(2,j) kst(3,nstrtor) = btcon(3,j) kst(7,nstrtor) = btcon(7,j) kst(8,nstrtor) = btcon(8,j) kst(9,nstrtor) = btcon(9,j) end if ist(1,nstrtor) = i do k = 1, n12(ia) if (i12(k,ia) .eq. ib) then ist(2,nstrtor) = bndlist(k,ia) goto 60 endif end do 60 continue do k = 1, n12(ib) if (i12(k,ib) .eq. ic) then ist(3,nstrtor) = bndlist(k,ib) goto 70 end if end do 70 continue do k = 1, n12(ic) if (i12(k,ic) .eq. id) then ist(4,nstrtor) = bndlist(k,ic) goto 100 end if end do end if end do do j = 1, nbt if (kbt(j) .eq. pt0) then nstrtor = nstrtor + 1 kst(4,nstrtor) = btcon(4,j) kst(5,nstrtor) = btcon(5,j) kst(6,nstrtor) = btcon(6,j) if (swap) then kst(1,nstrtor) = btcon(7,j) kst(2,nstrtor) = btcon(8,j) kst(3,nstrtor) = btcon(9,j) kst(7,nstrtor) = btcon(1,j) kst(8,nstrtor) = btcon(2,j) kst(9,nstrtor) = btcon(3,j) else kst(1,nstrtor) = btcon(1,j) kst(2,nstrtor) = btcon(2,j) kst(3,nstrtor) = btcon(3,j) kst(7,nstrtor) = btcon(7,j) kst(8,nstrtor) = btcon(8,j) kst(9,nstrtor) = btcon(9,j) end if ist(1,nstrtor) = i do k = 1, n12(ia) if (i12(k,ia) .eq. ib) then ist(2,nstrtor) = bndlist(k,ia) goto 80 endif end do 80 continue do k = 1, n12(ib) if (i12(k,ib) .eq. ic) then ist(3,nstrtor) = bndlist(k,ib) goto 90 end if end do 90 continue do k = 1, n12(ic) if (i12(k,ic) .eq. id) then ist(4,nstrtor) = bndlist(k,ic) goto 100 end if end do end if end do 100 continue end do end if c c turn off the stretch-torsion potential if it is not used c if (nstrtor .eq. 0) use_strtor = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module ksttor -- stretch-torsion forcefield parameters ## c ## ## c ################################################################ c c c maxnbt maximum number of stretch-torsion parameter entries c c btcon torsional amplitude parameters for stretch-torsion c kbt string of atom classes for stretch-torsion terms c c module ksttor implicit none integer maxnbt real*8, allocatable :: btcon(:,:) character*16, allocatable :: kbt(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine ktors -- torsional parameter assignment ## c ## ## c ############################################################ c c c "ktors" assigns torsional parameters to each torsion in c the structure and processes any new or changed values c c subroutine ktors use atomid use atoms use couple use fields use inform use iounit use keys use ktorsn use math use potent use tors use usage implicit none integer i,j integer ia,ib,ic,id integer ita,itb,itc,itd integer nt,nt5,nt4 integer size,next integer iring,minat integer nlist,ilist integer, allocatable :: kindex(:) integer ft(6) real*8 angle real*8 vt(6),st(6) logical header,done logical use_ring character*4 pa,pb,pc,pd character*4 zeros character*7 label character*16 blank character*16 pt,pt0 character*16 pt1,pt2 character*16, allocatable :: klist(:) character*20 keyword character*240 record character*240 string c c c process keywords containing torsional angle parameters c blank = ' ' zeros = '0000' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) iring = -1 if (keyword(1:8) .eq. 'TORSION ') iring = 0 if (keyword(1:9) .eq. 'TORSION5 ') iring = 5 if (keyword(1:9) .eq. 'TORSION4 ') iring = 4 if (iring .ge. 0) then ia = 0 ib = 0 ic = 0 id = 0 do j = 1, 6 vt(j) = 0.0d0 st(j) = 0.0d0 ft(j) = 0 end do string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,6) 10 continue if (min(ia,ib,ic,id) .lt. 0) goto 110 size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) if (ib .lt. ic) then pt = pa//pb//pc//pd else if (ic .lt. ib) then pt = pd//pc//pb//pa else if (ia .le. id) then pt = pa//pb//pc//pd else if (id .lt. ia) then pt = pd//pc//pb//pa end if call torphase (ft,vt,st) if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Torsional Parameters :', & //,5x,'Atom Classes',5x,'1-Fold',4x,'2-Fold', & 4x,'3-Fold',4x,'4-Fold',4x,'5-Fold', & 4x,'6-Fold',/) end if if (iring .eq. 0) then write (iout,30) ia,ib,ic,id, & (vt(j),nint(st(j)),j=1,6) 30 format (2x,4i4,1x,6(f6.2,i4)) else if (iring .eq. 5) label = '5-Ring ' if (iring .eq. 4) label = '4-Ring ' write (iout,40) ia,ib,ic,id, & (vt(j),nint(st(j)),j=1,6),label(1:6) 40 format (2x,4i4,1x,6(f6.2,i4),3x,a6) end if end if if (iring .eq. 0) then do j = 1, maxnt if (kt(j).eq.blank .or. kt(j).eq.pt) then kt(j) = pt t1(1,j) = vt(1) t1(2,j) = st(1) t2(1,j) = vt(2) t2(2,j) = st(2) t3(1,j) = vt(3) t3(2,j) = st(3) t4(1,j) = vt(4) t4(2,j) = st(4) t5(1,j) = vt(5) t5(2,j) = st(5) t6(1,j) = vt(6) t6(2,j) = st(6) goto 60 end if end do write (iout,50) 50 format (/,' KTORS -- Too many Torsional Angle', & ' Parameters') abort = .true. 60 continue else if (iring .eq. 5) then do j = 1, maxnt5 if (kt5(j).eq.blank .or. kt5(j).eq.pt) then kt5(j) = pt t15(1,j) = vt(1) t15(2,j) = st(1) t25(1,j) = vt(2) t25(2,j) = st(2) t35(1,j) = vt(3) t35(2,j) = st(3) t45(1,j) = vt(4) t45(2,j) = st(4) t55(1,j) = vt(5) t55(2,j) = st(5) t65(1,j) = vt(6) t65(2,j) = st(6) goto 80 end if end do write (iout,70) 70 format (/,' KTORS -- Too many 5-Ring Torsional', & ' Parameters') abort = .true. 80 continue else if (iring .eq. 4) then do j = 1, maxnt4 if (kt4(j).eq.blank .or. kt4(j).eq.pt) then kt4(j) = pt t14(1,j) = vt(1) t14(2,j) = st(1) t24(1,j) = vt(2) t24(2,j) = st(2) t34(1,j) = vt(3) t34(2,j) = st(3) t44(1,j) = vt(4) t44(2,j) = st(4) t54(1,j) = vt(5) t54(2,j) = st(5) t64(1,j) = vt(6) t64(2,j) = st(6) goto 100 end if end do write (iout,90) 90 format (/,' KTORS -- Too many 4-Ring Torsional', & ' Parameters') abort = .true. 100 continue end if 110 continue end if end do c c perform dynamic allocation of some global arrays c if (allocated(tors1)) deallocate (tors1) if (allocated(tors2)) deallocate (tors2) if (allocated(tors3)) deallocate (tors3) if (allocated(tors4)) deallocate (tors4) if (allocated(tors5)) deallocate (tors5) if (allocated(tors6)) deallocate (tors6) allocate (tors1(4,ntors)) allocate (tors2(4,ntors)) allocate (tors3(4,ntors)) allocate (tors4(4,ntors)) allocate (tors5(4,ntors)) allocate (tors6(4,ntors)) c c use special torsional parameter assignment method for MMFF c if (forcefield .eq. 'MMFF94') then call ktorsm return end if c c determine the total number of forcefield parameters c nt = maxnt nt5 = maxnt5 nt4 = maxnt4 do i = maxnt, 1, -1 if (kt(i) .eq. blank) nt = i - 1 end do do i = maxnt5, 1, -1 if (kt5(i) .eq. blank) nt5 = i - 1 end do do i = maxnt4, 1, -1 if (kt4(i) .eq. blank) nt4 = i - 1 end do use_ring = .false. if (min(nt5,nt4) .ne. 0) use_ring = .true. c c perform dynamic allocation of some local arrays c allocate (kindex(maxnt)) allocate (klist(maxnt)) c c assign torsional parameters for each torsional angle c by putting the parameter values into the "tors" arrays c header = .true. nlist = 0 do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .lt. itc) then pt = pa//pb//pc//pd else if (itc .lt. itb) then pt = pd//pc//pb//pa else if (ita .le. itd) then pt = pa//pb//pc//pd else if (itd .lt. ita) then pt = pd//pc//pb//pa end if pt2 = zeros//pt(5:16) pt1 = pt(1:12)//zeros pt0 = zeros//pt(5:12)//zeros tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = 0.0d0 tors2(2,i) = 0.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 tors4(1,i) = 0.0d0 tors4(2,i) = 0.0d0 tors5(1,i) = 0.0d0 tors5(2,i) = 0.0d0 tors6(1,i) = 0.0d0 tors6(2,i) = 0.0d0 done = .false. c c make a check for torsions inside small rings c iring = 0 if (use_ring) then call chkring (iring,ia,ib,ic,id) if (iring .eq. 6) iring = 0 if (iring.eq.5 .and. nt5.eq.0) iring = 0 if (iring.eq.4 .and. nt4.eq.0) iring = 0 end if c c find parameters for this torsion; first check "klist" c to save time for angle types already located c if (iring .eq. 0) then do j = 1, nlist if (klist(j) .eq. pt) then ilist = kindex(j) tors1(1,i) = tors1(1,ilist) tors1(2,i) = tors1(2,ilist) tors2(1,i) = tors2(1,ilist) tors2(2,i) = tors2(2,ilist) tors3(1,i) = tors3(1,ilist) tors3(2,i) = tors3(2,ilist) tors4(1,i) = tors4(1,ilist) tors4(2,i) = tors4(2,ilist) tors5(1,i) = tors5(1,ilist) tors5(2,i) = tors5(2,ilist) tors6(1,i) = tors6(1,ilist) tors6(2,i) = tors6(2,ilist) done = .true. goto 120 end if end do do j = 1, nt if (kt(j) .eq. pt) then nlist = nlist + 1 klist(nlist) = pt kindex(nlist) = i tors1(1,i) = t1(1,j) tors1(2,i) = t1(2,j) tors2(1,i) = t2(1,j) tors2(2,i) = t2(2,j) tors3(1,i) = t3(1,j) tors3(2,i) = t3(2,j) tors4(1,i) = t4(1,j) tors4(2,i) = t4(2,j) tors5(1,i) = t5(1,j) tors5(2,i) = t5(2,j) tors6(1,i) = t6(1,j) tors6(2,i) = t6(2,j) done = .true. goto 120 end if end do do j = 1, nt if (kt(j).eq.pt1 .or. kt(j).eq.pt2) then tors1(1,i) = t1(1,j) tors1(2,i) = t1(2,j) tors2(1,i) = t2(1,j) tors2(2,i) = t2(2,j) tors3(1,i) = t3(1,j) tors3(2,i) = t3(2,j) tors4(1,i) = t4(1,j) tors4(2,i) = t4(2,j) tors5(1,i) = t5(1,j) tors5(2,i) = t5(2,j) tors6(1,i) = t6(1,j) tors6(2,i) = t6(2,j) done = .true. goto 120 end if end do do j = 1, nt if (kt(j) .eq. pt0) then tors1(1,i) = t1(1,j) tors1(2,i) = t1(2,j) tors2(1,i) = t2(1,j) tors2(2,i) = t2(2,j) tors3(1,i) = t3(1,j) tors3(2,i) = t3(2,j) tors4(1,i) = t4(1,j) tors4(2,i) = t4(2,j) tors5(1,i) = t5(1,j) tors5(2,i) = t5(2,j) tors6(1,i) = t6(1,j) tors6(2,i) = t6(2,j) done = .true. goto 120 end if end do c c find the parameters for a 5-ring torsion c else if (iring .eq. 5) then do j = 1, nt5 if (kt5(j) .eq. pt) then tors1(1,i) = t15(1,j) tors1(2,i) = t15(2,j) tors2(1,i) = t25(1,j) tors2(2,i) = t25(2,j) tors3(1,i) = t35(1,j) tors3(2,i) = t35(2,j) tors4(1,i) = t45(1,j) tors4(2,i) = t45(2,j) tors5(1,i) = t55(1,j) tors5(2,i) = t55(2,j) tors6(1,i) = t65(1,j) tors6(2,i) = t65(2,j) done = .true. goto 120 end if end do do j = 1, nt5 if (kt5(j).eq.pt1 .or. kt5(j).eq.pt2) then tors1(1,i) = t15(1,j) tors1(2,i) = t15(2,j) tors2(1,i) = t25(1,j) tors2(2,i) = t25(2,j) tors3(1,i) = t35(1,j) tors3(2,i) = t35(2,j) tors4(1,i) = t45(1,j) tors4(2,i) = t45(2,j) tors5(1,i) = t55(1,j) tors5(2,i) = t55(2,j) tors6(1,i) = t65(1,j) tors6(2,i) = t65(2,j) done = .true. goto 120 end if end do do j = 1, nt5 if (kt5(j) .eq. pt0) then tors1(1,i) = t15(1,j) tors1(2,i) = t15(2,j) tors2(1,i) = t25(1,j) tors2(2,i) = t25(2,j) tors3(1,i) = t35(1,j) tors3(2,i) = t35(2,j) tors4(1,i) = t45(1,j) tors4(2,i) = t45(2,j) tors5(1,i) = t55(1,j) tors5(2,i) = t55(2,j) tors6(1,i) = t65(1,j) tors6(2,i) = t65(2,j) done = .true. goto 120 end if end do c c find the parameters for a 4-ring torsion c else if (iring .eq. 4) then do j = 1, nt4 if (kt4(j) .eq. pt) then tors1(1,i) = t14(1,j) tors1(2,i) = t14(2,j) tors2(1,i) = t24(1,j) tors2(2,i) = t24(2,j) tors3(1,i) = t34(1,j) tors3(2,i) = t34(2,j) tors4(1,i) = t44(1,j) tors4(2,i) = t44(2,j) tors5(1,i) = t54(1,j) tors5(2,i) = t54(2,j) tors6(1,i) = t64(1,j) tors6(2,i) = t64(2,j) done = .true. goto 120 end if end do do j = 1, nt4 if (kt4(j).eq.pt1 .or. kt4(j).eq.pt2) then tors1(1,i) = t14(1,j) tors1(2,i) = t14(2,j) tors2(1,i) = t24(1,j) tors2(2,i) = t24(2,j) tors3(1,i) = t34(1,j) tors3(2,i) = t34(2,j) tors4(1,i) = t44(1,j) tors4(2,i) = t44(2,j) tors5(1,i) = t54(1,j) tors5(2,i) = t54(2,j) tors6(1,i) = t64(1,j) tors6(2,i) = t64(2,j) done = .true. goto 120 end if end do do j = 1, nt4 if (kt4(j) .eq. pt0) then tors1(1,i) = t14(1,j) tors1(2,i) = t14(2,j) tors2(1,i) = t24(1,j) tors2(2,i) = t24(2,j) tors3(1,i) = t34(1,j) tors3(2,i) = t34(2,j) tors4(1,i) = t44(1,j) tors4(2,i) = t44(2,j) tors5(1,i) = t54(1,j) tors5(2,i) = t54(2,j) tors6(1,i) = t64(1,j) tors6(2,i) = t64(2,j) done = .true. goto 120 end if end do end if c c warning if suitable torsional parameter not found c 120 continue minat = min(atomic(ia),atomic(ib),atomic(ic),atomic(id)) if (minat .eq. 0) done = .true. if (use_tors .and. .not.done) then if (use(ia) .or. use(ib) .or. use(ic) .or. use(id)) & abort = .true. if (header) then header = .false. write (iout,130) 130 format (/,' Undefined Torsional Parameters :', & //,' Type',24x,'Atom Names',24x, & 'Atom Classes',/) end if label = 'Torsion' if (iring .eq. 5) label = '5-Ring ' if (iring .eq. 4) label = '4-Ring ' write (iout,140) label,ia,name(ia),ib,name(ib),ic, & name(ic),id,name(id),ita,itb,itc,itd 140 format (1x,a7,4x,4(i6,'-',a3),5x,4i5) end if end do c c perform deallocation of some local arrays c deallocate (kindex) deallocate (klist) c c process keywords containing torsion specific parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) iring = -1 if (keyword(1:8) .eq. 'TORSION ') then ia = 0 ib = 0 ic = 0 id = 0 do j = 1, 6 vt(j) = 0.0d0 st(j) = 0.0d0 ft(j) = 0 end do string = record(next:240) read (string,*,err=150,end=150) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,6) 150 continue if (min(ia,ib,ic,id) .lt. 0) then ia = abs(ia) ib = abs(ib) ic = abs(ic) id = abs(id) call torphase (ft,vt,st) if (header .and. .not.silent) then header = .false. write (iout,160) 160 format (/,' Additional Torsion Specific Parameters :', & //,8x,'Atoms',9x,'1-Fold',4x,'2-Fold', & 4x,'3-Fold',4x,'4-Fold',4x,'5-Fold', & 4x,'6-Fold',/) end if if (.not. silent) then write (iout,170) ia,ib,ic,id, & (vt(j),nint(st(j)),j=1,6) 170 format (2x,4i4,1x,6(f6.2,i4)) end if do j = 1, ntors ita = itors(1,j) itb = itors(2,j) itc = itors(3,j) itd = itors(4,j) if ((ia.eq.ita .and. ib.eq.itb .and. & ic.eq.itc .and. id.eq.itd) .or. & (ia.eq.itd .and. ib.eq.itc .and. & ic.eq.itb .and. id.eq.ita)) then tors1(1,j) = vt(1) tors1(2,j) = st(1) tors2(1,j) = vt(2) tors2(2,j) = st(2) tors3(1,j) = vt(3) tors3(2,j) = st(3) tors4(1,j) = vt(4) tors4(2,j) = st(4) tors5(1,j) = vt(5) tors5(2,j) = st(5) tors6(1,j) = vt(6) tors6(2,j) = st(6) goto 180 end if end do end if 180 continue end if end do c c find the cosine and sine of phase angle for each torsion c do i = 1, ntors angle = tors1(2,i) / radian tors1(3,i) = cos(angle) tors1(4,i) = sin(angle) angle = tors2(2,i) / radian tors2(3,i) = cos(angle) tors2(4,i) = sin(angle) angle = tors3(2,i) / radian tors3(3,i) = cos(angle) tors3(4,i) = sin(angle) angle = tors4(2,i) / radian tors4(3,i) = cos(angle) tors4(4,i) = sin(angle) angle = tors5(2,i) / radian tors5(3,i) = cos(angle) tors5(4,i) = sin(angle) angle = tors6(2,i) / radian tors6(3,i) = cos(angle) tors6(4,i) = sin(angle) end do c c turn off the torsional potential if it is not used c if (ntors .eq. 0) use_tors = .false. return end c c c ############################################################### c ## ## c ## subroutine ktorsm -- assign MMFF torsional parameters ## c ## ## c ############################################################### c c c "ktorsm" assigns torsional parameters to each torsion according c to the Merck Molecular Force Field (MMFF) c c literature references: c c T. A. Halgren, "Merck Molecular Force Field. I. Basis, Form, c Scope, Parametrization, and Performance of MMFF94", Journal of c Computational Chemistry, 17, 490-519 (1995) c c T. A. Halgren, "Merck Molecular Force Field. V. Extension of c MMFF94 Using Experimental Data, Additional Computational Data, c and Empirical Rules", Journal of Computational Chemistry, 17, c 616-641 (1995) c c subroutine ktorsm use atomid use atoms use ktorsn use math use merck use potent use ring use tors implicit none integer i,j,k,l,m,o integer size,tt integer ia,ib,ic,id integer ita,itb,itc,itd integer inb,inc,irb,irc integer itta,ittb integer ittc,ittd integer nt4,nt5 integer ab,bc,cd integer mclass real*8 angle real*8 beta,pi_bc,n_bc real*8 ub,vb,wb real*8 uc,vc,wc logical done,skipring logical ring4,ring5 character*4 pa,pb,pc,pd character*16 pt,blank c c c determine the total number of forcefield parameters c blank = ' ' nt5 = maxnt5 nt4 = maxnt4 do i = maxnt5, 1, -1 if (kt5(i) .eq. blank) nt5 = i - 1 end do do i = maxnt4, 1, -1 if (kt4(i) .eq. blank) nt4 = i - 1 end do c c assign MMFF torsional parameters for each torsional angle c do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) itta = type(ia) ittb = type(ib) ittc = type(ic) ittd = type(id) done = .false. mclass = 0 skipring = .false. 10 continue c c determine the atom class equivalency assignments c mclass = mclass + 1 if (mclass .eq. 1) then ita = eqclass(itta,mclass) itb = eqclass(ittb,mclass) itc = eqclass(ittc,mclass) itd = eqclass(ittd,mclass) else if (mclass.eq.2) then ita = eqclass(itta,mclass) itb = eqclass(ittb,mclass) itc = eqclass(ittc,mclass) itd = eqclass(ittd,mclass) else if (mclass.eq.3) then ita = eqclass(itta,3) itb = eqclass(ittb,2) itc = eqclass(ittc,2) itd = eqclass(ittd,5) else if (mclass.eq.4) then ita = eqclass(itta,5) itb = eqclass(ittb,2) itc = eqclass(ittc,2) itd = eqclass(ittd,3) else if (mclass.eq.5) then ita = eqclass(itta,5) itb = eqclass(ittb,2) itc = eqclass(ittc,2) itd = eqclass(ittd,5) end if c c construct search string and zero out parameters c size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .lt. itc) then pt = pa//pb//pc//pd else if (itc .lt. itb) then pt = pd//pc//pb//pa else if (ita .le. itd) then pt = pa//pb//pc//pd else if (itd .lt. ita) then pt = pd//pc//pb//pa end if tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = 0.0d0 tors2(2,i) = 0.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 tors4(1,i) = 0.0d0 tors4(2,i) = 0.0d0 tors5(1,i) = 0.0d0 tors5(2,i) = 0.0d0 tors6(1,i) = 0.0d0 tors6(2,i) = 0.0d0 done = .false. c c set the MMFF torsion type attribution c ab = 0 if (ia .le. ib) then do j = 1, nligne if (ia.eq.bt_1(j,1) .and. ib.eq.bt_1(j,2)) then ab = 1 end if end do else if (ib .le. ia) then do j = 1, nligne if (ib.eq.bt_1(j,1) .and. ia.eq.bt_1(j,2)) then ab = 1 end if end do end if bc = 0 if (ib .le. ic) then do j = 1, nligne if (ib.eq.bt_1(j,1) .and. ic.eq.bt_1(j,2)) then bc = 1 end if end do else if (ic .le. ib) then do j = 1, nligne if (ic.eq.bt_1(j,1) .and. ib.eq.bt_1(j,2)) then bc = 1 end if end do end if cd = 0 if (ic .le. id) then do j = 1, nligne if (ic.eq.bt_1(j,1) .and. id.eq.bt_1(j,2)) then cd = 1 end if end do else if (id .le. ic) then do j = 1, nligne if (id.eq.bt_1(j,1) .and. ic.eq.bt_1(j,2)) then cd = 1 end if end do end if c c make a check for torsions inside small rings c ring4 = .false. ring5 = .false. do j = 1, nring4 do k = 1, 4 if (ia .eq. iring4(k,j)) then do l = 1, 4 if (ib .eq. iring4(l,j)) then do m = 1, 4 if (ic .eq. iring4(m,j)) then do o = 1, 4 if (id .eq. iring4(o,j)) & ring4 = .true. end do end if end do end if end do end if end do end do do j = 1, nring5 do k = 1, 5 if (ia .eq. iring5(k,j)) then do l = 1, 5 if (ib .eq. iring5(l,j)) then do m = 1, 5 if (ic .eq. iring5(m,j)) then do o = 1, 5 if (id .eq. iring5(o,j)) & ring5 = .true. end do end if end do end if end do end if end do end do if (skipring) then ring4 = .false. ring5 = .false. end if if (ring4) then tt = 4 do j = 1, nt4 if (kt4(j) .eq. pt) then tors1(1,i) = t14(1,j) tors1(2,i) = t14(2,j) tors2(1,i) = t24(1,j) tors2(2,i) = t24(2,j) tors3(1,i) = t34(1,j) tors3(2,i) = t34(2,j) done = .true. goto 20 end if end do if (.not.done .and. mclass.lt.5) then goto 10 end if end if if (ring5 .and. (class(ia).eq.1.or.class(ib).eq.1.or. & class(ic).eq.1.or.class(id).eq.1)) then tt = 5 do j = 1, nt5 if (kt5(j) .eq. pt) then tors1(1,i) = t15(1,j) tors1(2,i) = t15(2,j) tors2(1,i) = t25(1,j) tors2(2,i) = t25(2,j) tors3(1,i) = t35(1,j) tors3(2,i) = t35(2,j) done = .true. end if end do if (.not.done .and. mclass.lt.5) then goto 10 else if (.not.done .and. mclass.eq.5) then mclass = 0 skipring = .true. goto 10 end if end if c c condition below deduced from validation suite comparison c if ((ab.eq.1 .and. (mltb(class(ic)).eq.0.or. & sbmb(class(ic)).eq.0)) .or. & (cd.eq.1 .and. (mltb(class(ib)).eq.0.or. & sbmb(class(ib)).eq.0))) then tt = 2 do j = 1, maxnt if (kt_2(j) .eq. pt) then tors1(1,i) = t1_2(1,j) tors1(2,i) = t1_2(2,j) tors2(1,i) = t2_2(1,j) tors2(2,i) = t2_2(2,j) tors3(1,i) = t3_2(1,j) tors3(2,i) = t3_2(2,j) done = .true. goto 20 end if end do if (.not.done .and. mclass.lt.5) then goto 10 end if if (.not.done .and. mclass.eq.5) then tt = 0 do j = 1, maxnt if (kt(j) .eq. pt) then tors1(1,i) = t1(1,j) tors1(2,i) = t1(2,j) tors2(1,i) = t2(1,j) tors2(2,i) = t2(2,j) tors3(1,i) = t3(1,j) tors3(2,i) = t3(2,j) done = .true. goto 20 end if end do if (.not.done .and. mclass.lt.5) then goto 10 end if end if if (tors1(1,i) .eq. 1000.0d0) done = .false. if (tors1(2,i) .eq. 1000.0d0) done = .false. if (tors2(1,i) .eq. 1000.0d0) done = .false. if (tors2(2,i) .eq. 1000.0d0) done = .false. if (tors3(1,i) .eq. 1000.0d0) done = .false. if (tors3(2,i) .eq. 1000.0d0) done = .false. goto 20 else if (bc .eq. 1) then tt = 1 do j = 1, maxnt if (kt_1(j) .eq. pt) then tors1(1,i) = t1_1(1,j) tors1(2,i) = t1_1(2,j) tors2(1,i) = t2_1(1,j) tors2(2,i) = t2_1(2,j) tors3(1,i) = t3_1(1,j) tors3(2,i) = t3_1(2,j) done = .true. goto 20 end if end do if (.not.done .and. mclass.lt.5) then goto 10 end if if (tors1(1,i) .eq. 1000.0d0) done = .false. if (tors1(2,i) .eq. 1000.0d0) done = .false. if (tors2(1,i) .eq. 1000.0d0) done = .false. if (tors2(2,i) .eq. 1000.0d0) done = .false. if (tors3(1,i) .eq. 1000.0d0) done = .false. if (tors3(2,i) .eq. 1000.0d0) done = .false. goto 20 else if (.not. done) then tt = 0 do j = 1, maxnt if (kt(j) .eq. pt) then tors1(1,i) = t1(1,j) tors1(2,i) = t1(2,j) tors2(1,i) = t2(1,j) tors2(2,i) = t2(2,j) tors3(1,i) = t3(1,j) tors3(2,i) = t3(2,j) done = .true. goto 20 end if end do if (.not.done .and. mclass.lt.5) then goto 10 end if if (tors1(1,i) .eq. 1000.0d0) done = .false. if (tors1(2,i) .eq. 1000.0d0) done = .false. if (tors2(1,i) .eq. 1000.0d0) done = .false. if (tors2(2,i) .eq. 1000.0d0) done = .false. if (tors3(1,i) .eq. 1000.0d0) done = .false. if (tors3(2,i) .eq. 1000.0d0) done = .false. goto 20 end if 20 continue c c use the empirical rules for parameter not located c if (.not. done) then ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) inb = atomic(ib) inc = atomic(ic) if (inb .eq. 6) then ub = 2.0d0 vb = 2.12d0 else if (inb .eq. 7) then ub = 2.0d0 vb = 1.5d0 else if (inb .eq. 8) then ub = 2.0d0 vb = 0.2d0 else if (inb .eq. 14) then ub = 1.25d0 vb = 1.22d0 else if (inb .eq. 15) then ub = 1.25d0 vb = 2.4d0 else if (inb .eq. 16) then ub = 1.25d0 vb = 0.49d0 end if if (inc .eq. 6) then uc = 2.0d0 vc = 2.12d0 else if (inc .eq. 7) then uc = 2.0d0 vc = 1.5d0 else if (inc .eq. 8) then uc = 2.0d0 vc = 0.2d0 else if (inc .eq. 14) then uc = 1.25d0 vc = 1.22d0 else if (inc .eq. 15) then uc = 1.25d0 vc = 2.4d0 else if (inc .eq. 16) then uc = 1.25d0 vc = 0.49d0 end if n_bc = (crd(itb)-1) * (crd(itc)-1) if (inb.eq.1) irb = 0 if (inb.ge.3 .and. inb.le.10) irb = 1 if (inb.ge.11 .and. inb.le.18) irb = 2 if (inb.ge.19 .and. inb.le.36) irb = 3 if (inb.ge.37 .and. inb.le.54) irb = 4 if (inc.eq.1) irc = 0 if (inc.ge.3 .and. inc.le.10) irc = 1 if (inc.ge.11 .and. inc.le.18) irc = 2 if (inc.ge.19 .and. inc.le.36) irc = 3 if (inc.ge.37 .and. inc.le.54) irc = 4 if (lin(itb).eq.1 .or. lin(itc).eq.1) then tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = 0.0d0 tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if (arom(itb).eq.1 .and. arom(itc).eq.1) then if (pilp(itb).eq.0 .and. pilp(itc).eq.0) then pi_bc = 0.5d0 else pi_bc = 0.3d0 end if if ((val(itb).eq.3.and.val(itc).eq.4) .or. & (val(itb).eq.4.and.val(itc).eq.3) .or. & (val(itb).eq.4.and.val(itc).eq.34) .or. & (val(itb).eq.34.and.val(itc).eq.4) .or. & (val(itb).eq.34.and.val(itc).eq.3) .or. & (val(itb).eq.3.and.val(itc).eq.34) .or. & (val(itb).eq.34.and.val(itc).eq.34)) then beta = 3.0d0 else beta = 6.0d0 end if tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = beta * pi_bc * sqrt(ub*uc) tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if ((mltb(itb).eq.2 .and. mltb(itc).eq.2) .or. & (mltb(itc).eq.2 .and. mltb(itb).eq.2)) then beta = 6.0d0 pi_bc = 1.0d0 tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = beta * pi_bc * sqrt(ub*uc) tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if (mltb(itb).eq.2 .or. mltb(itc).eq.2) then beta = 6.0d0 pi_bc = 0.4d0 tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = beta * pi_bc * sqrt(ub*uc) tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if (crd(itb).eq.4 .and. crd(itc).eq.4) then tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = 0.0d0 tors2(2,i) = 180.0d0 tors3(1,i) = sqrt(vb*vc) / n_bc tors3(2,i) = 0.0d0 done = .true. goto 20 else if ((crd(itb).eq.4.and.crd(itc).eq.3.and. & ((val(itc).eq.4.or.val(itc).eq.34).or. & mltb(itc).ne.0)) .or. & (crd(itc).eq.4.and.crd(itb).eq.3.and. & ((val(itb).eq.4.or.val(itb).eq.34).or. & mltb(itb).ne.0))) then tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = 0.0d0 tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if ((crd(itb).eq.4.and.crd(itc).eq.2.and. & (val(itc).eq.3.or.mltb(itc).ne.0)) .or. & (crd(itb).eq.4.and.crd(itc).eq.2.and. & (val(itc).eq.3.or.mltb(itc).ne.0))) then tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = 0.0d0 tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if (crd(itb).eq.4 .or. crd(itc).eq.4) then tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = 0.0d0 tors2(2,i) = 180.0d0 tors3(1,i) = sqrt(vb*vc) / n_bc tors3(2,i) = 0.0d0 done = .true. goto 20 else if (pilp(itb).eq.1 .and. pilp(itc).eq.1) then tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = 0.0d0 tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if (pilp(itb).ne.0 .and. mltb(itc).ne.0) then beta = 6.0d0 if (mltb(itb) .eq. 1) then pi_bc = 0.5d0 else if (irb.eq.1 .and. irc.eq.1) then pi_bc = 0.3d0 else if (irb.ne.1 .or. irc.ne.1) then pi_bc = 0.15d0 end if tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = beta * pi_bc * sqrt(ub*uc) tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if (pilp(itc).ne.0 .and. mltb(itb).ne.0) then beta = 6.0d0 if (mltb(itc) .eq. 1) then pi_bc = 0.5d0 else if (irb.eq.1 .and. irc.eq.1) then pi_bc = 0.3d0 else if (irb.ne.1 .or. irc.ne.1) then pi_bc = 0.15d0 end if tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = beta * pi_bc * sqrt(ub*uc) tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if ((mltb(itb).eq.1.or.mltb(itc).eq.1) .and. & (inb.ne.6.or.inc.ne.6)) then beta = 6.0d0 pi_bc = 0.4d0 tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = beta * pi_bc * sqrt(ub*uc) tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if (mltb(itb).ne.0 .and. mltb(itc).ne.0) then beta = 6.0d0 pi_bc = 0.15d0 tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = beta * pi_bc * sqrt(ub*uc) tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if (inb.eq.8 .and. inc.eq.8) then wb = 2.0d0 wc = 2.0d0 tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = -sqrt(wb*wc) tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if ((inb.eq.8.and.inc.eq.16) .or. & (inb.eq.16.and.inc.eq.8)) then wb = 2.0d0 wc = 8.0d0 tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = -sqrt(wb*wc) tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else if (inb.eq.16 .and. inc.eq.16) then wb = 8.0d0 wc = 8.0d0 tors1(1,i) = 0.0d0 tors1(2,i) = 0.0d0 tors2(1,i) = -sqrt(wb*wc) tors2(2,i) = 180.0d0 tors3(1,i) = 0.0d0 tors3(2,i) = 0.0d0 done = .true. goto 20 else tors1(1,i) = 0.0 tors1(2,i) = 0.0 tors2(1,i) = 0.0 tors2(2,i) = 180.0 tors3(1,i) = sqrt(vb*vc) / n_bc tors3(2,i) = 0.0 done = .true. goto 20 end if end if end do c c find the cosine and sine of phase angle for each torsion c do i = 1, ntors angle = tors1(2,i) / radian tors1(3,i) = cos(angle) tors1(4,i) = sin(angle) angle = tors2(2,i) / radian tors2(3,i) = cos(angle) tors2(4,i) = sin(angle) angle = tors3(2,i) / radian tors3(3,i) = cos(angle) tors3(4,i) = sin(angle) angle = tors4(2,i) / radian tors4(3,i) = cos(angle) tors4(4,i) = sin(angle) angle = tors5(2,i) / radian tors5(3,i) = cos(angle) tors5(4,i) = sin(angle) angle = tors6(2,i) / radian tors6(3,i) = cos(angle) tors6(4,i) = sin(angle) end do c c turn off the torsional potential if it is not used c if (ntors .eq. 0) use_tors = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module ktorsn -- torsional angle forcefield parameters ## c ## ## c ################################################################ c c c maxnt maximum number of torsional angle parameter entries c maxnt5 maximum number of 5-membered ring torsion entries c maxnt4 maximum number of 4-membered ring torsion entries c c t1 torsional parameters for standard 1-fold rotation c t2 torsional parameters for standard 2-fold rotation c t3 torsional parameters for standard 3-fold rotation c t4 torsional parameters for standard 4-fold rotation c t5 torsional parameters for standard 5-fold rotation c t6 torsional parameters for standard 6-fold rotation c t15 torsional parameters for 1-fold rotation in 5-ring c t25 torsional parameters for 2-fold rotation in 5-ring c t35 torsional parameters for 3-fold rotation in 5-ring c t45 torsional parameters for 4-fold rotation in 5-ring c t55 torsional parameters for 5-fold rotation in 5-ring c t65 torsional parameters for 6-fold rotation in 5-ring c t14 torsional parameters for 1-fold rotation in 4-ring c t24 torsional parameters for 2-fold rotation in 4-ring c t34 torsional parameters for 3-fold rotation in 4-ring c t44 torsional parameters for 4-fold rotation in 4-ring c t54 torsional parameters for 5-fold rotation in 4-ring c t64 torsional parameters for 6-fold rotation in 4-ring c kt string of atom classes for torsional angles c kt5 string of atom classes for 5-ring torsions c kt4 string of atom classes for 4-ring torsions c c module ktorsn implicit none integer maxnt integer maxnt5 integer maxnt4 real*8, allocatable :: t1(:,:) real*8, allocatable :: t2(:,:) real*8, allocatable :: t3(:,:) real*8, allocatable :: t4(:,:) real*8, allocatable :: t5(:,:) real*8, allocatable :: t6(:,:) real*8, allocatable :: t15(:,:) real*8, allocatable :: t25(:,:) real*8, allocatable :: t35(:,:) real*8, allocatable :: t45(:,:) real*8, allocatable :: t55(:,:) real*8, allocatable :: t65(:,:) real*8, allocatable :: t14(:,:) real*8, allocatable :: t24(:,:) real*8, allocatable :: t34(:,:) real*8, allocatable :: t44(:,:) real*8, allocatable :: t54(:,:) real*8, allocatable :: t64(:,:) character*16, allocatable :: kt(:) character*16, allocatable :: kt5(:) character*16, allocatable :: kt4(:) save end c c c ############################################################# c ## COPYRIGHT (C) 2003 by Pengyu Ren & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################# c c ############################################################## c ## ## c ## subroutine ktortor -- tors-tors parameter assignment ## c ## ## c ############################################################## c c c "ktortor" assigns torsion-torsion parameters to adjacent c torsion pairs and processes any new or changed values c c subroutine ktortor use atomid use atoms use bitor use inform use iounit use keys use ktrtor use potent use tortor implicit none integer i,j,k,m integer ia,ib,ic,id,ie integer ita,itb,itc,itd,ite integer size,next,ntt integer nx,ny,nxy real*8 eps real*8 tx(maxtgrd2) real*8 ty(maxtgrd2) real*8 tf(maxtgrd2) real*8 bs(0:maxtgrd) real*8 cs(0:maxtgrd) real*8 ds(0:maxtgrd) real*8 tmp1(0:maxtgrd) real*8 tmp2(0:maxtgrd) real*8 tmp3(0:maxtgrd) real*8 tmp4(0:maxtgrd) real*8 tmp5(0:maxtgrd) real*8 tmp6(0:maxtgrd) real*8 tmp7(0:maxtgrd) logical header,cyclic character*4 pa,pb,pc,pd,pe character*20 blank,pt character*20 pt1,pt2 character*20 keyword character*240 record character*240 string c c c process keywords containing torsion-torsion parameters c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:8) .eq. 'TORTORS ') then ia = 0 ib = 0 ic = 0 id = 0 ie = 0 nx = 0 ny = 0 nxy = 0 do j = 1, maxtgrd2 tx(j) = 0.0d0 ty(j) = 0.0d0 tf(j) = 0.0d0 end do string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,id,ie,nx,ny nxy = nx * ny do j = 1, nxy record = keyline(i+j) read (record,*,err=10,end=10) tx(j),ty(j),tf(j) end do 10 continue if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Torsion-Torsion Parameters :', & //,5x,'Atom Classes',11x,'Grid-1', & 9x,'Grid-2',/) end if write (iout,30) ia,ib,ic,id,ie,nx,ny 30 format (1x,5i4,5x,i8,7x,i8) end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) call numeral (ie,pe,size) pt = pa//pb//pc//pd//pe do j = 1, maxntt if (ktt(j).eq.blank .or. ktt(j).eq.pt) then ktt(j) = pt nx = nxy call sort9 (nx,tx) ny = nxy call sort9 (ny,ty) tnx(j) = nx tny(j) = ny do k = 1, nx ttx(k,j) = tx(k) end do do k = 1, ny tty(k,j) = ty(k) end do do k = 1, nxy tbf(k,j) = tf(k) end do goto 50 end if end do write (iout,40) 40 format (/,' KTORTOR -- Too many Torsion-Torsion', & ' Parameters') abort = .true. 50 continue end if end do c c determine the total number of forcefield parameters c ntt = maxntt do i = maxntt, 1, -1 if (ktt(i) .eq. blank) ntt = i - 1 end do c c perform dynamic allocation of some global arrays c if (allocated(itt)) deallocate (itt) allocate (itt(3,nbitor)) c c check whether each torsion-torsion parameter is periodic; c assumes the "tbf" array is sorted with both indices in c increasing order and the first index changing most rapidly c do i = 1, ntt cyclic = .true. eps = 0.000001d0 nx = tnx(i) - 1 ny = tny(i) - 1 if (abs(abs(ttx(1,i)-ttx(tnx(i),i))-360.0d0) .gt. eps) & cyclic = .false. if (abs(abs(tty(1,i)-tty(tny(i),i))-360.0d0) .gt. eps) & cyclic = .false. if (cyclic) then do j = 1, tny(i) k = (j-1)*tnx(i) + 1 if (abs(tbf(k,i)-tbf(k+nx,i)) .gt. eps) then write (iout,60) tbf(k,i),tbf(k+nx,i) 60 format (/,' KTORTOR -- Warning, Unequal Tor-Tor', & ' Values',3x,2f12.5) end if end do k = ny * tnx(i) do j = 1, tnx(i) if (abs(tbf(j,i)-tbf(j+k,i)) .gt. eps) then write (iout,70) tbf(j,i),tbf(j+k,i) 70 format (/,' KTORTOR -- Warning, Unequal Tor-Tor', & ' Values',3x,2f12.5) end if end do end if c c spline fit the derivatives about the first torsion c do j = 1, tnx(i) tmp1(j-1) = ttx(j,i) end do m = 0 do j = 1, tny(i) do k = 1, tnx(i) tmp2(k-1) = tbf(m+k,i) end do if (cyclic) then call cspline (nx,tmp1,tmp2,bs,cs,ds,tmp3, & tmp4,tmp5,tmp6,tmp7) else call nspline (nx,tmp1,tmp2,bs,cs,tmp3, & tmp4,tmp5,tmp6,tmp7) end if do k = 1, tnx(i) tbx(m+k,i) = bs(k-1) end do m = m + tnx(i) end do c c spline fit the derivatives about the second torsion c do j = 1, tny(i) tmp1(j-1) = tty(j,i) end do m = 1 do j = 1, tnx(i) do k = 1, tny(i) tmp2(k-1) = tbf(m+(k-1)*tnx(i),i) end do if (cyclic) then call cspline (ny,tmp1,tmp2,bs,cs,ds,tmp3, & tmp4,tmp5,tmp6,tmp7) else call nspline (ny,tmp1,tmp2,bs,cs,tmp3, & tmp4,tmp5,tmp6,tmp7) end if do k = 1, tny(i) tby(m+(k-1)*tnx(i),i) = bs(k-1) end do m = m + 1 end do c c spline fit the cross derivatives about both torsions c m = 1 do j = 1, tnx(i) do k = 1, tny(i) tmp2(k-1) = tbx(m+(k-1)*tnx(i),i) end do if (cyclic) then call cspline (ny,tmp1,tmp2,bs,cs,ds,tmp3, & tmp4,tmp5,tmp6,tmp7) else call nspline (ny,tmp1,tmp2,bs,cs,tmp3, & tmp4,tmp5,tmp6,tmp7) end if do k = 1, tny(i) tbxy(m+(k-1)*tnx(i),i) = bs(k-1) end do m = m + 1 end do end do c c assign torsion-torsion parameters for each bitorsion c ntortor = 0 do i = 1, nbitor ia = ibitor(1,i) ib = ibitor(2,i) ic = ibitor(3,i) id = ibitor(4,i) ie = ibitor(5,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) ite = class(ie) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) call numeral (ite,pe,size) pt1 = pa//pb//pc//pd//pe pt2 = pe//pd//pc//pb//pa c c find parameters for this torsion-torsion interaction c do j = 1, ntt if (ktt(j) .eq. pt1) then ntortor = ntortor + 1 itt(1,ntortor) = i itt(2,ntortor) = j itt(3,ntortor) = 1 goto 80 else if (ktt(j) .eq. pt2) then ntortor = ntortor + 1 itt(1,ntortor) = i itt(2,ntortor) = j itt(3,ntortor) = -1 goto 80 end if end do 80 continue end do c c turn off the torsion-torsion potential if it is not used c if (ntortor .eq. 0) use_tortor = .false. return end c c c ################################################### c ## COPYRIGHT (C) 2003 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module ktrtor -- torsion-torsion forcefield parameters ## c ## ## c ################################################################ c c c maxntt maximum number of torsion-torsion parameter entries c maxtgrd maximum dimension of torsion-torsion spline grid c maxtgrd2 maximum number of torsion-torsion spline grid points c c tnx number of columns in torsion-torsion spline grid c tny number of rows in torsion-torsion spline grid c ttx angle values for first torsion of spline grid c tty angle values for second torsion of spline grid c tbf function values at points on spline grid c tbx gradient over first torsion of spline grid c tby gradient over second torsion of spline grid c tbxy Hessian cross components over spline grid c ktt string of torsion-torsion atom classes c c module ktrtor implicit none integer maxntt integer maxtgrd integer maxtgrd2 parameter (maxtgrd=30) parameter (maxtgrd2=maxtgrd*maxtgrd) integer, allocatable :: tnx(:) integer, allocatable :: tny(:) real*8, allocatable :: ttx(:,:) real*8, allocatable :: tty(:,:) real*8, allocatable :: tbf(:,:) real*8, allocatable :: tbx(:,:) real*8, allocatable :: tby(:,:) real*8, allocatable :: tbxy(:,:) character*20, allocatable :: ktt(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine kundrot1 -- Cartesian excluded volume derivs ## c ## ## c ################################################################# c c c "kundrot1" calculates first derivatives of the total excluded c volume with respect to the Cartesian coordinates of each atom c using a numerical method due to Craig Kundrot c c literature reference: c c C. E. Kundrot, J. W. Ponder and F. M. Richards, "Algorithms for c Calculating Excluded Volume and Its Derivatives as a Function c of Molecular Conformation and Their Use in Energy Minimization", c Journal of Computational Chemistry, 12, 402-409 (1991) c c subroutine kundrot1 (n,x,y,z,rad,probe,dex) use iounit use math implicit none integer maxcube,maxarc parameter (maxcube=30) parameter (maxarc=1000) integer i,j,k,m,n integer io,ir,in integer narc,nx,ny,nz integer istart,istop integer jstart,jstop integer kstart,kstop integer mstart,mstop integer isum,icube,itemp integer inov(maxarc) integer, allocatable :: itab(:) integer cube(2,maxcube,maxcube,maxcube) real*8 xr,yr,zr real*8 xmin,ymin,zmin real*8 xmax,ymax,zmax real*8 aa,bb,temp,phi_term real*8 theta1,theta2,dtheta real*8 seg_dx,seg_dy,seg_dz real*8 pre_dx,pre_dy,pre_dz real*8 rinsq,rdiff real*8 rsecn,rsec2n real*8 cosine,ti,tf real*8 alpha,beta real*8 ztop,zstart real*8 ztopshave real*8 phi1,cos_phi1 real*8 phi2,cos_phi2 real*8 zgrid,pix2 real*8 rsec2r,rsecr real*8 rr,rrx2,rrsq real*8 rmax,edge real*8 dist2,vdwsum real*8 probe,zstep real*8 arci(maxarc) real*8 arcf(maxarc) real*8 dx(maxarc) real*8 dy(maxarc) real*8 dsq(maxarc) real*8 d(maxarc) real*8 x(*) real*8 y(*) real*8 z(*) real*8 rad(*) real*8, allocatable :: volrad(:) real*8 dex(3,*) logical, allocatable :: skip(:) c c c set the step size in z-direction, which controls derivative c accuracy; step of 0.06 balances compute time and accuracy c for large systems, while step of 0.01 gives higher accuracy c c zstep = 0.0601d0 zstep = 0.0101d0 c c initialize minimum and maximum ranges of atoms c pix2 = 2.0d0 * pi rmax = 0.0d0 xmin = x(1) xmax = x(1) ymin = y(1) ymax = y(1) zmin = z(1) zmax = z(1) c c perform dynamic allocation of some local arrays c allocate (itab(n)) allocate (volrad(n)) allocate (skip(n)) c c assign van der Waals radii to the atoms; note that c the radii are incremented by the size of the probe; c then get the maximum and minimum ranges of atoms c do i = 1, n volrad(i) = rad(i) if (volrad(i) .eq. 0.0d0) then skip(i) = .true. else skip(i) = .false. volrad(i) = volrad(i) + probe if (volrad(i) .gt. rmax) rmax = volrad(i) if (x(i) .lt. xmin) xmin = x(i) if (x(i) .gt. xmax) xmax = x(i) if (y(i) .lt. ymin) ymin = y(i) if (y(i) .gt. ymax) ymax = y(i) if (z(i) .lt. zmin) zmin = z(i) if (z(i) .gt. zmax) zmax = z(i) end if end do c c load the cubes based on coarse lattice; first of all c set edge length to the maximum diameter of any atom c edge = 2.0d0 * rmax nx = int((xmax-xmin)/edge) + 1 ny = int((ymax-ymin)/edge) + 1 nz = int((zmax-zmin)/edge) + 1 if (max(nx,ny,nz) .gt. maxcube) then write (iout,10) 10 format (/,' KUNDROT1 -- Increase the Value of MAXCUBE') call fatal end if c c initialize the coarse lattice of cubes c do i = 1, nx do j = 1, ny do k = 1, nz cube(1,i,j,k) = 0 cube(2,i,j,k) = 0 end do end do end do c c find the number of atoms in each cube c do m = 1, n if (.not. skip(m)) then i = int((x(m)-xmin)/edge) + 1 j = int((y(m)-ymin)/edge) + 1 k = int((z(m)-zmin)/edge) + 1 cube(1,i,j,k) = cube(1,i,j,k) + 1 end if end do c c determine the highest index in the array "itab" for the c atoms that fall into each cube; the first cube that has c atoms defines the first index for "itab"; the final index c for the atoms in the present cube is the final index of c the last cube plus the number of atoms in the present cube c isum = 0 do i = 1, nx do j = 1, ny do k = 1, nz icube = cube(1,i,j,k) if (icube .ne. 0) then isum = isum + icube cube(2,i,j,k) = isum end if end do end do end do c c "cube(2,,,)" now contains a pointer to the array "itab" c giving the position of the last entry for the list of c atoms in that cube of total number equal to "cube(1,,,)" c do m = 1, n if (.not. skip(m)) then i = int((x(m)-xmin)/edge) + 1 j = int((y(m)-ymin)/edge) + 1 k = int((z(m)-zmin)/edge) + 1 icube = cube(2,i,j,k) itab(icube) = m cube(2,i,j,k) = icube - 1 end if end do c c set "cube(2,,,)" to be the starting index in "itab" c for atom list of that cube; and "cube(1,,,)" to be c the stop index c isum = 0 do i = 1, nx do j = 1, ny do k = 1, nz icube = cube(1,i,j,k) if (icube .ne. 0) then isum = isum + icube cube(1,i,j,k) = isum cube(2,i,j,k) = cube(2,i,j,k) + 1 end if end do end do end do c c process in turn each atom from the coordinate list; c first select the potential intersecting atoms c do ir = 1, n pre_dx = 0.0d0 pre_dy = 0.0d0 pre_dz = 0.0d0 if (skip(ir)) goto 50 rr = volrad(ir) rrx2 = 2.0d0 * rr rrsq = rr * rr xr = x(ir) yr = y(ir) zr = z(ir) c c find cubes to search for overlaps of current atom c istart = int((xr-xmin)/edge) istop = min(istart+2,nx) istart = max(istart,1) jstart = int((yr-ymin)/edge) jstop = min(jstart+2,ny) jstart = max(jstart,1) kstart = int((zr-zmin)/edge) kstop = min(kstart+2,nz) kstart = max(kstart,1) c c load all overlapping atoms into "inov" c io = 0 do i = istart, istop do j = jstart, jstop do k = kstart, kstop mstart = cube(2,i,j,k) if (mstart .ne. 0) then mstop = cube(1,i,j,k) do m = mstart, mstop in = itab(m) if (in .ne. ir) then io = io + 1 if (io .gt. maxarc) then write (iout,20) 20 format (/,' KUNDROT1 -- Increase ', & ' the Value of MAXARC') call fatal end if dx(io) = x(in) - xr dy(io) = y(in) - yr dsq(io) = dx(io)**2 + dy(io)**2 dist2 = dsq(io) + (z(in)-zr)**2 vdwsum = (rr+volrad(in))**2 if (dist2.gt.vdwsum .or. dist2.eq.0.0d0) then io = io - 1 else d(io) = sqrt(dsq(io)) inov(io) = in end if end if end do end if end do end do end do c c determine resolution along the z-axis c if (io .ne. 0) then ztop = zr + rr ztopshave = ztop - zstep zgrid = zr - rr c c half of the part not covered by the planes c zgrid = zgrid + 0.5d0*(rrx2-(int(rrx2/zstep)*zstep)) zstart = zgrid c c section atom spheres perpendicular to the z axis c do while (zgrid .le. ztop) c c "rsecr" is radius of circle of intersection c of "ir" sphere on the current sphere c rsec2r = rrsq - (zgrid-zr)**2 if (rsec2r .lt. 0.0d0) rsec2r = 0.000001d0 rsecr = sqrt(rsec2r) if (zgrid .ge. ztopshave) then cos_phi1 = 1.0d0 phi1 = 0.0d0 else cos_phi1 = (zgrid + 0.5d0*zstep - zr) / rr phi1 = acos(cos_phi1) end if if (zgrid .eq. zstart) then cos_phi2 = -1.0d0 phi2 = pi else cos_phi2 = (zgrid - 0.5d0*zstep - zr) / rr phi2 = acos(cos_phi2) end if c c check intersections of neighbor circles c narc = 0 do k = 1, io in = inov(k) rinsq = volrad(in)**2 rsec2n = rinsq - (zgrid-z(in))**2 if (rsec2n .gt. 0.0d0) then rsecn = sqrt(rsec2n) if (d(k) .lt. rsecr+rsecn) then rdiff = rsecr - rsecn if (d(k) .le. abs(rdiff)) then if (rdiff .lt. 0.0d0) then narc = 1 arci(narc) = 0.0d0 arcf(narc) = pix2 end if goto 40 end if narc = narc + 1 if (narc .gt. maxarc) then write (iout,30) 30 format (/,' KUNDROT1 -- Increase', & ' the Value of MAXARC') call fatal end if c c initial and final arc endpoints are found for intersection c of "ir" circle with another circle contained in same plane; c the initial endpoint of the enclosed arc is stored in "arci", c the final endpoint in "arcf"; get "cosine" via law of cosines c cosine = (dsq(k)+rsec2r-rsec2n) & / (2.0d0*d(k)*rsecr) cosine = min(1.0d0,max(-1.0d0,cosine)) c c "alpha" is the angle between a line containing either point c of intersection and the reference circle center and the c line containing both circle centers; "beta" is the angle c between the line containing both circle centers and x-axis c alpha = acos(cosine) beta = atan2(dy(k),dx(k)) if (dy(k) .lt. 0.0d0) beta = beta + pix2 ti = beta - alpha tf = beta + alpha if (ti .lt. 0.0d0) ti = ti + pix2 if (tf .gt. pix2) tf = tf - pix2 arci(narc) = ti c c if the arc crosses zero, then it is broken into two segments; c the first ends at two pi and the second begins at zero c if (tf .lt. ti) then arcf(narc) = pix2 narc = narc + 1 arci(narc) = 0.0d0 end if arcf(narc) = tf 40 continue end if end if end do c c find the pre-area and pre-forces on this section (band), c "pre-" means a multiplicative factor is yet to be applied c if (narc .eq. 0) then seg_dz = pix2 * (cos_phi1**2 - cos_phi2**2) pre_dz = pre_dz + seg_dz else c c sort the arc endpoint arrays, each with "narc" entries, c in order of increasing values of the arguments in "arci" c k = 1 do while (k .lt. narc) aa = arci(k) bb = arcf(k) temp = 1000000.0d0 do i = k, narc if (arci(i) .le. temp) then temp = arci(i) itemp = i end if end do arci(k) = arci(itemp) arcf(k) = arcf(itemp) arci(itemp) = aa arcf(itemp) = bb k = k + 1 end do c c consolidate arcs by removing overlapping arc endpoints c temp = arcf(1) j = 1 do k = 2, narc if (temp .lt. arci(k)) then arcf(j) = temp j = j + 1 arci(j) = arci(k) temp = arcf(k) else if (temp .lt. arcf(k)) then temp = arcf(k) end if end do arcf(j) = temp narc = j if (narc .eq. 1) then narc = 2 arcf(2) = pix2 arci(2) = arcf(1) arcf(1) = arci(1) arci(1) = 0.0d0 else temp = arci(1) do k = 1, narc-1 arci(k) = arcf(k) arcf(k) = arci(k+1) end do if (temp.eq.0.0d0 .and. arcf(narc).eq.pix2) then narc = narc - 1 else arci(narc) = arcf(narc) arcf(narc) = temp end if end if c c compute the numerical pre-derivative values c do k = 1, narc theta1 = arci(k) theta2 = arcf(k) if (theta2 .ge. theta1) then dtheta = theta2 - theta1 else dtheta = (theta2+pix2) - theta1 end if phi_term = phi2 - phi1 - 0.5d0*(sin(2.0d0*phi2) & -sin(2.0d0*phi1)) seg_dx = (sin(theta2)-sin(theta1)) * phi_term seg_dy = (cos(theta1)-cos(theta2)) * phi_term seg_dz = dtheta * (cos_phi1**2 - cos_phi2**2) pre_dx = pre_dx + seg_dx pre_dy = pre_dy + seg_dy pre_dz = pre_dz + seg_dz end do end if zgrid = zgrid + zstep end do end if 50 continue dex(1,ir) = 0.5d0 * rrsq * pre_dx dex(2,ir) = 0.5d0 * rrsq * pre_dy dex(3,ir) = 0.5d0 * rrsq * pre_dz end do c c perform deallocation of some local arrays c deallocate (itab) deallocate (volrad) deallocate (skip) return end c c c ################################################################## c ## ## c ## subroutine kundrot2 -- Cartesian excluded volume Hessian ## c ## ## c ################################################################## c c c "kundrot2" calculates second derivatives of the total excluded c volume with respect to the Cartesian coordinates of the atoms c using a numerical method due to Craig Kundrot c c literature reference: c c C. E. Kundrot, J. W. Ponder and F. M. Richards, "Algorithms for c Calculating Excluded Volume and Its Derivatives as a Function c of Molecular Conformation and Their Use in Energy Minimization", c Journal of Computational Chemistry, 12, 402-409 (1991) c c subroutine kundrot2 (iatom,n,x,y,z,rad,probe,xhess,yhess,zhess) use iounit use math implicit none integer maxarc parameter (maxarc=1000) integer i,j,k,m,n integer in,iaa,ibb integer iatom,narc integer iblock,itemp integer idtemp,idfirst integer nnear,id(0:2) integer inear(maxarc) integer arciatom(maxarc) integer arcfatom(maxarc) real*8 xr,yr,zr real*8 probe,zstep real*8 ztop,ztopshave,zstart real*8 aa,bb,temp,tempf real*8 phi1,phi2,phiold real*8 theta1,theta2,firsti real*8 zgrid,rsec2r,rsecr real*8 pix2,dist2,rcut2 real*8 rr,rrx2,rrsq real*8 alpha,beta,gamma real*8 ti,tf,ri,s2,b,cosine real*8 rinsq,rsecn,rsec2n real*8 cos1,cos2,sin1,sin2 real*8 phi_xy,phi_z real*8 delx(2),dely(2),delz(2) real*8 r_s(2),r_s2(2),u(2) real*8 r(0:2),r_r(0:2) real*8 duds(2),dudr(2) real*8 u_term(2) real*8 dfdtheta(3,2) real*8 dthetadx(2,3,0:2) real*8 dalphdx(2,3,0:2) real*8 dbetadx(2,2,0:2) real*8 dudx(2,3,0:2) real*8 dsdx(2,2,0:2) real*8 drdz(2,0:2) real*8 arci(maxarc) real*8 arcf(maxarc) real*8 dx(maxarc) real*8 dy(maxarc) real*8 dsq(maxarc) real*8 d(maxarc) real*8 x(*) real*8 y(*) real*8 z(*) real*8 rad(*) real*8, allocatable :: volrad(:) real*8 xhess(3,*) real*8 yhess(3,*) real*8 zhess(3,*) logical covered c c c set the step size in z-direction, which controls derivative c accuracy; step of 0.06 balances compute time and accuracy c for large systems, while step of 0.01 gives higher accuracy c c zstep = 0.0601d0 zstep = 0.0101d0 c c zero out the Hessian elements for current atom c do i = 1, n do j = 1, 3 xhess(j,i) = 0.0d0 yhess(j,i) = 0.0d0 zhess(j,i) = 0.0d0 end do end do if (rad(iatom) .eq. 0.0d0) return pix2 = 2.0d0 * pi c c perform dynamic allocation of some local arrays c allocate (volrad(n)) c c assign van der Waals radii to the atoms; note that c the radii are incremented by the size of the probe c do i = 1, n volrad(i) = rad(i) if (volrad(i) .ne. 0.0d0) volrad(i) = volrad(i) + probe end do c c set the radius and coordinates for current atom c rr = volrad(iatom) rrx2 = 2.0d0 * rr rrsq = rr**2 xr = x(iatom) yr = y(iatom) zr = z(iatom) c c select potential intersecting atoms c nnear = 1 do j = 1, n if (j.ne.iatom .and. volrad(j).ne.0.0d0) then dx(nnear) = x(j) - xr dy(nnear) = y(j) - yr dsq(nnear) = dx(nnear)**2 + dy(nnear)**2 dist2 = dsq(nnear) + (z(j)-zr)**2 rcut2 = (volrad(j) + rr)**2 if (dist2 .lt. rcut2) then d(nnear) = sqrt(dsq(nnear)) inear(nnear) = j nnear = nnear + 1 if (nnear .gt. maxarc) then write (iout,10) 10 format (/,' KUNDROT2 -- Increase', & ' the Value of MAXARC') call fatal end if end if end if end do nnear = nnear - 1 c c determine the z resolution c if (nnear .ne. 0) then ztop = zr + rr ztopshave = ztop - zstep zgrid = zr - rr c c half of the part not covered by the planes c zgrid = zgrid + (0.5d0*(rrx2-(int(rrx2/zstep)*zstep))) zstart = zgrid c c section atom spheres perpendicular to the z axis c do while (zgrid .le. ztop) c c "rsecr" is radius of current atom sphere on the z-plane c rsec2r = rrsq - (zgrid-zr)**2 if (rsec2r .lt. 0.0d0) then rsec2r = 0.000001d0 end if rsecr = sqrt(rsec2r) if (zgrid .ge. ztopshave) then phi1 = 0.0d0 else phi1 = acos(((zgrid+0.5d0*zstep)-zr) / rr) end if if (zgrid .eq. zstart) then phi2 = pi else phi2 = phiold end if c c check intersections of neighbor circles c k = 0 narc = 0 covered = .false. do while (.not.covered .and. k.lt.nnear & .and. narc.lt.maxarc) k = k + 1 in = inear(k) rinsq = volrad(in)**2 rsec2n = rinsq - (zgrid-z(in))**2 if (rsec2n .gt. 0.0d0) then rsecn = sqrt(rsec2n) if (d(k) .lt. rsecr+rsecn) then b = rsecr - rsecn if (d(k) .le. abs(b)) then if (b .lt. 0.0d0) then narc = 1 arci(narc) = 0.0d0 arcf(narc) = pix2 arciatom(narc) = in arcfatom(narc) = in covered = .true. end if else narc = narc + 1 if (narc .gt. maxarc) then write (iout,20) 20 format (/,' KUNDROT2 -- Increase', & ' the Value of MAXARC') call fatal else c c initial and final arc endpoints are found for intersection c of "ir" circle with another circle contained in same plane; c the initial endpoint of the enclosed arc is stored in "arci", c the final endpoint in "arcf"; get "cosine" via law of cosines c cosine = (dsq(k)+rsec2r-rsec2n) / & (2.0d0*d(k)*rsecr) cosine = min(1.0d0,max(-1.0d0,cosine)) c c "alpha" is the angle between a line containing either point c of intersection and the reference circle center and the c line containing both circle centers; "beta" is the angle c between the line containing both circle centers and x-axis c alpha = acos(cosine) if (dx(k) .eq. 0.0d0) then gamma = 0.5d0 * pi else gamma = atan(abs(dy(k)/dx(k))) end if if (dy(k) .gt. 0.0d0) then if (dx(k) .gt. 0.0d0) then beta = gamma else beta = pi - gamma end if else if (dx(k) .gt. 0.0d0) then beta = pix2 - gamma else beta = pi + gamma end if end if c c finally, the arc endpoints c ti = beta - alpha tf = beta + alpha if (ti .lt. 0.0d0) ti = ti + pix2 if (tf .gt. pix2) tf = tf - pix2 arci(narc) = ti arciatom(narc) = in arcfatom(narc) = in if (tf .lt. ti) then arcf(narc) = pix2 narc = narc + 1 arci(narc) = 0.0d0 arciatom(narc) = in arcfatom(narc) = in end if arcf(narc) = tf end if end if end if end if end do c c find the pre-area and pre-forces on this section (band) c through sphere "ir"; the "pre-" means a multiplicative c factor is yet to be applied c if (narc .ne. 0) then c c general case; sort arc endpoints c k = 1 do while (k .lt. narc) aa = arci(k) bb = arcf(k) iaa = arciatom(k) ibb = arcfatom(k) temp = 10000000.0d0 do i = k, narc if (arci(i) .le. temp) then temp = arci(i) itemp = i end if end do arci(k) = arci(itemp) arcf(k) = arcf(itemp) arciatom(k) = arciatom(itemp) arcfatom(k) = arcfatom(itemp) arci(itemp) = aa arcf(itemp) = bb arciatom(itemp) = iaa arcfatom(itemp) = ibb k = k + 1 end do c c eliminate overlapping arc endpoints; c first, consolidate the occluded arcs c m = 1 tempf = arcf(1) idtemp = arcfatom(1) do k = 2, narc if (tempf .lt. arci(k)) then arcf(m) = tempf arcfatom(m) = idtemp m = m + 1 arci(m) = arci(k) arciatom(m) = arciatom(k) tempf = arcf(k) idtemp = arcfatom(k) else if (tempf .lt. arcf(k)) then tempf = arcf(k) idtemp = arcfatom(k) end if end do arcf(m) = tempf arcfatom(m) = idtemp narc = m c c change occluded arcs to accessible arcs c if (narc .eq. 1) then if (arci(1).eq.0.0d0 .and. arcf(1).eq.pix2) then narc = 0 else firsti = arci(1) idfirst = arciatom(1) arci(1) = arcf(1) arciatom(1) = arcfatom(1) arcf(1) = firsti + pix2 arcfatom(1) = idfirst end if else firsti = arci(1) idfirst = arciatom(1) do k = 1, narc-1 arci(k) = arcf(k) arciatom(k) = arcfatom(k) arcf(k) = arci(k+1) arcfatom(k) = arciatom(k+1) end do c c check gap between first and last arcs; if the c occluded arc crossed zero, then no accessible arc c if (firsti.eq.0.0d0 .and. arcf(narc).eq.pix2) then narc = narc - 1 else arci(narc) = arcf(narc) arciatom(narc) = arcfatom(narc) arcf(narc) = firsti arcfatom(narc) = idfirst end if end if c c setup prior to application of chain rule c do k = 1, narc ri = sqrt(rrsq - (zgrid-zr)**2) do i = 1, 2 if (i .eq. 1) then id(1) = arciatom(k) else id(2) = arcfatom(k) end if delx(i) = x(id(i)) - xr dely(i) = y(id(i)) - yr delz(i) = zgrid - z(id(i)) s2 = delx(i)**2 + dely(i)**2 r_s(i) = 1.0d0 / sqrt(s2) r_s2(i) = r_s(i)**2 r(i) = sqrt(volrad(id(i))**2 - delz(i)**2) r_r(i) = 1.0d0 / r(i) u(i) = (ri**2+s2-r(i)**2) * (0.5d0*r_s(i)/ri) end do c c apply the chain rule repeatedly c theta1 = arci(k) theta2 = arcf(k) cos1 = cos(theta1) cos2 = cos(theta2) sin1 = sin(theta1) sin2 = sin(theta2) phi_xy = phi2 - phi1 - 0.5d0*(sin(2.0d0*phi2) & -sin(2.0d0*phi1)) phi_z = sin(phi2)**2 - sin(phi1)**2 phi_xy = 0.5d0 * rrsq * phi_xy phi_z = 0.5d0 * rrsq * phi_z dfdtheta(1,1) = -cos1 * phi_xy dfdtheta(2,1) = -sin1 * phi_xy dfdtheta(3,1) = -phi_z dfdtheta(1,2) = cos2 * phi_xy dfdtheta(2,2) = sin2 * phi_xy dfdtheta(3,2) = phi_z do i = 1, 2 dbetadx(i,1,0) = dely(i) * r_s2(i) dbetadx(i,2,0) = -delx(i) * r_s2(i) dbetadx(i,1,i) = -dbetadx(i,1,0) dbetadx(i,2,i) = -dbetadx(i,2,0) end do do i = 1, 2 duds(i) = (1.0d0/ri) - (u(i)*r_s(i)) dsdx(i,1,i) = delx(i) * r_s(i) dsdx(i,2,i) = dely(i) * r_s(i) dsdx(i,1,0) = -dsdx(i,1,i) dsdx(i,2,0) = -dsdx(i,2,i) dudr(i) = -r(i) * r_s(i) / ri drdz(i,i) = delz(i) * r_r(i) drdz(i,0) = -drdz(i,i) end do do m = 0, 2 do i = 1, 2 dudx(i,1,m) = duds(i) * dsdx(i,1,m) dudx(i,2,m) = duds(i) * dsdx(i,2,m) dudx(i,3,m) = dudr(i) * drdz(i,m) end do end do do i = 1, 2 u_term(i) = -1.0d0 / sqrt(1.0d0-u(i)**2) end do do j = 1, 3 do m = 0, 2 do i = 1, 2 dalphdx(i,j,m) = u_term(i) * dudx(i,j,m) end do end do end do do j = 1, 2 do m = 0, 2 dthetadx(1,j,m) = dbetadx(1,j,m) & + dalphdx(1,j,m) dthetadx(2,j,m) = dbetadx(2,j,m) & - dalphdx(2,j,m) end do end do do m = 0, 2 dthetadx(1,3,m) = dalphdx(1,3,m) dthetadx(2,3,m) = -dalphdx(2,3,m) end do c c partials with respect to coordinates of serial atom id(m) c id(0) = iatom do m = 0, 2 iblock = id(m) do j = 1, 3 xhess(j,iblock) = xhess(j,iblock) & + dfdtheta(1,1)*dthetadx(1,j,m) & + dfdtheta(1,2)*dthetadx(2,j,m) yhess(j,iblock) = yhess(j,iblock) & + dfdtheta(2,1)*dthetadx(1,j,m) & + dfdtheta(2,2)*dthetadx(2,j,m) zhess(j,iblock) = zhess(j,iblock) & + dfdtheta(3,1)*dthetadx(1,j,m) & + dfdtheta(3,2)*dthetadx(2,j,m) end do end do end do end if zgrid = zgrid + zstep phiold = phi1 end do end if c c perform deallocation of some local arrays c deallocate (volrad) return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine kurey -- Urey-Bradley parameter assignment ## c ## ## c ############################################################### c c c "kurey" assigns the force constants and ideal distances c for the Urey-Bradley 1-3 interactions; also processes any c new or changed parameter values c c subroutine kurey use angbnd use atomid use atoms use inform use iounit use keys use kurybr use potent use urey implicit none integer i,j,nu integer ia,ib,ic integer ita,itb,itc integer size,next real*8 bb,tt logical header character*4 pa,pb,pc character*12 blank,pt character*20 keyword character*240 record character*240 string c c c process keywords containing Urey-Bradley parameters c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:9) .eq. 'UREYBRAD ') then ia = 0 ib = 0 ic = 0 bb = 0.0d0 tt = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) ia,ib,ic,bb,tt 10 continue if (min(ia,ib,ic) .lt. 0) goto 50 if (.not. silent) then if (header) then header = .false. write (iout,20) 20 format (/,' Additional Urey-Bradley Parameters :', & //,5x,'Atom Classes',12x,'K(UB)', & 7x,'Distance',/) end if write (iout,30) ia,ib,ic,bb,tt 30 format (4x,3i4,3x,f15.3,f15.4) end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) if (ia .le. ic) then pt = pa//pb//pc else pt = pc//pb//pa end if do j = 1, maxnu if (ku(j).eq.blank .or. ku(j).eq.pt) then ku(j) = pt ucon(j) = bb dst13(j) = tt goto 50 end if end do write (iout,40) 40 format (/,' KUREY -- Too many Urey-Bradley', & ' Interaction Parameters') abort = .true. 50 continue end if end do c c determine the total number of forcefield parameters c nu = maxnu do i = maxnu, 1, -1 if (ku(i) .eq. blank) nu = i - 1 end do c c perform dynamic allocation of some global arrays c if (allocated(iury)) deallocate (iury) if (allocated(uk)) deallocate (uk) if (allocated(ul)) deallocate (ul) allocate (iury(3,nangle)) allocate (uk(nangle)) allocate (ul(nangle)) c c assign the Urey-Bradley parameters for each angle c nurey = 0 if (nu .ne. 0) then do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pt = pa//pb//pc else pt = pc//pb//pa end if do j = 1, nu if (ku(j) .eq. pt) then nurey = nurey + 1 iury(1,nurey) = ia iury(2,nurey) = ib iury(3,nurey) = ic uk(nurey) = ucon(j) ul(nurey) = dst13(j) goto 60 end if end do 60 continue end do end if c c process keywords containing Urey-Bradley specific parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:9) .eq. 'UREYBRAD ') then ia = 0 ib = 0 ic = 0 bb = 0.0d0 tt = 0.0d0 string = record(next:240) read (string,*,err=70,end=70) ia,ib,ic,bb,tt 70 continue if (min(ia,ib,ic) .lt. 0) then ia = abs(ia) ib = abs(ib) ic = abs(ic) if (header .and. .not.silent) then header = .false. write (iout,80) 80 format (/,' Additional Urey-Bradley Parameters', & ' for Specific Angles :', & //,8x,'Atoms',16x,'K(UB)',7x,'Distance',/) end if if (.not. silent) then write (iout,90) ia,ib,ic,bb,tt 90 format (4x,3i4,3x,f15.3,f15.4) end if do j = 1, nurey ita = iury(1,j) itb = iury(2,j) itc = iury(3,j) if (ib .eq. itb) then if ((ia.eq.ita .and. ic.eq.itc) .or. & (ia.eq.itc .and. ic.eq.ita)) then uk(j) = bb ul(j) = tt goto 100 end if end if end do end if 100 continue end if end do c c turn off the Urey-Bradley potential if it is not used c if (nurey .eq. 0) use_urey = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module kurybr -- Urey-Bradley term forcefield parameters ## c ## ## c ################################################################## c c c maxnu maximum number of Urey-Bradley parameter entries c c ucon force constant parameters for Urey-Bradley terms c dst13 ideal 1-3 distance parameters for Urey-Bradley terms c ku string of atom classes for Urey-Bradley terms c c module kurybr implicit none integer maxnu real*8, allocatable :: ucon(:) real*8, allocatable :: dst13(:) character*12, allocatable :: ku(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine kvdw -- van der Waals parameter assignment ## c ## ## c ############################################################### c c c "kvdw" assigns the parameters to be used in computing the c van der Waals interactions and processes any new or changed c values for these parameters c c subroutine kvdw use atomid use atoms use couple use fields use inform use iounit use keys use khbond use kvdws use kvdwpr use math use merck use potent use vdw use vdwpot implicit none integer i,j,k integer ii,kk integer ia,ib integer next,size integer maxdim integer nlist,number integer, allocatable :: list(:) real*8 rd,ep,rdn,gik real*8, allocatable :: srad(:) real*8, allocatable :: srad4(:) real*8, allocatable :: seps(:) real*8, allocatable :: seps4(:) logical header character*4 pa,pb character*8 blank,pt character*20 keyword character*240 record character*240 string c c c process keywords containing van der Waals parameters c maxdim = maxclass if (vdwindex .eq. 'TYPE') maxdim = maxtyp header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:4) .eq. 'VDW ') then call getnumb (record,k,next) if (k.gt.0 .and. k.le.maxdim) then rd = 0.0d0 ep = 0.0d0 rdn = 0.0d0 string = record(next:240) read (string,*,err=10,end=10) rd,ep,rdn 10 continue if (header .and. .not.silent) then header = .false. if (vdwindex .eq. 'CLASS') then write (iout,20) 20 format (/,' Additional van der Waals Parameters :', & //,5x,'Atom Class',15x,'Size', & 8x,'Epsilon',8x,'Reduction',/) else write (iout,30) 30 format (/,' Additional van der Waals Parameters :', & //,5x,'Atom Type',16x,'Size', & 8x,'Epsilon',8x,'Reduction',/) end if end if rad(k) = rd eps(k) = ep reduct(k) = rdn if (.not. silent) then write (iout,40) k,rd,ep,rdn 40 format (6x,i6,7x,2f15.4,f15.3) end if else if (k .gt. maxclass) then write (iout,50) maxclass 50 format (/,' KVDW -- Only Atom Classes through',i4, & ' are Allowed') abort = .true. end if end if end do c c process keywords containing 1-4 van der Waals parameters c maxdim = maxclass if (vdwindex .eq. 'TYPE') maxdim = maxtyp header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:6) .eq. 'VDW14 ') then call getnumb (record,k,next) if (k.gt.0 .and. k.le.maxdim) then rd = 0.0d0 ep = 0.0d0 string = record(next:240) read (string,*,err=60,end=60) rd,ep 60 continue if (header .and. .not.silent) then header = .false. if (vdwindex .eq. 'CLASS') then write (iout,70) 70 format (/,' Additional 1-4 van der Waals', & ' Parameters :', & //,5x,'Atom Class',15x,'Size', & 8x,'Epsilon',/) else write (iout,80) 80 format (/,' Additional 1-4 van der Waals', & ' Parameters :', & //,5x,'Atom Type',16x,'Size', & 8x,'Epsilon',/) end if end if rad4(k) = rd eps4(k) = ep if (.not. silent) then write (iout,90) k,rd,ep 90 format (6x,i6,7x,2f15.4) end if else if (k .gt. maxclass) then write (iout,100) maxclass 100 format (/,' KVDW -- Only Atom Classes through',i4, & ' are Allowed') abort = .true. end if end if end do c c process keywords containing specific pair vdw parameters c blank = ' ' header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:8) .eq. 'VDWPAIR ' .or. & keyword(1:6) .eq. 'VDWPR ') then ia = 0 ib = 0 rd = 0.0d0 ep = 0.0d0 string = record(next:240) read (string,*,err=150,end=150) ia,ib,rd,ep if (header .and. .not.silent) then header = .false. if (vdwindex .eq. 'CLASS') then write (iout,110) 110 format (/,' Additional van der Waals Parameters', & ' for Specific Pairs :', & //,5x,'Atom Classes',9x,'Size Sum', & 8x,'Epsilon',/) else write (iout,120) 120 format (/,' Additional van der Waals Parameters', & ' for Specific Pairs :', & //,5x,'Atom Types',11x,'Size Sum', & 8x,'Epsilon',/) end if end if if (.not. silent) then write (iout,130) ia,ib,rd,ep 130 format (6x,2i4,5x,2f15.4) end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) if (ia .le. ib) then pt = pa//pb else pt = pb//pa end if do k = 1, maxnvp if (kvpr(k).eq.blank .or. kvpr(k).eq.pt) then kvpr(k) = pt radpr(k) = rd epspr(k) = ep goto 150 end if end do write (iout,140) 140 format (/,' KVDW -- Too many Special Pair VDW', & ' Parameters') abort = .true. 150 continue end if end do c c process keywords containing hydrogen bonding vdw parameters c header = .true. do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:6) .eq. 'HBOND ') then ia = 0 ib = 0 rd = 0.0d0 ep = 0.0d0 string = record(next:240) read (string,*,err=200,end=200) ia,ib,rd,ep if (header .and. .not.silent) then header = .false. if (vdwindex .eq. 'CLASS') then write (iout,160) 160 format (/,' Additional van der Waals Hydrogen', & ' Bonding Parameters :', & //,5x,'Atom Classes',9x,'Size Sum', & 8x,'Epsilon',/) else write (iout,170) 170 format (/,' Additional van der Waals Hydrogen', & ' Bonding Parameters :', & //,5x,'Atom Types',11x,'Size Sum', & 8x,'Epsilon',/) end if end if if (.not. silent) then write (iout,180) ia,ib,rd,ep 180 format (6x,2i4,5x,2f15.4) end if size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) if (ia .le. ib) then pt = pa//pb else pt = pb//pa end if do k = 1, maxnvp if (khb(k).eq.blank .or. khb(k).eq.pt) then khb(k) = pt radhb(k) = rd epshb(k) = ep goto 200 end if end do write (iout,190) 190 format (/,' KVDW -- Too many Hydrogen Bonding Pair', & ' Parameters') abort = .true. 200 continue end if end do c c perform dynamic allocation of some global arrays c if (allocated(ivdw)) deallocate (ivdw) if (allocated(jvdw)) deallocate (jvdw) if (allocated(mvdw)) deallocate (mvdw) if (allocated(ired)) deallocate (ired) if (allocated(kred)) deallocate (kred) if (allocated(xred)) deallocate (xred) if (allocated(yred)) deallocate (yred) if (allocated(zred)) deallocate (zred) allocate (ivdw(n)) allocate (jvdw(n)) allocate (mvdw(maxtyp)) allocate (ired(n)) allocate (kred(n)) allocate (xred(n)) allocate (yred(n)) allocate (zred(n)) c c perform dynamic allocation of some local arrays c allocate (list(n)) allocate (srad(maxtyp)) allocate (srad4(maxtyp)) allocate (seps(maxtyp)) allocate (seps4(maxtyp)) c c set type or class index into condensed pair matrices c nlist = n do i = 1, n list(i) = 0 if (vdwindex .eq. 'TYPE') then list(i) = type(i) else list(i) = class(i) end if jvdw(i) = list(i) end do call sort8 (nlist,list) do i = 1, maxtyp mvdw(i) = 0 end do do i = 1, n j = jvdw(i) if (mvdw(j) .eq. 0) then do k = 1, nlist if (list(k) .eq. j) mvdw(j) = k end do end if end do do i = 1, n if (vdwindex .eq. 'TYPE') then k = type(i) jvdw(i) = mvdw(k) else k = class(i) jvdw(i) = mvdw(k) end if end do c c get the vdw radii and well depths for each atom type c maxdim = maxclass if (vdwindex .eq. 'TYPE') maxdim = maxtyp do i = 1, maxdim if (rad4(i) .eq. 0.0d0) rad4(i) = rad(i) if (eps4(i) .eq. 0.0d0) eps4(i) = eps(i) if (radtyp .eq. 'SIGMA') then rad(i) = twosix * rad(i) rad4(i) = twosix * rad4(i) end if if (radsiz .eq. 'DIAMETER') then rad(i) = 0.5d0 * rad(i) rad4(i) = 0.5d0 * rad4(i) end if srad(i) = sqrt(rad(i)) eps(i) = abs(eps(i)) seps(i) = sqrt(eps(i)) srad4(i) = sqrt(rad4(i)) eps4(i) = abs(eps4(i)) seps4(i) = sqrt(eps4(i)) end do c c perform dynamic allocation of some global arrays c if (allocated(radmin)) deallocate (radmin) if (allocated(epsilon)) deallocate (epsilon) if (allocated(radmin4)) deallocate (radmin4) if (allocated(epsilon4)) deallocate (epsilon4) if (allocated(radhbnd)) deallocate (radhbnd) if (allocated(epshbnd)) deallocate (epshbnd) allocate (radmin(nlist,nlist)) allocate (epsilon(nlist,nlist)) allocate (radmin4(nlist,nlist)) allocate (epsilon4(nlist,nlist)) allocate (radhbnd(nlist,nlist)) allocate (epshbnd(nlist,nlist)) c c use combination rules to set pairwise vdw radii sums c do ii = 1, nlist i = list(ii) do kk = ii, nlist k = list(kk) if (radrule(1:6) .eq. 'MMFF94') then if (i .ne. k) then rd = 0.5d0 * (rad(i)+rad(k)) if (DA(i).ne.'D' .and. DA(k).ne.'D') then if (rd .ne. 0.0d0) then gik = (rad(i)-rad(k))/(rad(i)+rad(k)) rd = (1.0d0+0.2d0*(1.0d0-exp(-12.0d0*gik*gik))) & * rd end if end if else rd = rad(i) end if else if (rad(i).eq.0.0d0 .and. rad(k).eq.0.0d0) then rd = 0.0d0 else if (radrule(1:10) .eq. 'ARITHMETIC') then rd = rad(i) + rad(k) else if (radrule(1:9) .eq. 'GEOMETRIC') then rd = 2.0d0 * (srad(i) * srad(k)) else if (radrule(1:10) .eq. 'CUBIC-MEAN') then rd = 2.0d0 * (rad(i)**3+rad(k)**3)/(rad(i)**2+rad(k)**2) else rd = rad(i) + rad(k) end if radmin(ii,kk) = rd radmin(kk,ii) = rd end do end do c c use combination rules to set pairwise well depths c do ii = 1, nlist i = list(ii) do kk = ii, nlist k = list(kk) if (epsrule(1:6) .eq. 'MMFF94') then ep = 0.0d0 if (nn(i).ne.0.0d0 .and. nn(k).ne.0.0d0 & .and. radmin(ii,kk).ne.0.0d0) then ep = 181.16d0*g(i)*g(k)*alph(i)*alph(k) & / ((sqrt(alph(i)/nn(i))+sqrt(alph(k)/nn(k))) & *radmin(ii,kk)**6) end if if (i .eq. k) eps(i) = ep else if (eps(i).eq.0.0d0 .and. eps(k).eq.0.0d0) then ep = 0.0d0 else if (epsrule(1:10) .eq. 'ARITHMETIC') then ep = 0.5d0 * (eps(i) + eps(k)) else if (epsrule(1:9) .eq. 'GEOMETRIC') then ep = seps(i) * seps(k) else if (epsrule(1:8) .eq. 'HARMONIC') then ep = 2.0d0 * (eps(i)*eps(k)) / (eps(i)+eps(k)) else if (epsrule(1:3) .eq. 'HHG') then ep = 4.0d0 * (eps(i)*eps(k)) / (seps(i)+seps(k))**2 else if (epsrule(1:3) .eq. 'W-H') then ep = 2.0d0 * (seps(i)*seps(k)) * (rad(i)*rad(k))**3 & / (rad(i)**6+rad(k)**6) else ep = seps(i) * seps(k) end if epsilon(ii,kk) = ep epsilon(kk,ii) = ep end do end do c c use combination rules to set pairwise 1-4 vdw radii sums c do ii = 1, nlist i = list(ii) do kk = ii, nlist k = list(kk) if (radrule(1:6) .eq. 'MMFF94') then if (i .ne. k) then rd = 0.5d0 * (rad(i)+rad(k)) if (DA(i).ne.'D' .and. DA(k).ne.'D') then if (rd .ne. 0.0d0) then gik = (rad(i)-rad(k))/(rad(i)+rad(k)) rd = (1.0d0+0.2d0*(1.0d0-exp(-12.0d0*gik*gik))) & * rd end if end if else rd = rad(i) end if else if (rad4(i).eq.0.0d0 .and. rad4(k).eq.0.0d0) then rd = 0.0d0 else if (radrule(1:10) .eq. 'ARITHMETIC') then rd = rad4(i) + rad4(k) else if (radrule(1:9) .eq. 'GEOMETRIC') then rd = 2.0d0 * (srad4(i) * srad4(k)) else if (radrule(1:10) .eq. 'CUBIC-MEAN') then rd = 2.0d0 * (rad4(i)**3+rad4(k)**3) & / (rad4(i)**2+rad4(k)**2) else rd = rad4(i) + rad4(k) end if radmin4(ii,kk) = rd radmin4(kk,ii) = rd end do end do c c use combination rules to set pairwise 1-4 well depths c do ii = 1, nlist i = list(ii) do kk = ii, nlist k = list(kk) if (epsrule(1:6) .eq. 'MMFF94') then ep = 0.0d0 if (nn(i).ne.0.0d0 .and. nn(k).ne.0.0d0 & .and. radmin4(ii,kk).ne.0.0d0) then ep = 181.16d0*G(i)*G(k)*alph(i)*alph(k) & / ((sqrt(alph(i)/nn(i))+sqrt(alph(k)/nn(k))) & *radmin4(ii,kk)**6) end if if (i .eq. k) eps4(i) = ep else if (eps4(i).eq.0.0d0 .and. eps4(k).eq.0.0d0) then ep = 0.0d0 else if (epsrule(1:10) .eq. 'ARITHMETIC') then ep = 0.5d0 * (eps4(i) + eps4(k)) else if (epsrule(1:9) .eq. 'GEOMETRIC') then ep = seps4(i) * seps4(k) else if (epsrule(1:8) .eq. 'HARMONIC') then ep = 2.0d0 * (eps4(i)*eps4(k)) / (eps4(i)+eps4(k)) else if (epsrule(1:3) .eq. 'HHG') then ep = 4.0d0 * (eps4(i)*eps4(k)) / (seps4(i)+seps4(k))**2 else if (epsrule(1:3) .eq. 'W-H') then ep = 2.0d0 * (seps4(i)*seps4(k)) * (rad4(i)*rad4(k))**3 & / (rad4(i)**6+rad4(k)**6) else ep = seps4(i) * seps4(k) end if epsilon4(ii,kk) = ep epsilon4(kk,ii) = ep end do end do c c use reduced values for MMFF donor-acceptor pairs c if (forcefield .eq. 'MMFF94') then do ii = 1, nlist i = list(ii) do kk = ii, nlist k = list(kk) if ((da(i).eq.'D' .and. da(k).eq.'A') .or. & (da(i).eq.'A' .and. da(k).eq.'D')) then epsilon(ii,kk) = epsilon(ii,kk) * 0.5d0 epsilon(kk,ii) = epsilon(kk,ii) * 0.5d0 radmin(ii,kk) = radmin(ii,kk) * 0.8d0 radmin(kk,ii) = radmin(kk,ii) * 0.8d0 epsilon4(ii,kk) = epsilon4(ii,kk) * 0.5d0 epsilon4(kk,ii) = epsilon4(kk,ii) * 0.5d0 radmin4(ii,kk) = radmin4(ii,kk) * 0.8d0 radmin4(kk,ii) = radmin4(kk,ii) * 0.8d0 end if end do end do end if c c vdw reduction factor information for each individual atom c do i = 1, n ired(i) = i kred(i) = 0.0d0 if (vdwindex .eq. 'TYPE') then kred(i) = reduct(type(i)) else kred(i) = reduct(class(i)) end if if (n12(i).eq.1 .and. kred(i).ne.0.0d0) then ired(i) = i12(1,i) end if end do c c apply radii and well depths for special atom class pairs c do i = 1, maxnvp if (kvpr(i) .eq. blank) goto 230 ia = number(kvpr(i)(1:4)) ib = number(kvpr(i)(5:8)) if (rad(ia) .eq. 0.0d0) rad(ia) = 0.001d0 if (rad(ib) .eq. 0.0d0) rad(ib) = 0.001d0 ia = mvdw(ia) ib = mvdw(ib) if (ia.ne.0 .and. ib.ne.0) then if (radtyp .eq. 'SIGMA') radpr(i) = twosix * radpr(i) radmin(ia,ib) = radpr(i) radmin(ib,ia) = radpr(i) epsilon(ia,ib) = abs(epspr(i)) epsilon(ib,ia) = abs(epspr(i)) radmin4(ia,ib) = radpr(i) radmin4(ib,ia) = radpr(i) epsilon4(ia,ib) = abs(epspr(i)) epsilon4(ib,ia) = abs(epspr(i)) end if end do 230 continue c c set radii and well depths for hydrogen bonding pairs c if (vdwtyp .eq. 'MM3-HBOND') then do i = 1, nlist do k = 1, nlist radhbnd(k,i) = 0.0d0 epshbnd(k,i) = 0.0d0 end do end do do i = 1, maxnhb if (khb(i) .eq. blank) goto 240 ia = number(khb(i)(1:4)) ib = number(khb(i)(5:8)) if (rad(ia) .eq. 0.0d0) rad(ia) = 0.001d0 if (rad(ib) .eq. 0.0d0) rad(ib) = 0.001d0 ia = mvdw(ia) ib = mvdw(ib) if (ia.ne.0 .and. ib.ne.0) then if (radtyp .eq. 'SIGMA') radhb(i) = twosix * radhb(i) radhbnd(ia,ib) = radhb(i) radhbnd(ib,ia) = radhb(i) epshbnd(ia,ib) = abs(epshb(i)) epshbnd(ib,ia) = abs(epshb(i)) end if end do 240 continue end if c c perform deallocation of some local arrays c deallocate (list) deallocate (srad) deallocate (srad4) deallocate (seps) deallocate (seps4) c c set coefficients for Gaussian fit to eps=1 and radmin=1 c if (vdwtyp .eq. 'GAUSSIAN') then if (gausstyp .eq. 'LJ-4') then ngauss = 4 igauss(1,1) = 846706.7d0 igauss(2,1) = 15.464405d0 * twosix**2 igauss(1,2) = 2713.651d0 igauss(2,2) = 7.346875d0 * twosix**2 igauss(1,3) = -9.699172d0 igauss(2,3) = 1.8503725d0 * twosix**2 igauss(1,4) = -0.7154420d0 igauss(2,4) = 0.639621d0 * twosix**2 else if (gausstyp .eq. 'LJ-2') then 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 else if (gausstyp .eq. 'MM3-2') then ngauss = 2 igauss(1,1) = 2438.886d0 igauss(2,1) = 9.342616d0 igauss(1,2) = -6.197368d0 igauss(2,2) = 1.564486d0 else if (gausstyp .eq. 'MM2-2') then ngauss = 2 igauss(1,1) = 3423.562d0 igauss(2,1) = 9.692821d0 igauss(1,2) = -6.503760d0 igauss(2,2) = 1.585344d0 else if (gausstyp .eq. 'IN-PLACE') then ngauss = 2 igauss(1,1) = 500.0d0 igauss(2,1) = 6.143d0 igauss(1,2) = -18.831d0 igauss(2,2) = 2.209d0 end if end if c c remove zero-sized atoms from the list of vdw sites c nvdw = 0 do i = 1, n if (jvdw(i) .ne. 0) then k = class(i) if (vdwindex .eq. 'TYPE') k = type(i) if (rad(k) .ne. 0.0d0) then nvdw = nvdw + 1 ivdw(nvdw) = i end if end if end do c c turn off the van der Waals potential if it is not used c if (nvdw .eq. 0) use_vdw = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module kvdwpr -- special pair vdw forcefield parameters ## c ## ## c ################################################################# c c c maxnvp maximum number of special pair van der Waals entries c c radpr radius parameter for special van der Waals pairs c epspr well depth parameter for special van der Waals pairs c kvpr string of atom classes for special van der Waals pairs c c module kvdwpr implicit none integer maxnvp real*8, allocatable :: radpr(:) real*8, allocatable :: epspr(:) character*8, allocatable :: kvpr(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module kvdws -- van der Waals term forcefield parameters ## c ## ## c ################################################################## c c c rad van der Waals radius parameter for each atom class c eps van der Waals well depth parameter for each atom class c rad4 van der Waals radius parameter in 1-4 interactions c eps4 van der Waals well depth parameter in 1-4 interactions c reduct van der Waals reduction factor for each atom class c c module kvdws implicit none real*8, allocatable :: rad(:) real*8, allocatable :: eps(:) real*8, allocatable :: rad4(:) real*8, allocatable :: eps4(:) real*8, allocatable :: reduct(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine lattice -- setup periodic boundary conditions ## c ## ## c ################################################################## c c c "lattice" stores the periodic box dimensions and sets angle c values to be used in computing fractional coordinates c c subroutine lattice use bound use boxes use cell use inform use iounit use math implicit none real*8 boxmax real*8 ar1,ar2,ar3 real*8 br1,br2,br3 real*8 cr1,cr2,cr3 c c c use periodic boundary conditions if a cell was defined c boxmax = max(xbox,ybox,zbox) if (boxmax .ne. 0.0d0) use_bounds = .true. c c set unspecified periodic boundary box lengths and angles c if (use_bounds) then if (xbox .eq. 0.0d0) xbox = boxmax if (ybox .eq. 0.0d0) ybox = boxmax if (zbox .eq. 0.0d0) zbox = boxmax if (alpha .eq. 0.0d0) alpha = 90.0d0 if (beta .eq. 0.0d0) beta = 90.0d0 if (gamma .eq. 0.0d0) gamma = 90.0d0 c c determine the general periodic boundary lattice type c orthogonal = .false. monoclinic = .false. triclinic = .false. if (nosymm) then triclinic = .true. else 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 if c c set lattice values for non-prism periodic boundaries c if (octahedron .or. dodecadron) then orthogonal = .false. monoclinic = .false. triclinic = .false. nonprism = .true. end if c c compute and store half box lengths and other lengths c xbox2 = 0.5d0 * xbox ybox2 = 0.5d0 * ybox zbox2 = 0.5d0 * zbox if (octahedron) box34 = 0.75d0 * xbox c c set replicated cell dimensions equal to the unit cell c xcell = xbox ycell = ybox zcell = zbox xcell2 = xbox2 ycell2 = ybox2 zcell2 = zbox2 c c get values needed for fractional coordinate computations c if (triclinic) then alpha_sin = sin(alpha/radian) alpha_cos = cos(alpha/radian) beta_sin = sin(beta/radian) beta_cos = cos(beta/radian) gamma_sin = sin(gamma/radian) gamma_cos = cos(gamma/radian) beta_term = (alpha_cos - beta_cos*gamma_cos) / gamma_sin gamma_term = sqrt(beta_sin**2 - beta_term**2) else if (monoclinic) then alpha_sin = 1.0d0 alpha_cos = 0.0d0 beta_sin = sin(beta/radian) beta_cos = cos(beta/radian) gamma_sin = 1.0d0 gamma_cos = 0.0d0 beta_term = 0.0d0 gamma_term = beta_sin else alpha_sin = 1.0d0 alpha_cos = 0.0d0 beta_sin = 1.0d0 beta_cos = 0.0d0 gamma_sin = 1.0d0 gamma_cos = 0.0d0 beta_term = 0.0d0 gamma_term = 1.0d0 end if c c determine the volume of the parent periodic box c volbox = 0.0d0 if (triclinic) then volbox = (gamma_sin*gamma_term) * xbox * ybox * zbox else if (monoclinic) then volbox = beta_sin * xbox * ybox * zbox else volbox = xbox * ybox * zbox end if c c compute and store real space lattice vectors as rows c ar1 = xbox ar2 = 0.0d0 ar3 = 0.0d0 br1 = ybox * gamma_cos br2 = ybox * gamma_sin br3 = 0.0d0 cr1 = zbox * beta_cos cr2 = zbox * beta_term cr3 = zbox * gamma_term lvec(1,1) = ar1 lvec(1,2) = ar2 lvec(1,3) = ar3 lvec(2,1) = br1 lvec(2,2) = br2 lvec(2,3) = br3 lvec(3,1) = cr1 lvec(3,2) = cr2 lvec(3,3) = cr3 c c compute and store reciprocal lattice vectors as columns c if (volbox .ne. 0.0d0) then recip(1,1) = (br2*cr3 - cr2*br3) / volbox recip(2,1) = (br3*cr1 - cr3*br1) / volbox recip(3,1) = (br1*cr2 - cr1*br2) / volbox recip(1,2) = (cr2*ar3 - ar2*cr3) / volbox recip(2,2) = (cr3*ar1 - ar3*cr1) / volbox recip(3,2) = (cr1*ar2 - ar1*cr2) / volbox recip(1,3) = (ar2*br3 - br2*ar3) / volbox recip(2,3) = (ar3*br1 - br3*ar1) / volbox recip(3,3) = (ar1*br2 - br1*ar2) / volbox end if c c correct volume of non-parallelepiped periodic cells c if (nonprism) volbox = 0.5d0 * volbox return end c c c ################################################### c ## COPYRIGHT (C) 1999 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine lbfgs -- limited memory BFGS optimization ## c ## ## c ############################################################## c c c "lbfgs" implements a limited memory BFGS quasi-newton nonlinear c optimization routine c c literature references: c c J. Nocedal, "Updating Quasi-Newton Matrices with Limited c Storage", Mathematics of Computation, 35, 773-782 (1980) c c D. C. Lui and J. Nocedal, "On the Limited Memory BFGS Method c for Large Scale Optimization", Mathematical Programming, c 45, 503-528 (1989) c c J. Nocedal and S. J. Wright, "Numerical Optimization", c Springer-Verlag, New York, 1999, Section 9.1 c c variables and parameters: c c nvar number of parameters in the objective function c x0 contains starting point upon input, upon return c contains the best point found c minimum during optimization contains best current function c value; returns final best function value c grdmin normal exit if rms gradient gets below this value c ncalls total number of function/gradient evaluations c c required external routines: c c fgvalue function to evaluate function and gradient values c optsave subroutine to write out info about current status c c subroutine lbfgs (nvar,x0,minimum,grdmin,fgvalue,optsave) use inform use iounit use keys use linmin use math use minima use output use scales implicit none integer i,j,k,m integer nvar,next integer msav,muse integer niter,ncalls integer nerr,maxerr real*8 f,f_old,fgvalue real*8 f_move,x_move real*8 g_norm,g_rms real*8 minimum,grdmin real*8 angle,rms,beta real*8 ys,yy,gamma real*8 x0(*) real*8, allocatable :: rho(:) real*8, allocatable :: alpha(:) real*8, allocatable :: x_old(:) real*8, allocatable :: g(:) real*8, allocatable :: g_old(:) real*8, allocatable :: p(:) real*8, allocatable :: q(:) real*8, allocatable :: r(:) real*8, allocatable :: h0(:) real*8, allocatable :: s(:,:) real*8, allocatable :: y(:,:) logical done character*9 blank,status character*20 keyword character*240 record character*240 string external fgvalue,optsave c c c initialize some values to be used below c ncalls = 0 rms = sqrt(dble(nvar)) if (coordtype .eq. 'CARTESIAN') then rms = rms / sqrt(3.0d0) else if (coordtype .eq. 'RIGIDBODY') then rms = rms / sqrt(6.0d0) end if blank = ' ' done = .false. nerr = 0 maxerr = 2 c c perform dynamic allocation of some global arrays c if (.not. allocated(scale)) allocate (scale(nvar)) c c set default values for variable scale factors c if (.not. set_scale) then do i = 1, nvar if (scale(i) .eq. 0.0d0) scale(i) = 1.0d0 end do end if c c set default parameters for the optimization c msav = min(nvar,20) if (fctmin .eq. 0.0d0) fctmin = -100000000.0d0 if (maxiter .eq. 0) maxiter = 1000000 if (nextiter .eq. 0) nextiter = 1 if (iprint .lt. 0) iprint = 1 if (iwrite .lt. 0) iwrite = 1 c c set default parameters for the line search c if (stpmax .eq. 0.0d0) stpmax = 5.0d0 stpmin = 1.0d-16 cappa = 0.9d0 slpmax = 10000.0d0 angmax = 180.0d0 intmax = 5 c c search the keywords for optimization parameters c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:14) .eq. 'LBFGS-VECTORS ') then read (string,*,err=10,end=10) msav msav = max(0,min(msav,nvar)) else if (keyword(1:17) .eq. 'STEEPEST-DESCENT ') then msav = 0 else if (keyword(1:7) .eq. 'FCTMIN ') then read (string,*,err=10,end=10) fctmin else if (keyword(1:8) .eq. 'MAXITER ') then read (string,*,err=10,end=10) maxiter else if (keyword(1:8) .eq. 'STEPMAX ') then read (string,*,err=10,end=10) stpmax else if (keyword(1:8) .eq. 'STEPMIN ') then read (string,*,err=10,end=10) stpmin else if (keyword(1:6) .eq. 'CAPPA ') then read (string,*,err=10,end=10) cappa else if (keyword(1:9) .eq. 'SLOPEMAX ') then read (string,*,err=10,end=10) slpmax else if (keyword(1:7) .eq. 'ANGMAX ') then read (string,*,err=10,end=10) angmax else if (keyword(1:7) .eq. 'INTMAX ') then read (string,*,err=10,end=10) intmax end if 10 continue end do c c print header information about the optimization method c if (iprint .gt. 0) then if (msav .eq. 0) then write (iout,20) 20 format (/,' Steepest Descent Gradient Optimization :') write (iout,30) 30 format (/,' SD Iter F Value G RMS F Move', & ' X Move Angle FG Call Comment') else write (iout,40) 40 format (/,' Limited Memory BFGS Quasi-Newton', & ' Optimization :') write (iout,50) 50 format (/,' QN Iter F Value G RMS F Move', & ' X Move Angle FG Call Comment') end if flush (iout) end if c c perform dynamic allocation of some local arrays c allocate (x_old(nvar)) allocate (g(nvar)) allocate (g_old(nvar)) allocate (p(nvar)) allocate (q(nvar)) allocate (r(nvar)) allocate (h0(nvar)) if (msav .ne. 0) then allocate (rho(msav)) allocate (alpha(msav)) allocate (s(nvar,msav)) allocate (y(nvar,msav)) end if c c evaluate the function and get the initial gradient c niter = nextiter - 1 maxiter = niter + maxiter ncalls = ncalls + 1 f = fgvalue (x0,g) f_old = f m = 0 gamma = 1.0d0 g_norm = 0.0d0 g_rms = 0.0d0 do i = 1, nvar g_norm = g_norm + g(i)*g(i) g_rms = g_rms + (g(i)*scale(i))**2 end do g_norm = sqrt(g_norm) g_rms = sqrt(g_rms) / rms f_move = 0.5d0 * stpmax * g_norm c c print initial information prior to first iteration c if (iprint .gt. 0) then if (f.lt.1.0d8 .and. f.gt.-1.0d7 .and. g_rms.lt.1.0d5) then write (iout,60) niter,f,g_rms,ncalls 60 format (/,i6,f14.4,f11.4,29x,i7) else write (iout,70) niter,f,g_rms,ncalls 70 format (/,i6,d14.4,d11.4,29x,i7) end if flush (iout) end if c c write initial intermediate prior to first iteration c if (iwrite .gt. 0) call optsave (niter,f,x0) c c tests of the various termination criteria c if (niter .ge. maxiter) then status = 'IterLimit' done = .true. end if if (f .le. fctmin) then status = 'SmallFct ' done = .true. end if if (g_rms .le. grdmin) then status = 'SmallGrad' done = .true. end if c c start of a new limited memory BFGS iteration c do while (.not. done) niter = niter + 1 muse = min(niter-1,msav) m = m + 1 if (m .gt. msav) m = 1 c c estimate Hessian diagonal and compute the Hg product c do i = 1, nvar h0(i) = gamma q(i) = g(i) end do k = m do j = 1, muse k = k - 1 if (k .eq. 0) k = msav alpha(k) = 0.0d0 do i = 1, nvar alpha(k) = alpha(k) + s(i,k)*q(i) end do alpha(k) = alpha(k) * rho(k) do i = 1, nvar q(i) = q(i) - alpha(k)*y(i,k) end do end do do i = 1, nvar r(i) = h0(i) * q(i) end do do j = 1, muse beta = 0.0d0 do i = 1, nvar beta = beta + y(i,k)*r(i) end do beta = beta * rho(k) do i = 1, nvar r(i) = r(i) + s(i,k)*(alpha(k)-beta) end do k = k + 1 if (k .gt. msav) k = 1 end do c c set search direction and store current point and gradient c do i = 1, nvar p(i) = -r(i) x_old(i) = x0(i) g_old(i) = g(i) end do c c perform line search along the new conjugate direction c status = blank call search (nvar,f,g,x0,p,f_move,angle,ncalls,fgvalue,status) c c update variables based on results of this iteration c if (msav .ne. 0) then ys = 0.0d0 yy = 0.0d0 do i = 1, nvar s(i,m) = x0(i) - x_old(i) y(i,m) = g(i) - g_old(i) ys = ys + y(i,m)*s(i,m) yy = yy + y(i,m)*y(i,m) end do gamma = abs(ys/yy) rho(m) = 1.0d0 / ys end if c c get the sizes of the moves made during this iteration c f_move = f_old - f f_old = f x_move = 0.0d0 do i = 1, nvar x_move = x_move + ((x0(i)-x_old(i))/scale(i))**2 end do x_move = sqrt(x_move) / rms if (coordtype .eq. 'INTERNAL') then x_move = radian * x_move end if c c compute the rms gradient per optimization parameter c g_rms = 0.0d0 do i = 1, nvar g_rms = g_rms + (g(i)*scale(i))**2 end do g_rms = sqrt(g_rms) / rms c c test for error due to line search problems c if (status.eq.'BadIntpln' .or. status.eq.'IntplnErr') then nerr = nerr + 1 if (nerr .ge. maxerr) done = .true. else nerr = 0 end if c c test for too many total iterations c if (niter .ge. maxiter) then status = 'IterLimit' done = .true. end if c c test the normal termination criteria c if (f .le. fctmin) then status = 'SmallFct ' done = .true. end if if (g_rms .le. grdmin) then status = 'SmallGrad' done = .true. end if c c print intermediate results for the current iteration c if (iprint .gt. 0) then if (done .or. mod(niter,iprint).eq.0) then if (f.lt.1.0d8 .and. f.gt.-1.0d7 .and. & g_rms.lt.1.0d5 .and. f_move.lt.1.0d6 .and. & f_move.gt.-1.0d5) then write (iout,80) niter,f,g_rms,f_move,x_move, & angle,ncalls,status 80 format (i6,f14.4,f11.4,f12.4,f9.4,f8.2,i7,3x,a9) else write (iout,90) niter,f,g_rms,f_move,x_move, & angle,ncalls,status 90 format (i6,d14.4,d11.4,d12.4,f9.4,f8.2,i7,3x,a9) end if end if flush (iout) end if c c write intermediate results for the current iteration c if (iwrite .gt. 0) then if (done .or. mod(niter,iwrite).eq.0) then call optsave (niter,f,x0) end if end if end do c c perform deallocation of some local arrays c deallocate (x_old) deallocate (g) deallocate (g_old) deallocate (p) deallocate (q) deallocate (r) deallocate (h0) if (msav .ne. 0) then deallocate (rho) deallocate (alpha) deallocate (s) deallocate (y) end if c c set final value of the objective function c minimum = f if (iprint .gt. 0) then if (status.eq.'SmallGrad' .or. status.eq.'SmallFct ') then write (iout,100) status 100 format (/,' LBFGS -- Normal Termination due to ',a9) else write (iout,110) status 110 format (/,' LBFGS -- Incomplete Convergence due to ',a9) end if flush (iout) 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 light -- method of lights pair neighbors indices ## c ## ## c ################################################################# c c c nlight total number of sites for method of lights calculation c kbx low index of neighbors of each site in the x-sorted list c kby low index of neighbors of each site in the y-sorted list c kbz low index of neighbors of each site in the z-sorted list c kex high index of neighbors of each site in the x-sorted list c key high index of neighbors of each site in the y-sorted list c kez high index of neighbors of each site in the z-sorted list c locx maps the x-sorted list into original interaction list c locy maps the y-sorted list into original interaction list c locz maps the z-sorted list into original interaction list c rgx maps the original interaction list into x-sorted list c rgy maps the original interaction list into y-sorted list c rgz maps the original interaction list into z-sorted list c c module light implicit none integer nlight integer, allocatable :: kbx(:) integer, allocatable :: kby(:) integer, allocatable :: kbz(:) integer, allocatable :: kex(:) integer, allocatable :: key(:) integer, allocatable :: kez(:) integer, allocatable :: locx(:) integer, allocatable :: locy(:) integer, allocatable :: locz(:) integer, allocatable :: rgx(:) integer, allocatable :: rgy(:) integer, allocatable :: rgz(:) save end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine lights -- get neighbors via method of lights ## c ## ## c ################################################################# c c c "lights" computes the set of nearest neighbor interactions c using the method of lights algorithm c c note this routine can include each pair only once via setting c of the negative x-coordinate boundaries, or it can optionally c include each pair in both directions, ie, both (A,B) and (B,A); c inclusion of one or both directions is controlled by "unique" c c literature references: c c F. Sullivan, R. D. Mountain and J. O'Connell, "Molecular c Dynamics on Vector Computers", Journal of Computational c Physics, 61, 138-153 (1985) c c W. Dzwinel, M. Bargiel, J. Kitowski and J. Moscinski, "Linked c Lists and the Method of Lights in Molecular Dynamics Simulation- c Search for the Best Method of Forces Evaluation in Sequential c MD Codes", Molecular Simulation, 4, 229-239 (1989) c c subroutine lights (cutoff,nsite,xsort,ysort,zsort,unique) use bound use boxes use cell use iounit use light implicit none integer i,j,k integer nsite integer extent real*8 cutoff,term,box real*8 xcut,ycut,zcut real*8 xmove,ymove,zmove real*8 xsort(*) real*8 ysort(*) real*8 zsort(*) real*8, allocatable :: xfrac(:) real*8, allocatable :: yfrac(:) real*8, allocatable :: zfrac(:) logical unique c c c check that maximum number of replicates is not exceeded c if (use_replica) then if (xcell2.gt.xbox .or. ycell2.gt.ybox & .or. zcell2.gt.zbox) then write (iout,10) 10 format (/,' LIGHTS -- Number of Replicas is Too', & ' Large for Method of Lights') call fatal end if end if c c non-prism periodic cell is not handled at present c if (use_bounds) then if (nonprism) then write (iout,20) 20 format (/,' LIGHTS -- Non-Prism Cell is not', & ' Supported by Method of Lights') call fatal end if end if c c set the light width based on input distance cutoff c xcut = cutoff ycut = cutoff zcut = cutoff if (use_bounds) then if (monoclinic) then xcut = xcut / beta_sin zcut = zcut / beta_sin else if (triclinic) then term = xbox * ybox * zbox / volbox xcut = xcut * term * alpha_sin ycut = ycut * term * beta_sin zcut = zcut * term * gamma_sin end if end if c c perform dynamic allocation of some local arrays c if (use_bounds) then allocate (xfrac(nsite)) allocate (yfrac(nsite)) allocate (zfrac(nsite)) end if c c find fractional coordinates for the unit cell atoms c if (use_bounds) then if (orthogonal) then do i = 1, nsite zfrac(i) = zsort(i) yfrac(i) = ysort(i) xfrac(i) = xsort(i) end do else if (monoclinic) then do i = 1, nsite zfrac(i) = zsort(i) / beta_sin yfrac(i) = ysort(i) xfrac(i) = xsort(i) - zfrac(i)*beta_cos end do else if (triclinic) then do i = 1, nsite zfrac(i) = zsort(i) / gamma_term yfrac(i) = (ysort(i) - zfrac(i)*beta_term) / gamma_sin xfrac(i) = xsort(i) - yfrac(i)*gamma_cos & - zfrac(i)*beta_cos end do end if end if c c use images to move coordinates into periodic cell c if (use_bounds) then do i = 1, nsite xsort(i) = xfrac(i) ysort(i) = yfrac(i) zsort(i) = zfrac(i) do while (abs(xsort(i)) .gt. xcell2) xsort(i) = xsort(i) - sign(xcell,xsort(i)) end do do while (abs(ysort(i)) .gt. ycell2) ysort(i) = ysort(i) - sign(ycell,ysort(i)) end do do while (abs(zsort(i)) .gt. zcell2) zsort(i) = zsort(i) - sign(zcell,zsort(i)) end do end do end if c c generate the replica coordinates for the sort arrays c if (use_replica) then k = nsite do j = 2, ncell xmove = icell(1,j) * xbox ymove = icell(2,j) * ybox zmove = icell(3,j) * zbox do i = 1, nsite k = k + 1 xsort(k) = xfrac(i) + xmove ysort(k) = yfrac(i) + ymove zsort(k) = zfrac(i) + zmove do while (abs(xsort(k)) .gt. xcell2) xsort(k) = xsort(k) - sign(xcell,xsort(k)) end do do while (abs(ysort(k)) .gt. ycell2) ysort(k) = ysort(k) - sign(ycell,ysort(k)) end do do while (abs(zsort(k)) .gt. zcell2) zsort(k) = zsort(k) - sign(zcell,zsort(k)) end do end do end do end if c c perform deallocation of some local arrays c if (use_bounds) then deallocate (xfrac) deallocate (yfrac) deallocate (zfrac) end if c c perform dynamic allocation of some global arrays c nlight = ncell * nsite extent = 0 if (allocated(rgx)) extent = size(rgx) if (extent .lt. nlight) then if (allocated(kbx)) deallocate (kbx) if (allocated(kby)) deallocate (kby) if (allocated(kbz)) deallocate (kbz) if (allocated(kex)) deallocate (kex) if (allocated(key)) deallocate (key) if (allocated(kez)) deallocate (kez) if (allocated(locx)) deallocate (locx) if (allocated(locy)) deallocate (locy) if (allocated(locz)) deallocate (locz) if (allocated(rgx)) deallocate (rgx) if (allocated(rgy)) deallocate (rgy) if (allocated(rgz)) deallocate (rgz) allocate (kbx(nsite)) allocate (kby(nsite)) allocate (kbz(nsite)) allocate (kex(nsite)) allocate (key(nsite)) allocate (kez(nsite)) allocate (locx(nlight)) allocate (locy(nlight)) allocate (locz(nlight)) allocate (rgx(nlight)) allocate (rgy(nlight)) allocate (rgz(nlight)) end if c c sort the coordinate components into ascending order c call sort2 (nlight,xsort,locx) call sort2 (nlight,ysort,locy) call sort2 (nlight,zsort,locz) c c use of replicates requires secondary sorting along x-axis c if (use_replica) then j = 1 do i = 1, nlight-1 if (xsort(i+1) .ne. xsort(i)) then call sort5 (i-j+1,locx(j),nsite) j = i + 1 end if end do call sort5 (nlight-j+1,locx(j),nsite) end if c c index the position of each atom in the sorted coordinates c do i = 1, nlight rgx(locx(i)) = i rgy(locy(i)) = i rgz(locz(i)) = i end do c c find the negative x-coordinate boundary for each atom c if (unique) then do i = nlight, 1, -1 k = locx(i) if (k .le. nsite) then kbx(k) = i end if end do else j = nlight box = 0.0d0 do i = nlight, 1, -1 k = locx(i) do while (xsort(i)-xsort(j)+box .le. xcut) if (j .eq. 1) then if (use_bounds) then j = nlight + 1 box = xcell end if end if j = j - 1 if (j .lt. 1) goto 30 end do 30 continue j = j + 1 if (j .gt. nlight) then j = 1 box = 0.0d0 end if kbx(k) = j end do end if c c find the positive x-coordinate boundary for each atom c j = 1 box = 0.0d0 do i = 1, nlight k = locx(i) if (k .le. nsite) then do while (xsort(j)-xsort(i)+box .lt. xcut) if (j .eq. nlight) then if (use_bounds) then j = 0 box = xcell end if end if j = j + 1 if (j .gt. nlight) goto 40 end do 40 continue j = j - 1 if (j .lt. 1) then j = nlight box = 0.0d0 end if kex(k) = j end if end do c c find the negative y-coordinate boundary for each atom c j = nlight box = 0.0d0 do i = nlight, 1, -1 k = locy(i) if (k .le. nsite) then do while (ysort(i)-ysort(j)+box .le. ycut) if (j .eq. 1) then if (use_bounds) then j = nlight + 1 box = ycell end if end if j = j - 1 if (j .lt. 1) goto 50 end do 50 continue j = j + 1 if (j .gt. nlight) then j = 1 box = 0.0d0 end if kby(k) = j end if end do c c find the positive y-coordinate boundary for each atom c j = 1 box = 0.0d0 do i = 1, nlight k = locy(i) if (k .le. nsite) then do while (ysort(j)-ysort(i)+box .lt. ycut) if (j .eq. nlight) then if (use_bounds) then j = 0 box = ycell end if end if j = j + 1 if (j .gt. nlight) goto 60 end do 60 continue j = j - 1 if (j .lt. 1) then j = nlight box = 0.0d0 end if key(k) = j end if end do c c find the negative z-coordinate boundary for each atom c j = nlight box = 0.0d0 do i = nlight, 1, -1 k = locz(i) if (k .le. nsite) then do while (zsort(i)-zsort(j)+box .le. zcut) if (j .eq. 1) then if (use_bounds) then j = nlight + 1 box = zcell end if end if j = j - 1 if (j .lt. 1) goto 70 end do 70 continue j = j + 1 if (j .gt. nlight) then j = 1 box = 0.0d0 end if kbz(k) = j end if end do c c find the positive z-coordinate boundary for each atom c j = 1 box = 0.0d0 do i = 1, nlight k = locz(i) if (k .le. nsite) then do while (zsort(j)-zsort(i)+box .lt. zcut) if (j .eq. nlight) then if (use_bounds) then j = 0 box = zcell end if end if j = j + 1 if (j .gt. nlight) goto 80 end do 80 continue j = j - 1 if (j .lt. 1) then j = nlight box = 0.0d0 end if kez(k) = j end if 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 limits -- interaction taper & cutoff distances ## c ## ## c ############################################################### c c c vdwcut cutoff distance for van der Waals interactions c repcut cutoff distance for Pauli repulsion interactions c dispcut cutoff distance for dispersion interactions c chgcut cutoff distance for charge-charge interactions c dplcut cutoff distance for dipole-dipole interactions c mpolecut cutoff distance for atomic multipole interactions c ctrncut cutoff distance for charge transfer interactions c vdwtaper distance at which van der Waals switching begins c reptaper distance at which Pauli repulsion switching begins c disptaper distance at which dispersion switching begins c chgtaper distance at which charge-charge switching begins c dpltaper distance at which dipole-dipole switching begins c mpoletaper distance at which atomic multipole switching begins c ctrntaper distance at which charge transfer switching begins c ewaldcut cutoff distance for real space Ewald electrostatics c dewaldcut cutoff distance for real space Ewald dispersion c usolvcut cutoff distance for dipole solver preconditioner c use_ewald logical flag governing use of electrostatic Ewald c use_dewald logical flag governing use of dispersion Ewald c use_lights logical flag governing use of method of lights c use_list logical flag governing use of any neighbor lists c use_vlist logical flag governing use of van der Waals list c use_dlist logical flag governing use of dispersion list c use_clist logical flag governing use of charge list c use_mlist logical flag governing use of multipole list c use_ulist logical flag governing use of preconditioner list c c module limits implicit none real*8 vdwcut,repcut real*8 dispcut,chgcut real*8 dplcut,mpolecut real*8 ctrncut real*8 vdwtaper,reptaper real*8 disptaper,chgtaper real*8 dpltaper,mpoletaper real*8 ctrntaper real*8 ewaldcut,dewaldcut real*8 usolvcut logical use_ewald,use_dewald logical use_lights,use_list logical use_vlist,use_dlist logical use_clist,use_mlist logical use_ulist save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module linmin -- line search minimization parameters ## c ## ## c ############################################################## c c c intmax maximum number of interpolations during line search c stpmin minimum step length in current line search direction c stpmax maximum step length in current line search direction c cappa stringency of line search (0=tight < cappa < 1=loose) c slpmax projected gradient above which stepsize is reduced c angmax maximum angle between search direction and -gradient c c module linmin implicit none integer intmax real*8 stpmin real*8 stpmax real*8 cappa real*8 slpmax real*8 angmax save end c c c ################################################### c ## COPYRIGHT (C) 2020 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine lusolve -- LU factorization as linear solver ## c ## ## c ################################################################# c c c "lusolve" uses a LU factorization with partial pivoting to solve c the linear system Ax = b, returning "x" in "b"; "A" is the upper c triangle of a symmetric matrix and the diagonal stored by rows c c literature reference: c c W. H. Press, B. P. Flannery, S. A. Teukolsky and W. T. Vetterling, c "Numerical Recipes: The Art of Scientific Computing, 2nd Edition", c Cambridge University Press, 1992, Section 2.3 c c subroutine lusolve (nvar,a,b) use iounit implicit none integer i,j,k,m integer nvar,imax integer, allocatable :: indx(:) real*8 amax,sum real*8 eps,temp real*8 a(*) real*8 b(*) real*8, allocatable :: vv(:) real*8, allocatable :: af(:,:) c c c perform dynamic allocation of some local arrays c allocate (indx(nvar)) allocate (vv(nvar)) allocate (af(nvar,nvar)) c c copy input upper triangle into the full matrix c k = 0 do i = 1, nvar do j = i, nvar k = k + 1 af(j,i) = a(k) af(i,j) = af(j,i) end do end do c c perform LU factorization of the input matrix c do i = 1, nvar amax = 0.0d0 do j = 1, nvar if (abs(af(i,j)) .gt. amax) amax = abs(af(i,j)) end do if (amax .eq. 0.0d0) then write (iout,10) 10 format (/,' LUSOLVE -- Input Matrix Singular during', & ' LU Factorization') call fatal end if vv(i) = 1.0d0 / amax end do eps = 1.0d-10 do j = 1, nvar do i = 1, j-1 sum = af(i,j) do k = 1, i-1 sum = sum - af(i,k)*af(k,j) end do af(i,j) = sum end do amax = 0.0d0 do i = j, nvar sum = af(i,j) do k = 1, j-1 sum = sum - af(i,k)*af(k,j) end do af(i,j) = sum temp = vv(i) * abs(sum) if (temp .ge. amax) then imax = i amax = temp end if end do if (j .ne. imax) then do k = 1, nvar temp = af(imax,k) af(imax,k) = af(j,k) af(j,k) = temp end do vv(imax) = vv(j) end if indx(j) = imax if (af(j,j) .eq. 0.0d0) af(j,j) = eps if (j .ne. nvar) then temp = 1.0d0 / af(j,j) do i = j+1, nvar af(i,j) = af(i,j) * temp end do end if end do c c use factored matrix to solve the linear equations c m = 0 do i = 1, nvar k = indx(i) sum = b(k) b(k) = b(i) if (m .ne. 0) then do j = m, i-1 sum = sum - af(i,j)*b(j) end do else if (sum .ne. 0.0d0) then m = i end if b(i) = sum end do do i = nvar, 1, -1 sum = b(i) do j = i+1, nvar sum = sum - af(i,j)*b(j) end do b(i) = sum / af(i,i) end do c c perform deallocation of some local arrays c deallocate (indx) deallocate (vv) deallocate (af) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine makeint -- convert Cartesian to internal ## c ## ## c ############################################################# c c c "makeint" converts Cartesian to internal coordinates where c selection of internal coordinates is controlled by "mode" c c mode = 0 automatic internal coordinates c mode = 1 manual selection of coordinates c mode = 2 use existing structure as a template c mode = 3 use dihedral angles in all cases c c subroutine makeint (mode) use atoms use couple use iounit use math use zclose use zcoord implicit none integer i,j integer i1,i2,i3,i4,i5 integer adjacent,trial integer mode,next integer, allocatable :: iz0(:) integer, allocatable :: iz1(:) real*8 geometry,sign logical more character*1 answer character*1 default character*8 phrase character*240 record c c c perform dynamic allocation of some local arrays c allocate (iz0(0:n)) allocate (iz1(n)) c c zero out local values used for the defining atoms c i1 = 0 i2 = 0 i3 = 0 i4 = 0 i5 = 0 iz0(0) = 0 do i = 1, n iz0(i) = 0 iz1(i) = 0 end do c c zero out the coordinates, defining atoms and closures c do i = 1, n zbond(i) = 0.0d0 zang(i) = 0.0d0 ztors(i) = 0.0d0 end do if (mode .ne. 2) then do i = 1, n do j = 1, 4 iz(j,i) = 0 end do end do nadd = 0 ndel = 0 end if c c first, decide which of the atoms to define next c do i = 1, n if (mode .eq. 1) then trial = i1 + 1 10 continue write (iout,20) trial 20 format (/,' Atom Number to be Defined [',i5,'] : ',$) read (input,30,err=10) i1 30 format (i10) if (i1 .eq. 0) i1 = trial if (iz0(i1) .ne. 0) then write (iout,40) 40 format (/,' Already Defined that Atom; Choose Another') if (i1 .eq. trial) trial = trial + 1 goto 10 end if else i1 = i end if c c define the bond length for the current atom c if (i .ge. 2) then if (mode .eq. 2) then i2 = iz(1,i1) else i2 = adjacent (i1,0,mode,more,iz0,iz1) if (i2 .eq. 0) then write (iout,50) i1 50 format (/,' MAKEINT -- Connectivity Error', & ' in defining Atom',i6) call fatal end if end if zbond(i1) = geometry (i1,i2,0,0) end if c c define the bond angle for the current atom c if (i .ge. 3) then if (mode .eq. 2) then i3 = iz(2,i1) else i3 = adjacent (i2,i1,mode,more,iz0,iz1) if (i3 .eq. 0) then write (iout,60) i1 60 format (/,' MAKEINT -- Connectivity Error', & ' in defining Atom',i6) call fatal end if end if zang(i1) = geometry (i1,i2,i3,0) end if c c decide whether to use a dihedral or second bond angle; c then find the value of the angle c if (i .ge. 4) then if (mode .eq. 3) then answer = 'D' else if (mode .eq. 2) then if (iz(4,i1) .eq. 0) then answer = 'D' else answer = 'B' end if else if (mode .eq. 1) then if (more) then phrase = 'D or [B]' default = 'B' else phrase = '[D] or B' default = 'D' end if write (iout,70) phrase 70 format (/,' Specify with Dihedral Angle or Second', & ' Bond Angle (',a8,') : ',$) read (input,80) record 80 format (a240) next = 1 call gettext (record,answer,next) call upcase (answer) if (answer.ne.'B' .and. answer.ne.'D') answer = default else if (mode .eq. 0) then if (more) then answer = 'B' else answer = 'D' end if end if if (answer .eq. 'B') then if (mode .eq. 2) then i4 = iz(3,i1) else i4 = adjacent (i2,i3,mode,more,iz0,iz1) if (i4 .eq. 0) then write (iout,90) i1 90 format (/,' MAKEINT -- Connectivity Error', & ' in defining Atom',i6) call fatal end if end if ztors(i1) = geometry (i1,i2,i4,0) i5 = 1 sign = geometry (i1,i2,i3,i4) if (sign .gt. 0.0d0) i5 = -1 else if (answer .eq. 'D') then if (mode .eq. 2) then i4 = iz(3,i1) else i4 = adjacent (i3,i2,mode,more,iz0,iz1) if (i4 .eq. 0) then write (iout,100) i1 100 format (/,' MAKEINT -- Connectivity Error', & ' in defining Atom',i6) call fatal end if end if i5 = 0 ztors(i1) = geometry (i1,i2,i3,i4) end if end if c c transfer defining atoms to permanent array; c mark the current atom as finished c iz(1,i1) = iz0(i2) iz(2,i1) = iz0(i3) iz(3,i1) = iz0(i4) iz(4,i1) = i5 iz0(i1) = i iz1(i1) = i2 end do c c add any bonds needed to make ring closures c nadd = 0 do i = 1, n do j = 1, n12(i) if (iz0(i) .lt. iz0(i12(j,i)) .and. & iz1(i12(j,i)) .ne. i) then nadd = nadd + 1 iadd(1,nadd) = iz0(i) iadd(2,nadd) = iz0(i12(j,i)) end if end do end do c c perform deallocation of some local arrays c deallocate (iz0) deallocate (iz1) return end c c c ############################################################## c ## ## c ## function adjacent -- atom adjacent to specified atom ## c ## ## c ############################################################## c c c "adjacent" finds an atom connected to atom "i1" other than c atom "i2"; if no such atom exists, then the closest atom c in space is returned c c variables and parameters: c c mode whether "makeint" is in manual mode, automatic, etc. c more returned true if there is more than one previously c defined atom other than "i2" which is directly c connected (adjacent) to atom "i1" c iz0 line number of the Z-matrix on which an atom is c defined, 0 if not yet defined c iz1 line number of the Z-matrix on which the atom used c defining the bond length to a given atom is defined c c function adjacent (i1,i2,mode,more,iz0,iz1) use atoms use couple use inform use iounit use sizes use zclose implicit none integer i,j,k,i1,i2 integer nc,adjacent,mode integer ic(maxval) integer iz0(0:*) integer iz1(*) real*8 dist2,short logical more c c c get a list of eligible atoms bonded to the atom of interest c nc = 0 more = .false. do j = 1, n12(i1) i = i12(j,i1) if (iz0(i).ne.0 .and. i.ne.i2) then if (i2 .eq. 0) then nc = nc + 1 ic(nc) = i else if (iz1(i).eq.i1 .or. iz1(i1).eq.i) then nc = nc + 1 ic(nc) = i end if end if end if end do if (nc .gt. 1) more = .true. c c if no bonded atom is eligible, use the nearest neighbor c if (nc .eq. 0) then adjacent = 0 if (mode .eq. 1) then write (iout,10) i1 10 format (/,' ADJACENT -- Atom',i6,' not Attached', & ' to any Prior Atom') else short = 100000000.0d0 do i = 1, n if (iz0(i).ne.0 .and. i.ne.i1 .and. i.ne.i2) then dist2 = (x(i)-x(i1))**2 + (y(i)-y(i1))**2 & + (z(i)-z(i1))**2 if (dist2 .lt. short) then short = dist2 adjacent = i end if end if end do if (i2 .eq. 0) then ndel = ndel + 1 idel(1,ndel) = adjacent idel(2,ndel) = i1 if (debug) then write (iout,20) i1 20 format (/,' ADJACENT -- Atom',i6,' not Attached', & ' to any Prior Atom') end if end if end if c c for automatic mode, always use the first eligible bonded atom c else if (mode .eq. 0) then adjacent = ic(1) c c for torsion mode, use an adjacent atom bonded to undefined atoms c else if (mode .eq. 3) then adjacent = ic(1) do k = 1, nc do j = 1, n12(ic(k)) i = i12(j,ic(k)) if (iz0(i).ne.0 .and. i.ne.i1) then adjacent = ic(k) goto 30 end if end do end do 30 continue c c if only one directly bonded atom is eligible, then use it c else if (nc .eq. 1) then adjacent = ic(1) if (mode.eq.1 .or. debug) then write (iout,40) ic(1) 40 format (/,' ADJACENT -- Atom',i6,' is the only', & ' Connected Atom') end if c c ask the user which eligible bonded atom to use as adjacent c else 50 continue if (nc .eq. 2) then write (iout,60) (ic(j),j=1,nc) 60 format (' Choose a Connected Atom (',2i6,') : ',$) else if (nc .eq. 3) then write (iout,70) (ic(j),j=1,nc) 70 format (' Choose a Connected Atom (',3i6,') : ',$) else if (nc .eq. 4) then write (iout,80) (ic(j),j=1,nc) 80 format (' Choose a Connected Atom (',4i6,') : ',$) else if (nc .eq. 5) then write (iout,90) (ic(j),j=1,nc) 90 format (' Choose a Connected Atom (',5i6,') : ',$) else if (nc .eq. 6) then write (iout,100) (ic(j),j=1,nc) 100 format (' Choose a Connected Atom (',6i6,') : ',$) else if (nc .eq. 7) then write (iout,110) (ic(j),j=1,nc) 110 format (' Choose a Connected Atom (',7i6,') : ',$) else if (nc .eq. 8) then write (iout,120) (ic(j),j=1,nc) 120 format (' Choose a Connected Atom (',8i6,') : ',$) end if read (input,130,err=50) adjacent 130 format (i10) if (adjacent .eq. 0) then adjacent = ic(1) else do j = 1, nc if (ic(j) .eq. adjacent) goto 140 end do goto 50 140 continue end if end if return end c c c ################################################### c ## COPYRIGHT (C) 1996 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine makeref -- copy structure to reference area ## c ## ## c ################################################################ c c c "makeref" copies the information contained in the "xyz" file c of the current structure into corresponding reference areas c c subroutine makeref (iref) use atomid use atoms use boxes use couple use files use refer use titles implicit none integer i,j,iref logical first save first data first / .true. / c c c perform dynamic allocation of some global arrays c if (first) then first = .false. if (.not. allocated(reftyp)) allocate (reftyp(maxatm,maxref)) if (.not. allocated(n12ref)) allocate (n12ref(maxatm,maxref)) if (.not. allocated(i12ref)) & allocate (i12ref(maxval,maxatm,maxref)) if (.not. allocated(xref)) allocate (xref(maxatm,maxref)) if (.not. allocated(yref)) allocate (yref(maxatm,maxref)) if (.not. allocated(zref)) allocate (zref(maxatm,maxref)) if (.not. allocated(refnam)) allocate (refnam(maxatm,maxref)) end if c c copy the filename and title line for the structure c reffile(iref) = filename refleng(iref) = leng reftitle(iref) = title refltitle(iref) = ltitle c c copy the coordinates, type and connectivity of each atom c nref(iref) = n do i = 1, n refnam(i,iref) = name(i) xref(i,iref) = x(i) yref(i,iref) = y(i) zref(i,iref) = z(i) reftyp(i,iref) = type(i) n12ref(i,iref) = n12(i) do j = 1, n12(i) i12ref(j,i,iref) = i12(j,i) end do end do c c copy any unit cell parameters from the coordinates file c xboxref(iref) = xbox yboxref(iref) = ybox zboxref(iref) = zbox alpharef(iref) = alpha betaref(iref) = beta gammaref(iref) = gamma return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine makexyz -- convert internal to Cartesian ## c ## ## c ############################################################# c c c "makexyz" generates a complete set of Cartesian coordinates c for a full structure from the internal coordinate values c c subroutine makexyz use atoms use zcoord implicit none integer i,chiral integer ia,ib,ic real*8 bond real*8 angle1 real*8 angle2 c c c loop over each atom in turn, finding its coordinates c do i = 1, n ia = iz(1,i) ib = iz(2,i) ic = iz(3,i) chiral = iz(4,i) bond = zbond(i) angle1 = zang(i) angle2 = ztors(i) call xyzatm (i,ia,bond,ib,angle1,ic,angle2,chiral) 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 math -- mathematical and geometrical constants ## c ## ## c ############################################################### c c c pi numerical value of the geometric constant Pi c twopi numerical value of two times Pi c rootpi numerical value of the square root of Pi c radian conversion factor from radians to degrees c elog numerical value of the natural logarithm base c logten numerical value of the natural log of ten c twosix numerical value of the sixth root of two c root2 numerical value of the square root of two c root3 numerical value of the square root of three c third numerical value of one-third (1/3) c third2 numerical value of two-thirds (2/3) c c module math implicit none real*8 pi,twopi,rootpi real*8 radian,elog,logten real*8 twosix,root2,root3 real*8 third,third2 parameter (pi=3.141592653589793238d0) parameter (twopi=6.283185307179586476d0) parameter (rootpi=1.772453850905516027d0) parameter (radian=57.29577951308232088d0) parameter (elog=2.718281828459045235d0) parameter (logten=2.302585092994045684d0) parameter (twosix=1.122462048309372981d0) parameter (root2=1.414213562373095049d0) parameter (root3=1.732050807568877294d0) parameter (third=0.333333333333333333d0) parameter (third2=0.666666666666666667d0) save end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## function maxwell -- Maxwell-Boltzmann distribution value ## c ## ## c ################################################################## c c c "maxwell" returns a speed in Angstroms/picosecond randomly c selected from a 3-D Maxwell-Boltzmann distribution for the c specified particle mass and system temperature c c literature reference: c c P. W. Atkins, "Physical Chemistry, 4th Edition", W. H. Freeman, c New York, 1990; see section 24.2 for general discussion c c function maxwell (mass,temper) use units implicit none real*8 maxwell real*8 mass,temper real*8 rho,beta real*8 random,erfinv real*8 xspeed,yspeed real*8 zspeed external random,erfinv c c c initialize the speed magnitude of the particle to zero c maxwell = 0.0d0 c c set normalization factor for cumulative velocity distribution c if (mass.gt.0.0d0 .and. temper.gt.0.0d0) then beta = sqrt(mass / (2.0d0*boltzmann*temper)) c c pick a randomly distributed velocity along each of three axes c rho = random () xspeed = erfinv(rho) / beta rho = random () yspeed = erfinv(rho) / beta rho = random () zspeed = erfinv(rho) / beta c c set the final value of the particle speed in 3-dimensions c maxwell = sqrt(xspeed**2 + yspeed**2 + zspeed**2) 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 mdinit -- initialize a dynamics trajectory ## c ## ## c ############################################################### c c c "mdinit" initializes the velocities and accelerations c for a molecular dynamics trajectory, including restarts c c subroutine mdinit (dt) use atomid use atoms use bath use bound use couple use extfld use files use freeze use group use inform use iounit use keys use mdstuf use molcul use moldyn use mpole use output use potent use rgddyn use rigid use stodyn use units use usage implicit none integer i,j,istep integer idyn,lext integer size,next integer freeunit integer trimtext real*8 dt,eps real*8 e,ekt,qterm real*8 maxwell,speed real*8 amass,gmass real*8 vec(3) real*8, allocatable :: derivs(:,:) logical exist character*7 ext character*20 keyword character*240 dynfile character*240 record character*240 string c c c set default parameters for the dynamics trajectory c integrate = 'BEEMAN' bmnmix = 8 arespa = 0.00025d0 nfree = 0 irest = 100 velsave = .false. frcsave = .false. uindsave = .false. friction = 91.0d0 use_sdarea = .false. iprint = 100 c c set default values for temperature and pressure control c thermostat = 'BUSSI' tautemp = -1.0d0 collide = 0.1d0 do i = 1, maxnose vnh(i) = 0.0d0 qnh(i) = 0.0d0 gnh(i) = 0.0d0 end do barostat = 'BERENDSEN' anisotrop = .false. taupres = -1.0d0 compress = 0.000046d0 vbar = 0.0d0 qbar = 0.0d0 gbar = 0.0d0 eta = 0.0d0 voltrial = 25 volmove = 100.0d0 volscale = 'MOLECULAR' c c check for keywords containing any altered parameters c 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) else if (keyword(1:14) .eq. 'BEEMAN-MIXING ') then read (string,*,err=10,end=10) bmnmix else if (keyword(1:12) .eq. 'RESPA-INNER ') then read (string,*,err=10,end=10) arespa arespa = 0.001d0 * arespa else if (keyword(1:16) .eq. 'DEGREES-FREEDOM ') then read (string,*,err=10,end=10) nfree else if (keyword(1:15) .eq. 'REMOVE-INERTIA ') then read (string,*,err=10,end=10) irest else if (keyword(1:14) .eq. 'SAVE-VELOCITY ') then velsave = .true. else if (keyword(1:11) .eq. 'SAVE-FORCE ') then frcsave = .true. else if (keyword(1:13) .eq. 'SAVE-INDUCED ') then uindsave = .true. else if (keyword(1:9) .eq. 'FRICTION ') then read (string,*,err=10,end=10) friction else if (keyword(1:17) .eq. 'FRICTION-SCALING ') then use_sdarea = .true. else if (keyword(1:11) .eq. 'THERMOSTAT ') then call getword (record,thermostat,next) call upcase (thermostat) else if (keyword(1:16) .eq. 'TAU-TEMPERATURE ') then read (string,*,err=10,end=10) tautemp else if (keyword(1:10) .eq. 'COLLISION ') then read (string,*,err=10,end=10) collide else if (keyword(1:9) .eq. 'BAROSTAT ') then call getword (record,barostat,next) call upcase (barostat) else if (keyword(1:15) .eq. 'ANISO-PRESSURE ') then anisotrop = .true. else if (keyword(1:13) .eq. 'TAU-PRESSURE ') then read (string,*,err=10,end=10) taupres else if (keyword(1:9) .eq. 'COMPRESS ') then read (string,*,err=10,end=10) compress else if (keyword(1:13) .eq. 'VOLUME-TRIAL ') then read (string,*,err=10,end=10) voltrial else if (keyword(1:12) .eq. 'VOLUME-MOVE ') then read (string,*,err=10,end=10) volmove else if (keyword(1:13) .eq. 'VOLUME-SCALE ') then call getword (record,volscale,next) call upcase (volscale) else if (keyword(1:9) .eq. 'PRINTOUT ') then read (string,*,err=10,end=10) iprint end if 10 continue end do c c check for use of induced dipole prediction methods c if (use_polar) call predict c c make sure all atoms or groups have a nonzero mass c if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp if (grpmass(i) .le. 0.0d0) then grpmass(i) = 1.0d0 if (igrp(1,i) .le. igrp(2,i)) then totmass = totmass + 1.0d0 if (verbose) then write (iout,20) i 20 format (/,' MDINIT -- Warning, Mass of Group', & i6,' Set to 1.0 for Dynamics') end if end if end if end do else do i = 1, n if (use(i) .and. mass(i).le.0.0d0) then mass(i) = 1.0d0 totmass = totmass + 1.0d0 if (verbose) then write (iout,30) i 30 format (/,' MDINIT -- Warning, Mass of Atom', & i6,' Set to 1.0 for Dynamics') end if end if end do end if c c enforce use of velocity Verlet with Andersen thermostat c if (thermostat .eq. 'ANDERSEN') then if (integrate .eq. 'BEEMAN') integrate = 'VERLET' end if c c enforce use of Bussi thermostat/barostat with integrator c if (integrate .eq. 'BUSSI') then thermostat = 'BUSSI' barostat = 'BUSSI' else if (thermostat.eq.'BUSSI' .and. barostat.eq.'BUSSI') then integrate = 'BUSSI' end if c c enforce use of Nose-Hoover thermostat/barostat with integrator c if (integrate .eq. 'NOSE-HOOVER') then thermostat = 'NOSE-HOOVER' barostat = 'NOSE-HOOVER' else if (thermostat.eq.'NOSE-HOOVER' .and. & barostat.eq.'NOSE-HOOVER') then integrate = 'NOSE-HOOVER' end if c c apply default values for thermostat and barostat coupling c if (tautemp .lt. 0.0d0) then tautemp = 0.2d0 if (thermostat .eq. 'NOSE-HOOVER') tautemp = 1.0d0 end if if (taupres .lt. 0.0d0) then taupres = 2.0d0 if (barostat .eq. 'NOSE-HOOVER') taupres = 10.0d0 end if c c check for use of Monte Carlo barostat with constraints c if (barostat.eq.'MONTECARLO' .and. volscale.eq.'ATOMIC') then if (use_rattle) then write (iout,40) 40 format (/,' MDINIT -- Atom-based Monte Carlo', & ' Barostat Incompatible with RATTLE') call fatal end if end if c c perform dynamic allocation of some global arrays c if (integrate .eq. 'RIGIDBODY') then if (.not. allocated(xcmo)) allocate (xcmo(n)) if (.not. allocated(ycmo)) allocate (ycmo(n)) if (.not. allocated(zcmo)) allocate (zcmo(n)) if (.not. allocated(vcm)) allocate (vcm(3,ngrp)) if (.not. allocated(wcm)) allocate (wcm(3,ngrp)) if (.not. allocated(lm)) allocate (lm(3,ngrp)) if (.not. allocated(vc)) allocate (vc(3,ngrp)) if (.not. allocated(wc)) allocate (wc(3,ngrp)) if (.not. allocated(linear)) allocate (linear(ngrp)) else if (.not. allocated(v)) allocate (v(3,n)) if (.not. allocated(a)) allocate (a(3,n)) if (.not. allocated(aalt)) allocate (aalt(3,n)) end if c c set the number of degrees of freedom for the system c if (nfree .eq. 0) then if (integrate .eq. 'RIGIDBODY') then call grpline nfree = 6 * ngrp do i = 1, ngrp size = igrp(2,i) - igrp(1,i) + 1 if (size .eq. 1) nfree = nfree - 3 if (linear(i)) nfree = nfree - 1 end do else nfree = 3 * nuse end if if (use_rattle) then nfree = nfree - nrat do i = 1, nratx nfree = nfree - kratx(i) end do end if if (isothermal .and. thermostat.ne.'ANDERSEN' & .and. integrate.ne.'STOCHASTIC' & .and. integrate.ne.'BAOAB' & .and. integrate.ne.'GHMC') then if (.not. use_exfld) then if (use_bounds) then nfree = nfree - 3 else nfree = nfree - 6 end if end if end if if (barostat .eq. 'BUSSI') nfree = nfree + 1 end if c c check for a nonzero number of degrees of freedom c if (nfree .lt. 0) nfree = 0 if (debug) then write (iout,50) nfree 50 format (/,' Number of Degrees of Freedom for Dynamics :',i10) end if if (nfree .eq. 0) then write (iout,60) 60 format (/,' MDINIT -- No Degrees of Freedom for Dynamics') call fatal end if c c set masses for Nose-Hoover thermostat and barostat c if (thermostat .eq. 'NOSE-HOOVER') then ekt = gasconst * kelvin qterm = ekt * tautemp * tautemp do j = 1, maxnose if (qnh(j) .eq. 0.0d0) qnh(j) = qterm end do qnh(1) = dble(nfree) * qnh(1) end if if (barostat .eq. 'NOSE-HOOVER') then ekt = gasconst * kelvin qterm = ekt * taupres * taupres qbar = dble(nfree+1) * qterm end if c c decide whether to remove center of mass motion c dorest = .true. if (irest .eq. 0) dorest = .false. if (nuse. ne. n) dorest = .false. if (integrate .eq. 'STOCHASTIC') dorest = .false. if (integrate .eq. 'BAOAB') dorest = .false. if (integrate .eq. 'GHMC') dorest = .false. if (isothermal .and. thermostat.eq.'ANDERSEN') dorest = .false. c c set inner steps per outer step for RESPA integrator c eps = 0.00000001d0 nrespa = int(dt/(arespa+eps)) + 1 c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c try to restart using prior velocities and accelerations c dynfile = filename(1:leng)//'.dyn' call version (dynfile,'old') inquire (file=dynfile,exist=exist) if (exist) then call gradient (e,derivs) idyn = freeunit () open (unit=idyn,file=dynfile,status='old') rewind (unit=idyn) call readdyn (idyn) close (unit=idyn) write (iout,70) dynfile(1:trimtext(dynfile)) 70 format (/,' Restarting Molecular Dynamics Using : ',a) c c set translational velocities for rigid body dynamics c else if (integrate .eq. 'RIGIDBODY') then call gradient (e,derivs) do i = 1, ngrp gmass = grpmass(i) speed = maxwell (gmass,kelvin) call ranvec (vec) do j = 1, 3 vcm(j,i) = speed * vec(j) wcm(j,i) = 0.0d0 lm(j,i) = 0.0d0 end do end do if (nuse .eq. n) then istep = 0 call mdrest (istep) end if c c set velocities and fast/slow accelerations for RESPA method c else if (integrate .eq. 'RESPA') then call gradslow (e,derivs) do i = 1, n amass = mass(i) if (use(i) .and. amass.ne.0.0d0) then speed = maxwell (amass,kelvin) call ranvec (vec) do j = 1, 3 v(j,i) = speed * vec(j) a(j,i) = -ekcal * derivs(j,i) / mass(i) end do else do j = 1, 3 v(j,i) = 0.0d0 a(j,i) = 0.0d0 end do end if end do call gradfast (e,derivs) do i = 1, n amass = mass(i) if (use(i) .and. amass.ne.0.0d0) then do j = 1, 3 aalt(j,i) = -ekcal * derivs(j,i) / amass end do else do j = 1, 3 aalt(j,i) = 0.0d0 end do end if end do if (nuse .eq. n) then istep = 0 call mdrest (istep) end if c c set velocities and accelerations for Cartesian dynamics c else call gradient (e,derivs) do i = 1, n amass = mass(i) if (use(i) .and. amass.ne.0.0d0) then speed = maxwell (amass,kelvin) call ranvec (vec) do j = 1, 3 v(j,i) = speed * vec(j) a(j,i) = -ekcal * derivs(j,i) / amass aalt(j,i) = a(j,i) end do else do j = 1, 3 v(j,i) = 0.0d0 a(j,i) = 0.0d0 aalt(j,i) = 0.0d0 end do end if end do if (nuse .eq. n) then istep = 0 call mdrest (istep) end if end if c c perform deallocation of some local arrays c deallocate (derivs) c c check for any prior dynamics coordinate sets c i = 0 exist = .true. do while (exist) i = i + 1 lext = 3 call numeral (i,ext,lext) dynfile = filename(1:leng)//'.'//ext(1:lext) inquire (file=dynfile,exist=exist) if (.not.exist .and. i.lt.100) then lext = 2 call numeral (i,ext,lext) dynfile = filename(1:leng)//'.'//ext(1:lext) inquire (file=dynfile,exist=exist) end if if (.not.exist .and. i.lt.10) then lext = 1 call numeral (i,ext,lext) dynfile = filename(1:leng)//'.'//ext(1:lext) inquire (file=dynfile,exist=exist) end if end do nprior = i - 1 return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine mdrest -- stop system translation & rotation ## c ## ## c ################################################################# c c c "mdrest" finds and removes any translational or rotational c kinetic energy of the overall system center of mass c c subroutine mdrest (istep) use atomid use atoms use bound use group use inform use iounit use mdstuf use moldyn use rgddyn use units implicit none integer i,j,k integer istep real*8 etrans,erot real*8 weigh,totmass,eps real*8 xx,yy,zz,xy,xz,yz real*8 xtot,ytot,ztot real*8 xdel,ydel,zdel real*8 mang(3),vang(3) real*8 vtot(3),tensor(3,3) real*8, allocatable :: xcm(:) real*8, allocatable :: ycm(:) real*8, allocatable :: zcm(:) c c c check steps between center of mass motion removal c if (.not.dorest) return if (mod(istep,irest) .ne. 0) return c c zero out the total mass and overall linear velocity c totmass = 0.0d0 do j = 1, 3 vtot(j) = 0.0d0 end do c c compute linear velocity of the system center of mass c if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp weigh = grpmass(i) totmass = totmass + weigh do j = 1, 3 vtot(j) = vtot(j) + vcm(j,i)*weigh end do end do else do i = 1, n weigh = mass(i) totmass = totmass + weigh do j = 1, 3 vtot(j) = vtot(j) + v(j,i)*weigh end do end do end if c c compute translational kinetic energy of overall system c etrans = 0.0d0 do j = 1, 3 vtot(j) = vtot(j) / totmass etrans = etrans + vtot(j)**2 end do etrans = 0.5d0 * etrans * totmass / ekcal c c perform dynamic allocation of some local arrays c if (.not.use_bounds .and. integrate.eq.'RIGIDBODY') then allocate (xcm(ngrp)) allocate (ycm(ngrp)) allocate (zcm(ngrp)) end if c c find the center of mass coordinates of the overall system c if (.not. use_bounds) then xtot = 0.0d0 ytot = 0.0d0 ztot = 0.0d0 if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp xcm(i) = 0.0d0 ycm(i) = 0.0d0 zcm(i) = 0.0d0 do j = igrp(1,i), igrp(2,i) k = kgrp(j) weigh = mass(k) xcm(i) = xcm(i) + x(k)*weigh ycm(i) = ycm(i) + y(k)*weigh zcm(i) = zcm(i) + z(k)*weigh end do xtot = xtot + xcm(i) ytot = ytot + ycm(i) ztot = ztot + zcm(i) weigh = max(1.0d0,grpmass(i)) xcm(i) = xcm(i) / weigh ycm(i) = ycm(i) / weigh zcm(i) = zcm(i) / weigh end do else do i = 1, n weigh = mass(i) xtot = xtot + x(i)*weigh ytot = ytot + y(i)*weigh ztot = ztot + z(i)*weigh end do end if xtot = xtot / totmass ytot = ytot / totmass ztot = ztot / totmass c c compute the angular momentum of the overall system c do j = 1, 3 mang(j) = 0.0d0 end do if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp weigh = grpmass(i) mang(1) = mang(1) + (ycm(i)*vcm(3,i) & -zcm(i)*vcm(2,i))*weigh mang(2) = mang(2) + (zcm(i)*vcm(1,i) & -xcm(i)*vcm(3,i))*weigh mang(3) = mang(3) + (xcm(i)*vcm(2,i) & -ycm(i)*vcm(1,i))*weigh end do else do i = 1, n weigh = mass(i) mang(1) = mang(1) + (y(i)*v(3,i)-z(i)*v(2,i))*weigh mang(2) = mang(2) + (z(i)*v(1,i)-x(i)*v(3,i))*weigh mang(3) = mang(3) + (x(i)*v(2,i)-y(i)*v(1,i))*weigh end do end if mang(1) = mang(1) - (ytot*vtot(3)-ztot*vtot(2))*totmass mang(2) = mang(2) - (ztot*vtot(1)-xtot*vtot(3))*totmass mang(3) = mang(3) - (xtot*vtot(2)-ytot*vtot(1))*totmass c c calculate the moment of inertia tensor c xx = 0.0d0 xy = 0.0d0 xz = 0.0d0 yy = 0.0d0 yz = 0.0d0 zz = 0.0d0 if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp weigh = grpmass(i) xdel = xcm(i) - xtot ydel = ycm(i) - ytot zdel = zcm(i) - ztot xx = xx + xdel*xdel*weigh xy = xy + xdel*ydel*weigh xz = xz + xdel*zdel*weigh yy = yy + ydel*ydel*weigh yz = yz + ydel*zdel*weigh zz = zz + zdel*zdel*weigh end do else do i = 1, n weigh = mass(i) xdel = x(i) - xtot ydel = y(i) - ytot zdel = z(i) - ztot xx = xx + xdel*xdel*weigh xy = xy + xdel*ydel*weigh xz = xz + xdel*zdel*weigh yy = yy + ydel*ydel*weigh yz = yz + ydel*zdel*weigh zz = zz + zdel*zdel*weigh end do end if tensor(1,1) = yy + zz tensor(2,1) = -xy tensor(3,1) = -xz tensor(1,2) = -xy tensor(2,2) = xx + zz tensor(3,2) = -yz tensor(1,3) = -xz tensor(2,3) = -yz tensor(3,3) = xx + yy c c fix to avoid singularity for one- or two-body systems c if (integrate .eq. 'RIGIDBODY') then if (ngrp .le. 2) then eps = 0.000001d0 tensor(1,1) = tensor(1,1) + eps tensor(2,2) = tensor(2,2) + eps tensor(3,3) = tensor(3,3) + eps end if else if (n .le. 2) then eps = 0.000001d0 tensor(1,1) = tensor(1,1) + eps tensor(2,2) = tensor(2,2) + eps tensor(3,3) = tensor(3,3) + eps end if end if c c diagonalize the moment of inertia tensor c call invert (3,tensor) c c compute angular velocity and rotational kinetic energy c erot = 0.0d0 do i = 1, 3 vang(i) = 0.0d0 do j = 1, 3 vang(i) = vang(i) + tensor(i,j)*mang(j) end do erot = erot + vang(i)*mang(i) end do erot = 0.5d0 * erot / ekcal end if c c eliminate any translation of the overall system c if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp do j = 1, 3 vcm(j,i) = vcm(j,i) - vtot(j) end do end do else do i = 1, n do j = 1, 3 v(j,i) = v(j,i) - vtot(j) end do end do end if c c print the translational velocity of the overall system c if (debug) then write (iout,10) (vtot(i),i=1,3),etrans 10 format (' System Linear Velocity : ',3d12.2, & /,' Translational Kinetic Energy :',10x,f12.4, & ' Kcal/mole') end if c c eliminate any rotation about the system center of mass c if (.not. use_bounds) then if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp xdel = xcm(i) - xtot ydel = ycm(i) - ytot zdel = zcm(i) - ztot vcm(1,i) = vcm(1,i) - vang(2)*zdel + vang(3)*ydel vcm(2,i) = vcm(2,i) - vang(3)*xdel + vang(1)*zdel vcm(3,i) = vcm(3,i) - vang(1)*ydel + vang(2)*xdel end do else do i = 1, n xdel = x(i) - xtot ydel = y(i) - ytot zdel = z(i) - ztot v(1,i) = v(1,i) - vang(2)*zdel + vang(3)*ydel v(2,i) = v(2,i) - vang(3)*xdel + vang(1)*zdel v(3,i) = v(3,i) - vang(1)*ydel + vang(2)*xdel end do end if c c print the angular velocity of the overall system c if (debug) then write (iout,20) (vang(i),i=1,3),erot 20 format (' System Angular Velocity : ',3d12.2, & /,' Rotational Kinetic Energy :',13x,f12.4, & ' Kcal/mole') end if end if c c perform deallocation of some local arrays c if (.not.use_bounds .and. integrate.eq.'RIGIDBODY') then deallocate (xcm) deallocate (ycm) deallocate (zcm) 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 mdsave -- save trajectory and restart files ## c ## ## c ################################################################ c c c "mdsave" writes molecular dynamics trajectory snapshots and c auxiliary files with velocity, force or induced dipole data; c also checks for user requested termination of a simulation c c subroutine mdsave (istep,dt,epot,eksum) use atomid use atoms use bound use boxes use couple use files use group use inform use iounit use mdstuf use mpole use output use polar use potent use rgddyn use socket use titles implicit none integer i,j,lext integer istep integer ixyz,iind integer ivel,ifrc integer iend,isave integer freeunit integer trimtext integer modsave real*8 dt,pico real*8 epot,eksum logical exist,first character*7 ext character*240 endfile character*240 xyzfile character*240 velfile character*240 frcfile character*240 indfile c c c send data via external socket communication if desired c if (.not.sktstart .or. use_socket) call sktdyn (istep,dt,epot) c c check number of steps between trajectory file saves c modsave = mod(istep,iwrite) if (modsave .ne. 0) return c c get the sequence number of the current trajectory frame c isave = nprior + istep/iwrite lext = 3 call numeral (isave,ext,lext) c c print header for the instantaneous values at current step c pico = dble(istep) * dt write (iout,10) istep 10 format (/,' Instantaneous Values for Frame Saved at', & i10,' Dynamics Steps') c c print the current time, potential and kinetic energies c if (digits .ge. 8) then write (iout,20) pico 20 format (/,' Current Time',8x,f19.8,' Picosecond') write (iout,30) epot 30 format (' Current Potential',3x,f19.8,' Kcal/mole') write (iout,40) eksum 40 format (' Current Kinetic',5x,f19.8,' Kcal/mole') else if (digits .ge. 6) then write (iout,50) pico 50 format (/,' Current Time',8x,f17.6,' Picosecond') write (iout,60) epot 60 format (' Current Potential',3x,f17.6,' Kcal/mole') write (iout,70) eksum 70 format (' Current Kinetic',5x,f17.6,' Kcal/mole') else write (iout,80) pico 80 format (/,' Current Time',8x,f15.4,' Picosecond') write (iout,90) epot 90 format (' Current Potential',3x,f15.4,' Kcal/mole') write (iout,100) eksum 100 format (' Current Kinetic',5x,f15.4,' Kcal/mole') end if c c print the values of the lattice lengths and angles c if (use_bounds) then if (digits .le. 6) then write (iout,110) xbox,ybox,zbox 110 format (' Lattice Lengths',6x,3f14.6) write (iout,120) alpha,beta,gamma 120 format (' Lattice Angles',7x,3f14.6) else if (digits .le. 8) then write (iout,130) xbox,ybox,zbox 130 format (' Lattice Lengths',6x,3f16.8) write (iout,140) alpha,beta,gamma 140 format (' Lattice Angles',7x,3f16.8) else write (iout,150) xbox,ybox,zbox 150 format (' Lattice Lengths',6x,3f18.10) write (iout,160) alpha,beta,gamma 160 format (' Lattice Angles',7x,3f18.10) end if end if c c move stray molecules into periodic box if desired c if (use_bounds) call bounds c c save coordinates to archive or numbered structure file c ixyz = freeunit () if (cyclesave) then xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') call prtxyz (ixyz) else if (dcdsave) then xyzfile = filename(1:leng) call suffix (xyzfile,'dcd','old') inquire (file=xyzfile,exist=exist) if (exist) then first = .false. open (unit=ixyz,file=xyzfile,form='unformatted', & status='old',position='append') else first = .true. open (unit=ixyz,file=xyzfile,form='unformatted', & status='new') end if call prtdcd (ixyz,first) else xyzfile = filename(1:leng) call suffix (xyzfile,'arc','old') inquire (file=xyzfile,exist=exist) if (exist) then call openend (ixyz,xyzfile) else open (unit=ixyz,file=xyzfile,status='new') end if call prtxyz (ixyz) end if close (unit=ixyz) write (iout,170) isave 170 format (' Frame Number',13x,i10) write (iout,180) xyzfile(1:trimtext(xyzfile)) 180 format (' Coordinate File',13x,a) c c update the information needed to restart the trajectory c call prtdyn c c save the velocity vector components at the current step c if (velsave) then ivel = freeunit () if (cyclesave) then velfile = filename(1:leng)//'.'//ext(1:lext)//'v' call version (velfile,'new') open (unit=ivel,file=velfile,status='new') else if (dcdsave) then velfile = filename(1:leng) call suffix (velfile,'dcdv','old') inquire (file=velfile,exist=exist) if (exist) then first = .false. open (unit=ivel,file=velfile,form='unformatted', & status='old',position='append') else first = .true. open (unit=ivel,file=velfile,form='unformatted', & status='new') end if else velfile = filename(1:leng) call suffix (velfile,'vel','old') inquire (file=velfile,exist=exist) if (exist) then call openend (ivel,velfile) else open (unit=ivel,file=velfile,status='new') end if end if if (integrate .eq. 'RIGIDBODY') then write (ivel,190) ngrp,title(1:ltitle) 190 format (i6,2x,a) do i = 1, ngrp write (ivel,200) i,(vcm(j,i),j=1,3) 200 format (i6,3x,d13.6,3x,d13.6,3x,d13.6) write (ivel,210) i,(wcm(j,i),j=1,3) 210 format (i6,3x,d13.6,3x,d13.6,3x,d13.6) end do else if (dcdsave) then call prtdcdv (ivel,first) else call prtvel (ivel) end if close (unit=ivel) write (iout,240) velfile(1:trimtext(velfile)) 240 format (' Velocity File',15x,a) end if c c save the force vector components for the current step; c only correct for single time step Cartesian integrators c if (frcsave .and. integrate.ne.'RIGIDBODY' & .and. integrate.ne.'RESPA') then ifrc = freeunit () if (cyclesave) then frcfile = filename(1:leng)//'.'//ext(1:lext)//'f' call version (frcfile,'new') open (unit=ifrc,file=frcfile,status='new') else if (dcdsave) then frcfile = filename(1:leng) call suffix (frcfile,'dcdf','old') inquire (file=frcfile,exist=exist) if (exist) then first = .false. open (unit=ifrc,file=frcfile,form='unformatted', & status='old',position='append') else first = .true. open (unit=ifrc,file=frcfile,form='unformatted', & status='new') end if call prtdcdf (ifrc,first) else 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 call prtfrc (ifrc) end if close (unit=ifrc) write (iout,270) frcfile(1:trimtext(frcfile)) 270 format (' Force Vector File',11x,a) end if c c save the induced dipole components for the current step c if (uindsave .and. use_polar) then iind = freeunit () if (cyclesave) then indfile = filename(1:leng)//'.'//ext(1:lext)//'u' call version (indfile,'new') open (unit=iind,file=indfile,status='new') else if (dcdsave) then indfile = filename(1:leng) call suffix (indfile,'dcdu','old') inquire (file=indfile,exist=exist) if (exist) then first = .false. open (unit=iind,file=indfile,form='unformatted', & status='old',position='append') else first = .true. open (unit=iind,file=indfile,form='unformatted', & status='new') end if call prtdcdu (iind,first) else 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 call prtuind (iind) end if close (unit=iind) write (iout,300) indfile(1:trimtext(indfile)) 300 format (' Induced Dipole File',9x,a) end if c c test for requested termination of the dynamics calculation 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,310) 310 format (/,' MDSAVE -- Dynamics Calculation Ending', & ' due to User Request') call fatal end if c c skip an extra line to keep the output formating neat c modsave = mod(istep,iprint) if (verbose .and. modsave.ne.0) then write (iout,320) 320 format () 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 mdstat -- compute averages over a trajectory ## c ## ## c ################################################################# c c c "mdstat" is called at each molecular dynamics time step to c form statistics on various average values and fluctuations, c and to periodically save the state of the trajectory c c subroutine mdstat (istep,dt,etot,epot,ekin,temp,pres) use atoms use bath use bound use boxes use inform use iounit use limits use mdstuf use molcul use units use usage use warp implicit none integer istep integer modstep real*8 dt,temp,pres real*8 etot,epot,ekin real*8 pico,dens real*8 fluctuate,fluctuate2 real*8 potfluct,potfluct2 real*8 kinfluct,kinfluct2 real*8 tfluct,pfluct,dfluct real*8 tfluct2,pfluct2,dfluct2 real*8 etot_sum,etot2_sum real*8 etot_ave,etot2_ave real*8 epot_sum,epot2_sum real*8 epot_ave,epot2_ave real*8 ekin_sum,ekin2_sum real*8 ekin_ave,ekin2_ave real*8 temp_sum,temp2_sum real*8 temp_ave,temp2_ave real*8 pres_sum,pres2_sum real*8 pres_ave,pres2_ave real*8 dens_sum,dens2_sum real*8 dens_ave,dens2_ave save etot_sum,etot2_sum save epot_sum,epot2_sum save ekin_sum,ekin2_sum save temp_sum,temp2_sum save pres_sum,pres2_sum save dens_sum,dens2_sum c c c set number of steps for block averages of properties c modstep = mod(istep,iprint) c c zero out summation variables for new averaging period c if (modstep.eq.1 .or. iprint.eq.1) then etot_sum = 0.0d0 etot2_sum = 0.0d0 epot_sum = 0.0d0 epot2_sum = 0.0d0 ekin_sum = 0.0d0 ekin2_sum = 0.0d0 temp_sum = 0.0d0 temp2_sum = 0.0d0 pres_sum = 0.0d0 pres2_sum = 0.0d0 dens_sum = 0.0d0 dens2_sum = 0.0d0 end if c c print energy, temperature and pressure for current step c if (verbose) then if (modstep .eq. 1) then if (use_bounds .and. integrate.ne.'STOCHASTIC') then write (iout,10) 10 format (/,4x,'MD Step',7x,'E Total',4x,'E Potential', & 6x,'E Kinetic',7x,'Temp',7x,'Pres',/) else write (iout,20) 20 format (/,4x,'MD Step',7x,'E Total',4x,'E Potential', & 6x,'E Kinetic',7x,'Temp',/) end if end if if (use_bounds .and. integrate.ne.'STOCHASTIC') then write (iout,30) istep,etot,epot,ekin,temp,pres 30 format (i10,3f15.4,2f11.2) else write (iout,40) istep,etot,epot,ekin,temp 40 format (i10,3f15.4,f11.2) end if flush (iout) end if c c print header for the averages over a group of recent steps c if (modstep .eq. 0) then pico = dble(istep) * dt write (iout,50) iprint,istep 50 format (/,' Average Values for the Last',i6,' Out of', & i9,' Dynamics Steps') if (digits .ge. 8) then write (iout,60) pico 60 format (/,' Simulation Time',5x,f19.8,' Picosecond') else if (digits .ge. 6) then write (iout,70) pico 70 format (/,' Simulation Time',5x,f17.6,' Picosecond') else write (iout,80) pico 80 format (/,' Simulation Time',5x,f15.4,' Picosecond') end if end if c c compute total energy and fluctuation for recent steps c etot_sum = etot_sum + etot etot2_sum = etot2_sum + etot**2 if (modstep .eq. 0) then etot_ave = etot_sum / dble(iprint) etot2_ave = etot2_sum / dble(iprint) fluctuate2 = etot2_ave - etot_ave**2 if (fluctuate2 .gt. 0.0d0) then fluctuate = sqrt(fluctuate2) else fluctuate = 0.0d0 end if if (digits .ge. 8) then write (iout,90) etot_ave,fluctuate 90 format (' Total Energy',8x,f19.8,' Kcal/mole',3x, & '(+/-',f13.8,')') else if (digits .ge. 6) then write (iout,100) etot_ave,fluctuate 100 format (' Total Energy',8x,f17.6,' Kcal/mole',3x, & '(+/-',f11.6,')') else write (iout,110) etot_ave,fluctuate 110 format (' Total Energy',8x,f15.4,' Kcal/mole',3x, & '(+/-',f9.4,')') end if end if c c compute average potential energy and its fluctuation c epot_sum = epot_sum + epot epot2_sum = epot2_sum + epot**2 if (modstep .eq. 0) then epot_ave = epot_sum / dble(iprint) epot2_ave = epot2_sum / dble(iprint) potfluct2 = epot2_ave - epot_ave**2 if (potfluct2 .gt. 0.0d0) then potfluct = sqrt(potfluct2) else potfluct = 0.0d0 end if if (digits .ge. 8) then write (iout,120) epot_ave,potfluct 120 format (' Potential Energy',4x,f19.8,' Kcal/mole',3x, & '(+/-',f13.8,')') else if (digits .ge. 6) then write (iout,130) epot_ave,potfluct 130 format (' Potential Energy',4x,f17.6,' Kcal/mole',3x, & '(+/-',f11.6,')') else write (iout,140) epot_ave,potfluct 140 format (' Potential Energy',4x,f15.4,' Kcal/mole',3x, & '(+/-',f9.4,')') end if end if c c compute average kinetic energy and its fluctuation c ekin_sum = ekin_sum + ekin ekin2_sum = ekin2_sum + ekin**2 if (modstep .eq. 0) then ekin_ave = ekin_sum / dble(iprint) ekin2_ave = ekin2_sum / dble(iprint) kinfluct2 = ekin2_ave - ekin_ave**2 if (kinfluct2 .gt. 0.0d0) then kinfluct = sqrt(kinfluct2) else kinfluct = 0.0d0 end if if (digits .ge. 8) then write (iout,150) ekin_ave,kinfluct 150 format (' Kinetic Energy',6x,f19.8,' Kcal/mole',3x, & '(+/-',f13.8,')') else if (digits .ge. 6) then write (iout,160) ekin_ave,kinfluct 160 format (' Kinetic Energy',6x,f17.6,' Kcal/mole',3x, & '(+/-',f11.6,')') else write (iout,170) ekin_ave,kinfluct 170 format (' Kinetic Energy',6x,f15.4,' Kcal/mole',3x, & '(+/-',f9.4,')') end if end if c c compute the average temperature and its fluctuation c temp_sum = temp_sum + temp temp2_sum = temp2_sum + temp**2 if (modstep .eq. 0) then temp_ave = temp_sum / dble(iprint) temp2_ave = temp2_sum / dble(iprint) tfluct2 = temp2_ave - temp_ave**2 if (tfluct2 .gt. 0.0d0) then tfluct = sqrt(tfluct2) else tfluct = 0.0d0 end if if (digits .ge. 8) then write (iout,210) temp_ave,tfluct 210 format (' Temperature',9x,f19.6,' Kelvin',6x, & '(+/-',f13.6,')') else if (digits .ge. 6) then write (iout,220) temp_ave,tfluct 220 format (' Temperature',9x,f17.4,' Kelvin',6x, & '(+/-',f11.4,')') else write (iout,230) temp_ave,tfluct 230 format (' Temperature',9x,f15.2,' Kelvin',6x, & '(+/-',f9.2,')') end if end if c c compute the average pressure and its fluctuation c if (use_bounds) then pres_sum = pres_sum + pres pres2_sum = pres2_sum + pres**2 if (modstep .eq. 0) then pres_ave = pres_sum / dble(iprint) pres2_ave = pres2_sum / dble(iprint) pfluct2 = pres2_ave - pres_ave**2 if (pfluct2 .gt. 0.0d0) then pfluct = sqrt(pfluct2) else pfluct = 0.0d0 end if if (digits .ge. 8) then write (iout,240) pres_ave,pfluct 240 format (' Pressure',12x,f19.6,' Atmosphere',2x, & '(+/-',f13.6,')') else if (digits .ge. 6) then write (iout,250) pres_ave,pfluct 250 format (' Pressure',12x,f17.4,' Atmosphere',2x, & '(+/-',f11.4,')') else write (iout,260) pres_ave,pfluct 260 format (' Pressure',12x,f15.2,' Atmosphere',2x, & '(+/-',f9.2,')') end if end if c c compute the average density and its fluctuation c dens = (1.0d24/volbox) * (totmass/avogadro) dens_sum = dens_sum + dens dens2_sum = dens2_sum + dens**2 if (modstep .eq. 0) then dens_ave = dens_sum / dble(iprint) dens2_ave = dens2_sum / dble(iprint) dfluct2 = dens2_ave - dens_ave**2 if (dfluct2 .gt. 0.0d0) then dfluct = sqrt(dfluct2) else dfluct = 0.0d0 end if if (digits .ge. 8) then write (iout,270) dens_ave,dfluct 270 format (' Density',13x,f19.8,' Grams/cc',4x, & '(+/-',f13.8,')') else if (digits .ge. 6) then write (iout,280) dens_ave,dfluct 280 format (' Density',13x,f17.6,' Grams/cc',4x, & '(+/-',f11.6,')') else write (iout,290) dens_ave,dfluct 290 format (' Density',13x,f15.4,' Grams/cc',4x, & '(+/-',f9.4,')') end if end if end if c c declare deformation value for potential energy smoothing c if (use_smooth) then if (modstep .eq. 0) then if (digits .ge. 8) then write (iout,300) deform 300 format (' Deformation',9x,f19.8,' Sqr Angs') else if (digits .ge. 6) then write (iout,310) deform 310 format (' Deformation',9x,f17.6,' Sqr Angs') else write (iout,320) deform 320 format (' Deformation',9x,f15.4,' Sqr Angs') end if end if end if c c ensure any output is written to the storage device c if (modstep .eq. 0) flush (iout) return end c c c ################################################### c ## COPYRIGHT (C) 2000 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module mdstuf -- molecular dynamics trajectory controls ## c ## ## c ################################################################# c c c nfree total number of degrees of freedom for a system c irest steps between removal of COM motion (0=no removal) c bmnmix mixing coefficient for use with Beeman integrator c nrespa inner steps per outer step for RESPA integrator c arespa inner time step for use with RESPA integrator c dorest logical flag to remove center of mass motion c integrate type of molecular dynamics integration algorithm c c module mdstuf implicit none integer nfree integer irest integer bmnmix integer nrespa real*8 arespa logical dorest character*11 integrate save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine mechanic -- initialize molecular mechanics ## c ## ## c ############################################################### c c c "mechanic" sets up needed parameters for the potential energy c calculation and reads in many of the user selectable options c c subroutine mechanic use inform use iounit implicit none c c c set the bonded connectivity lists and active atoms c call attach call active c c find bonds, angles, torsions, bitorsions and small rings c call bonds call angles call torsions call bitors call rings c c get the base force field from parameter file and keyfile c call field c c find unit cell type, lattice parameters and cutoff values c call unitcell call lattice call polymer call cutoffs c c setup needed for potential energy smoothing methods c call flatten c c assign atom types, classes and other atomic information c call katom c c assign atoms to molecules and set the atom groups c call molecule call cluster c c find any pisystem atoms, bonds and torsional angles c call orbital c c assign bond, angle and cross term potential parameters c call kbond call kangle call kstrbnd call kurey call kangang c c assign out-of-plane deformation potential parameters c call kopbend call kopdist call kimprop call kimptor c c assign torsion and torsion cross term potential parameters c call ktors call kpitors call kstrtor call kangtor call ktortor c c assign electrostatic interaction potential parameters c call kcharge call kdipole call kmpole call kpolar call kchgtrn call kchgflx c c assign van der Waals, repulsion and dispersion parameters c call kvdw call krepel call kdisp c c assign solvation, metal, pisystem and restraint parameters c call ksolv call kmetal call korbit call kgeom call kextra c c assign electrostatic and dispersion Ewald sum parameters c call kewald c c set any holonomic interatomic distance constraints c call shakeup c c set hybrid parameter values for free energy perturbation c call mutate c c quit if essential parameter information is missing c if (abort) then write (iout,10) 10 format (/,' MECHANIC -- Some Required Potential Energy', & ' Parameters are Undefined') call fatal end if return end c c c ############################################################## c ## COPYRIGHT (C) 2007 by Nicolas Staelens & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################## c c ############################################################## c ## ## c ## module merck -- MMFF-specific force field parameters ## c ## ## c ############################################################## c c c nligne number of atom pairs having MMFF Bond Type 1 c bt_1 atom pairs having MMFF Bond Type 1 c eqclass table of atom class equivalencies used to find c default parameters if explicit values are missing c (see J. Comput. Chem., 17, 490-519, '95, Table IV) c crd number of attached neighbors | c val valency value | see T. A. Halgren, c pilp if 0, no lone pair | J. Comput. Chem., c if 1, one or more lone pair(s) | 17, 616-645 (1995) c mltb multibond indicator | c arom aromaticity indicator | c lin linearity indicator | c sbmb single- vs multiple-bond flag | c mmffarom aromatic rings parameters c mmffaromc cationic aromatic rings parameters c mmffaroma anionic aromatic rings parameters c c module merck use sizes implicit none integer nligne integer bt_1(500,2) integer eqclass(500,5) integer crd(100) integer val(100) integer pilp(100) integer mltb(100) integer arom(100) integer lin(100) integer sbmb(100) integer mmffarom(maxtyp,6) integer mmffaromc(maxtyp,6) integer mmffaroma(maxtyp,6) c c c rad0 covalent atomic radius for empirical bond rules c paulel Pauling electronegativities for empirical bond rules c r0ref reference bond length for empirical bond rules c kbref reference force constant for empirical bond rules c mmff_kb bond force constant for pairs of atom classes c mmff_kb1 bond force constant for class pairs with Bond Type 1 c mmff_b0 bond length value for pairs of atom classes c mmff_b1 bond length value for class pairs with Bond Type 1 c c real*8 rad0(100) real*8 paulel(100) real*8 r0ref(100,100) real*8 kbref(100,100) real*8 mmff_kb(100,100) real*8 mmff_kb1(100,100) real*8 mmff_b0(100,100) real*8 mmff_b1(100,100) c c c mmff_ka angle force constant for triples of atom classes c mmff_ka1 angle force constant with one bond of Type 1 c mmff_ka2 angle force constant with both bonds of Type 1 c mmff_ka3 angle force constant for 3-membered ring c mmff_ka4 angle force constant for 4-membered ring c mmff_ka5 angle force constant for 3-ring and one Bond Type 1 c mmff_ka6 angle force constant for 3-ring and both Bond Type 1 c mmff_ka7 angle force constant for 4-ring and one Bond Type 1 c mmff_ka8 angle force constant for 4-ring and both Bond Type 1 c mmff_ang0 ideal bond angle for triples of atom classes c mmff_ang1 ideal bond angle with one bond of Type 1 c mmff_ang2 ideal bond angle with both bonds of Type 1 c mmff_ang3 ideal bond angle for 3-membered ring c mmff_ang4 ideal bond angle for 4-membered ring c mmff_ang5 ideal bond angle for 3-ring and one Bond Type 1 c mmff_ang6 ideal bond angle for 3-ring and both Bond Type 1 c mmff_ang7 ideal bond angle for 4-ring and one Bond Type 1 c mmff_ang8 ideal bond angle for 4-ring and both Bond Type 1 c c real*8, allocatable :: mmff_ka(:,:,:) real*8, allocatable :: mmff_ka1(:,:,:) real*8, allocatable :: mmff_ka2(:,:,:) real*8, allocatable :: mmff_ka3(:,:,:) real*8, allocatable :: mmff_ka4(:,:,:) real*8, allocatable :: mmff_ka5(:,:,:) real*8, allocatable :: mmff_ka6(:,:,:) real*8, allocatable :: mmff_ka7(:,:,:) real*8, allocatable :: mmff_ka8(:,:,:) real*8, allocatable :: mmff_ang0(:,:,:) real*8, allocatable :: mmff_ang1(:,:,:) real*8, allocatable :: mmff_ang2(:,:,:) real*8, allocatable :: mmff_ang3(:,:,:) real*8, allocatable :: mmff_ang4(:,:,:) real*8, allocatable :: mmff_ang5(:,:,:) real*8, allocatable :: mmff_ang6(:,:,:) real*8, allocatable :: mmff_ang7(:,:,:) real*8, allocatable :: mmff_ang8(:,:,:) c c c Stretch-Bend Type 0 c stbn_abc stretch-bend parameters for A-B-C atom classes c stbn_cba stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type 1 (A-B is Bond Type 1) c stbn_abc1 stretch-bend parameters for A-B-C atom classes c stbn_cba1 stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type 2 (B-C is Bond Type 1) c stbn_abc2 stretch-bend parameters for A-B-C atom classes c stbn_cba2 stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type = 3 (A-B and B-C are Bond Type 1) c stbn_abc3 stretch-bend parameters for A-B-C atom classes c stbn_cba3 stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type 4 (both Bond Types 0, 4-membered ring) c stbn_abc4 stretch-bend parameters for A-B-C atom classes c stbn_cba4 stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type 5 (both Bond Types 0, 3-membered ring) c stbn_abc5 stretch-bend parameters for A-B-C atom classes c stbn_cba5 stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type 6 (A-B is Bond Type 1, 3-membered ring) c stbn_abc6 stretch-bend parameters for A-B-C atom classes c stbn_cba6 stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type 7 (B-C is Bond Type 1, 3-membered ring) c stbn_abc7 stretch-bend parameters for A-B-C atom classes c stbn_cba7 stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type 8 (both Bond Types 1, 3-membered ring) c stbn_abc8 stretch-bend parameters for A-B-C atom classes c stbn_cba8 stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type 9 (A-B is Bond Type 1, 4-membered ring) c stbn_abc9 stretch-bend parameters for A-B-C atom classes c stbn_cba9 stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type 10 (B-C is Bond Type 1, 4-membered ring) c stbn_abc10 stretch-bend parameters for A-B-C atom classes c stbn_cba10 stretch-bend parameters for C-B-A atom classes c Stretch-Bend Type 11 (both Bond Types 1, 4-membered ring) c stbn_abc11 stretch-bend parameters for A-B-C atom classes c stbn_cba11 stretch-bend parameters for C-B-A atom classes c defstbn_abc default stretch-bend parameters for A-B-C classes c defstbn_cba default stretch-bend parameters for C-B-A classes c c real*8, allocatable :: stbn_abc(:,:,:) real*8, allocatable :: stbn_cba(:,:,:) real*8, allocatable :: stbn_abc1(:,:,:) real*8, allocatable :: stbn_cba1(:,:,:) real*8, allocatable :: stbn_abc2(:,:,:) real*8, allocatable :: stbn_cba2(:,:,:) real*8, allocatable :: stbn_abc3(:,:,:) real*8, allocatable :: stbn_cba3(:,:,:) real*8, allocatable :: stbn_abc4(:,:,:) real*8, allocatable :: stbn_cba4(:,:,:) real*8, allocatable :: stbn_abc5(:,:,:) real*8, allocatable :: stbn_cba5(:,:,:) real*8, allocatable :: stbn_abc6(:,:,:) real*8, allocatable :: stbn_cba6(:,:,:) real*8, allocatable :: stbn_abc7(:,:,:) real*8, allocatable :: stbn_cba7(:,:,:) real*8, allocatable :: stbn_abc8(:,:,:) real*8, allocatable :: stbn_cba8(:,:,:) real*8, allocatable :: stbn_abc9(:,:,:) real*8, allocatable :: stbn_cba9(:,:,:) real*8, allocatable :: stbn_abc10(:,:,:) real*8, allocatable :: stbn_cba10(:,:,:) real*8, allocatable :: stbn_abc11(:,:,:) real*8, allocatable :: stbn_cba11(:,:,:) real*8 defstbn_abc(0:4,0:4,0:4) real*8 defstbn_cba(0:4,0:4,0:4) c c c t1_1 torsional parameters for 1-fold, MMFF Torsion Type 1 c t1_2 torsional parameters for 1-fold, MMFF Torsion Type 2 c t2_1 torsional parameters for 2-fold, MMFF Torsion Type 1 c t2_2 torsional parameters for 2-fold, MMFF Torsion Type 2 c t3_1 torsional parameters for 3-fold, MMFF Torsion Type 1 c t3_2 torsional parameters for 3-fold, MMFF Torsion Type 2 c kt_1 string of classes for torsions, MMFF Torsion Type 1 c kt_2 string of classes for torsions, MMFF Torsion Type 2 c c real*8 t1_1(2,0:2000) real*8 t2_1(2,0:2000) real*8 t3_1(2,0:2000) real*8 t1_2(2,0:2000) real*8 t2_2(2,0:2000) real*8 t3_2(2,0:2000) character*16 kt_1(0:2000) character*16 kt_2(0:2000) c c c g scale factors for calculation of MMFF eps c alph atomic polarizabilities for calculation of MMFF eps c nn effective number of valence electrons for MMFF eps c da donor/acceptor atom classes c c real*8 g(maxclass) real*8 alph(maxclass) real*8 nn(maxclass) character*1 da(maxclass) c c c bci bond charge increments for building atom charges c bci_1 bond charge increments for MMFF Bond Type 1 c pbci partial BCI for building missing BCI's c fcadj formal charge adjustment factor c c real*8 bci(100,100) real*8 bci_1(100,100) real*8 pbci(maxclass) real*8 fcadj(maxclass) save end c c c ################################################### c ## COPYRIGHT (C) 1996 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine merge -- merge reference & current systems ## c ## ## c ############################################################### c c c "merge" combines the reference and current structures into c a single new "current" structure containing the reference c atoms followed by the atoms of the current structure c c subroutine merge (iref) use atomid use atoms use couple use iounit use refer implicit none integer i,j,k integer iref integer ntotal c c c check for too many total atoms in the combined system c ntotal = n + nref(iref) if (ntotal .gt. maxatm) then write (iout,10) maxatm 10 format (/,' MERGE -- The Maximum of',i9,' Atoms', & ' has been Exceeded') call fatal end if c c move the current structure to higher atom numbers c do i = n, 1, -1 k = i + nref(iref) x(k) = x(i) y(k) = y(i) z(k) = z(i) type(k) = type(i) name(k) = name(i) n12(k) = n12(i) do j = 1, n12(i) i12(j,k) = i12(j,i) + nref(iref) end do end do c c place reference structure in the current structure c call getref (iref) n = ntotal return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module minima -- general parameters for minimizations ## c ## ## c ############################################################### c c c maxiter maximum number of iterations during optimization c nextiter iteration number to use for the first iteration c fctmin value below which function is deemed optimized c hguess initial value for the H-matrix diagonal elements c c module minima implicit none integer maxiter integer nextiter real*8 fctmin real*8 hguess save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## program minimize -- low storage BFGS Cartesian optimizer ## c ## ## c ################################################################## c c c "minimize" performs energy minimization in Cartesian coordinate c space using a low storage BFGS nonlinear optimization c c program minimize use atoms use bound use files use freeze use inform use iounit use scales use usage implicit none integer i,j,k integer imin,nvar integer freeunit real*8 minimum,minimiz1 real*8 grdmin,gnorm,grms real*8 energy,eps real*8, allocatable :: xx(:) real*8, allocatable :: derivs(:,:) logical exist,analytic character*240 minfile character*240 string external energy external minimiz1 external optsave c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c perform the setup functions needed for optimization c call optinit c c use either analytical or numerical gradients c analytic = .true. eps = 0.00001d0 c c get termination criterion as RMS gradient per atom c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) grdmin 10 continue if (grdmin .le. 0.0d0) then write (iout,20) 20 format (/,' Enter RMS Gradient per Atom Criterion', & ' [0.01] : ',$) read (input,30) grdmin 30 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.01d0 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 global arrays c if (.not. allocated(scale)) allocate (scale(3*n)) c c set scaling parameter for function and derivative values; c use square root of median eigenvalue of typical Hessian c set_scale = .true. nvar = 0 do i = 1, nuse do j = 1, 3 nvar = nvar + 1 scale(nvar) = 12.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (xx(nvar)) allocate (derivs(3,n)) c c convert atomic coordinates to optimization parameters c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 xx(nvar) = x(k) * scale(nvar) nvar = nvar + 1 xx(nvar) = y(k) * scale(nvar) nvar = nvar + 1 xx(nvar) = z(k) * scale(nvar) end do c c make the call to the optimization routine c call lbfgs (nvar,xx,minimum,grdmin,minimiz1,optsave) 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) / scale(nvar) nvar = nvar + 1 y(k) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(k) = xx(nvar) / scale(nvar) end do c c compute the final function and RMS gradient values c if (analytic) then call gradient (minimum,derivs) else minimum = energy () call numgrad (energy,derivs,eps) end if 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,40) minimum,grms,gnorm 40 format (/,' Final Function Value :',2x,f20.8, & /,' Final RMS Gradient :',4x,f20.8, & /,' Final Gradient Norm :',3x,f20.8) else write (iout,50) minimum,grms,gnorm 50 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,60) minimum,grms,gnorm 60 format (/,' Final Function Value :',2x,f18.6, & /,' Final RMS Gradient :',4x,f18.6, & /,' Final Gradient Norm :',3x,f18.6) else write (iout,70) minimum,grms,gnorm 70 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,80) minimum,grms,gnorm 80 format (/,' Final Function Value :',2x,f16.4, & /,' Final RMS Gradient :',4x,f16.4, & /,' Final Gradient Norm :',3x,f16.4) else write (iout,90) minimum,grms,gnorm 90 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 move stray molecules into periodic box if desired c c if (use_bounds) call bounds 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 ## function minimiz1 -- energy and gradient for minimize ## c ## ## c ############################################################### c c c "minimiz1" is a service routine that computes the energy and c gradient for a low storage BFGS optimization in Cartesian c coordinate space c c function minimiz1 (xx,g) use atoms use freeze use scales use usage implicit none integer i,k,nvar real*8 minimiz1,e real*8 energy,eps real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) logical analytic external energy c c c use either analytical or numerical gradients c analytic = .true. eps = 0.00001d0 c c convert optimization parameters to atomic coordinates c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 x(k) = xx(nvar) / scale(nvar) nvar = nvar + 1 y(k) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(k) = xx(nvar) / scale(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 and store the energy and gradient c if (analytic) then call gradient (e,derivs) else e = energy () call numgrad (energy,derivs,eps) end if minimiz1 = e c c adjust gradient to remove components along constraints c if (use_rattle) call shake2 (derivs) c c convert coordinates and gradient to optimization parameters c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 xx(nvar) = x(k) * scale(nvar) g(nvar) = derivs(1,k) / scale(nvar) nvar = nvar + 1 xx(nvar) = y(k) * scale(nvar) g(nvar) = derivs(2,k) / scale(nvar) nvar = nvar + 1 xx(nvar) = z(k) * scale(nvar) g(nvar) = derivs(3,k) / scale(nvar) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## program minirot -- low storage BFGS torsional optimizer ## c ## ## c ################################################################# c c c "minirot" performs an energy minimization in torsional c angle space using a low storage BFGS nonlinear optimization c c program minirot use files use inform use iounit use math use omega use scales use zcoord implicit none integer i,imin integer freeunit real*8 minimum,minirot1 real*8 grdmin,grms,gnorm real*8, allocatable :: xx(:) real*8, allocatable :: derivs(:) logical exist character*240 minfile character*240 string external minirot1 external optsave c c c set up the molecular mechanics calculation c call initial call getint call mechanic c c perform the setup functions needed for optimization c call optinit call initrot c c get termination criterion as RMS torsional gradient c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) grdmin 10 continue if (grdmin .le. 0.0d0) then write (iout,20) 20 format (/,' Enter RMS Gradient per Torsion Criterion', & ' [0.01] : ',$) read (input,30) grdmin 30 format (f20.0) end if if (grdmin .eq. 0.0d0) grdmin = 0.01d0 c c write out a copy of coordinates for later update c imin = freeunit () minfile = filename(1:leng)//'.int' call version (minfile,'new') open (unit=imin,file=minfile,status='new') call prtint (imin) close (unit=imin) outfile = minfile c c perform dynamic allocation of some global arrays c if (.not. allocated(scale)) allocate (scale(nomega)) c c set scaling parameter for function and derivative values; c use square root of median eigenvalue of typical Hessian c set_scale = .true. do i = 1, nomega scale(i) = 5.0d0 end do c c perform dynamic allocation of some local arrays c allocate (xx(nomega)) c c convert dihedral angles to optimization parameters c do i = 1, nomega xx(i) = dihed(i) * scale(i) end do c c make the call to the optimization routine c call lbfgs (nomega,xx,minimum,grdmin,minirot1,optsave) c c convert optimization parameters to dihedral angles c do i = 1, nomega dihed(i) = xx(i) / scale(i) ztors(zline(i)) = dihed(i) * radian end do c c perform deallocation of some local arrays c deallocate (xx) c c perform dynamic allocation of some local arrays c allocate (derivs(nomega)) c c compute the final function and RMS gradient values c call gradrot (minimum,derivs) gnorm = 0.0d0 do i = 1, nomega gnorm = gnorm + derivs(i)**2 end do gnorm = sqrt(gnorm) grms = gnorm / sqrt(dble(nomega)) c c perform deallocation of some local arrays c 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,40) minimum,grms,gnorm 40 format (/,' Final Function Value :',2x,f20.8, & /,' Final RMS Gradient :',4x,f20.8, & /,' Final Gradient Norm :',3x,f20.8) else write (iout,50) minimum,grms,gnorm 50 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,60) minimum,grms,gnorm 60 format (/,' Final Function Value :',2x,f18.6, & /,' Final RMS Gradient :',4x,f18.6, & /,' Final Gradient Norm :',3x,f18.6) else write (iout,70) minimum,grms,gnorm 70 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,80) minimum,grms,gnorm 80 format (/,' Final Function Value :',2x,f16.4, & /,' Final RMS Gradient :',4x,f16.4, & /,' Final Gradient Norm :',3x,f16.4) else write (iout,90) minimum,grms,gnorm 90 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 prtint (imin) close (unit=imin) c c perform any final tasks before program exit c call final end c c c ############################################################## c ## ## c ## function minirot1 -- energy and gradient for minirot ## c ## ## c ############################################################## c c c "minirot1" is a service routine that computes the energy c and gradient for a low storage BFGS nonlinear optimization c in torsional angle space c c function minirot1 (xx,g) use math use omega use scales use zcoord implicit none integer i real*8 minirot1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:) c c c convert optimization parameters to dihedral angles c do i = 1, nomega dihed(i) = xx(i) / scale(i) ztors(zline(i)) = dihed(i) * radian end do c c perform dynamic allocation of some local arrays c allocate (derivs(nomega)) c c get coordinates, then compute energy and gradient c call makexyz call gradrot (e,derivs) minirot1 = e c c convert gradient components to optimization parameters c do i = 1, nomega g(i) = derivs(i) / scale(i) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ################################################### c ## COPYRIGHT (C) 1999 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## program minrigid -- low store BFGS rigid body optimizer ## c ## ## c ################################################################# c c c "minrigid" performs an energy minimization of rigid body atom c groups using a low storage BFGS nonlinear optimization c c program minrigid use files use group use inform use iounit use output use rigid implicit none integer i,j integer imin,nvar integer freeunit real*8 minimum,minrigid1 real*8 grdmin,grms,gnorm real*8, allocatable :: xx(:) real*8, allocatable :: derivs(:,:) logical exist character*240 minfile character*240 string external minrigid1 external optsave c c c set up the molecular mechanics calculation c call initial call getxyz call mechanic c c set up the use of rigid body coordinate system c coordtype = 'RIGIDBODY' use_rigid = .true. call orient c c perform the setup functions needed for optimization c call optinit c c get termination criterion as RMS rigid body gradient c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) grdmin 10 continue if (grdmin .le. 0.0d0) then write (iout,20) 20 format (/,' Enter RMS Gradient per Rigid Body Criterion', & ' [0.01] : ',$) read (input,30) grdmin 30 format (f20.0) end if if (grdmin .eq. 0.0d0) grdmin = 0.01d0 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(6*ngrp)) c c convert rigid body coordinates to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 xx(nvar) = rbc(j,i) end do end do c c make the call to the optimization routine c call lbfgs (nvar,xx,minimum,grdmin,minrigid1,optsave) c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c perform deallocation of some local arrays c deallocate (xx) c c perform dynamic allocation of some local arrays c allocate (derivs(6,ngrp)) c c compute the final function and RMS gradient values c call gradrgd (minimum,derivs) gnorm = 0.0d0 do i = 1, ngrp do j = 1, 6 gnorm = gnorm + derivs(j,i)**2 end do end do gnorm = sqrt(gnorm) grms = gnorm / sqrt(dble(ngrp)) c c perform deallocation of some local arrays c 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,40) minimum,grms,gnorm 40 format (/,' Final Function Value :',2x,f20.8, & /,' Final RMS Gradient :',4x,f20.8, & /,' Final Gradient Norm :',3x,f20.8) else write (iout,50) minimum,grms,gnorm 50 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,60) minimum,grms,gnorm 60 format (/,' Final Function Value :',2x,f18.6, & /,' Final RMS Gradient :',4x,f18.6, & /,' Final Gradient Norm :',3x,f18.6) else write (iout,70) minimum,grms,gnorm 70 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,80) minimum,grms,gnorm 80 format (/,' Final Function Value :',2x,f16.4, & /,' Final RMS Gradient :',4x,f16.4, & /,' Final Gradient Norm :',3x,f16.4) else write (iout,90) minimum,grms,gnorm 90 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 ## function minrigid1 -- energy and gradient for minrigid ## c ## ## c ################################################################ c c c "minrigid1" is a service routine that computes the energy c and gradient for a low storage BFGS nonlinear optimization c of rigid bodies c c function minrigid1 (xx,g) use group use math use rigid implicit none integer i,j,nvar real*8 minrigid1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) c c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c perform dynamic allocation of some local arrays c allocate (derivs(6,ngrp)) c c compute and store the energy and gradient c call rigidxyz call gradrgd (e,derivs) minrigid1 = e c c convert rigid body gradient to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 g(nvar) = derivs(j,i) end do end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ################################################### c ## COPYRIGHT (C) 1995 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## program mol2xyz -- Tripos MOL2 to Cartesian coordinates ## c ## ## c ################################################################# c c c "mol2xyz" takes as input a Tripos MOL2 coordinates file, c converts to and then writes out Cartesian coordinates c c program mol2xyz use files use iounit use titles implicit none integer ixyz,freeunit character*240 xyzfile c c c get and read the Tripos MOL2 format file c call initial call getmol2 write (iout,10) title(1:ltitle) 10 format (/,' Title : ',a) c c write out the Cartesian coordinates file c ixyz = freeunit () xyzfile = filename(1:leng)//'.xyz' call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') call prtxyz (ixyz) close (unit=ixyz) 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 molcul -- individual molecules in current system ## c ## ## c ################################################################# c c c nmol total number of separate molecules in the system c imol first and last atom of each molecule in the list c kmol contiguous list of the atoms in each molecule c molcule number of the molecule to which each atom belongs c totmass total weight of all the molecules in the system c molmass molecular weight for each molecule in the system c c module molcul implicit none integer nmol integer, allocatable :: imol(:,:) integer, allocatable :: kmol(:) integer, allocatable :: molcule(:) real*8 totmass real*8, allocatable :: molmass(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module moldyn -- MD trajectory velocity & acceleration ## c ## ## c ################################################################ c c c v current velocity of each atom along the x,y,z-axes c a current acceleration of each atom along x,y,z-axes c aalt alternate acceleration of each atom along x,y,z-axes c c module moldyn implicit none real*8, allocatable :: v(:,:) real*8, allocatable :: a(:,:) real*8, allocatable :: aalt(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################## c ## ## c ## subroutine molecule -- assign atoms to molecules ## c ## ## c ########################################################## c c c "molecule" counts the molecules, assigns each atom to c its molecule and computes the mass of each molecule c c subroutine molecule use atomid use atoms use couple use molcul implicit none integer i,j,k,ii integer mi,mj,mk integer, allocatable :: list(:) c c c perform dynamic allocation of some global arrays c if (allocated(imol)) deallocate (imol) if (allocated(kmol)) deallocate (kmol) if (allocated(molcule)) deallocate (molcule) if (allocated(molmass)) deallocate (molmass) allocate (imol(2,n)) allocate (kmol(n)) allocate (molcule(n)) allocate (molmass(n)) c c zero number of molecules and molecule membership list c nmol = 0 do i = 1, n molcule(i) = 0 end do c c assign each atom to its respective molecule c do i = 1, n if (molcule(i) .eq. 0) then nmol = nmol + 1 molcule(i) = nmol end if mi = molcule(i) do ii = 1, n12(i) j = i12(ii,i) mj = molcule(j) if (mj .eq. 0) then molcule(j) = mi else if (mi .lt. mj) then nmol = nmol - 1 do k = 1, n mk = molcule(k) if (mk .eq. mj) then molcule(k) = mi else if (mk .gt. mj) then molcule(k) = mk - 1 end if end do else if (mi .gt. mj) then nmol = nmol - 1 do k = 1, n mk = molcule(k) if (mk .eq. mi) then molcule(k) = mj else if (mk .gt. mi) then molcule(k) = mk - 1 end if end do mi = mj end if end do end do c c perform dynamic allocation of some local arrays c allocate (list(n)) c c pack atoms of each molecule into a contiguous indexed list c do i = 1, n list(i) = molcule(i) end do call sort3 (n,list,kmol) c c find the first and last atom in each molecule c k = 1 imol(1,1) = 1 do i = 2, n j = list(i) if (j .ne. k) then imol(2,k) = i - 1 k = j imol(1,k) = i end if end do imol(2,nmol) = n c c perform deallocation of some local arrays c deallocate (list) c c sort the list of atoms in each molecule by atom number c do i = 1, nmol k = imol(2,i) - imol(1,i) + 1 call sort (k,kmol(imol(1,i))) end do c c if all atomic masses are zero, set them all to unity c do i = 1, n if (mass(i) .ne. 0.0d0) goto 10 end do do i = 1, n mass(i) = 1.0d0 end do 10 continue c c compute the mass of each molecule and the total mass c totmass = 0.0d0 do i = 1, nmol molmass(i) = 0.0d0 do k = imol(1,i), imol(2,i) molmass(i) = molmass(i) + mass(kmol(k)) end do totmass = totmass + molmass(i) end do return end c c c ################################################### c ## COPYRIGHT (C) 2012 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## program molxyz -- MDL MOL file to Cartesian coordinates ## c ## ## c ################################################################# c c c "molxyz" takes as input a MDL MOL coordinates file, c converts to and then writes out Cartesian coordinates c c program molxyz use files use iounit use titles implicit none integer ixyz,freeunit character*240 xyzfile c c c get and read the MDL MOL format file c call initial call getmol write (iout,10) title(1:ltitle) 10 format (/,' Title : ',a) c c write out the Cartesian coordinates file c ixyz = freeunit () xyzfile = filename(1:leng)//'.xyz' call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') call prtxyz (ixyz) close (unit=ixyz) 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 moment -- electric multipole moment components ## c ## ## c ############################################################### c c c netchg net electric charge for the total system c netdpl dipole moment magnitude for the total system c netqpl diagonal quadrupole (Qxx, Qyy, Qzz) for total system c xdpl total dipole vector x-component in the global frame c ydpl total dipole vector y-component in the global frame c zdpl total dipole vector z-component in the global frame c xxqpl total quadrupole tensor xx-component in global frame c xyqpl total quadrupole tensor xy-component in global frame c xzqpl total quadrupole tensor xz-component in global frame c yxqpl total quadrupole tensor yx-component in global frame c yyqpl total quadrupole tensor yy-component in global frame c yzqpl total quadrupole tensor yz-component in global frame c zxqpl total quadrupole tensor zx-component in global frame c zyqpl total quadrupole tensor zy-component in global frame c zzqpl total quadrupole tensor zz-component in global frame c c module moment implicit none real*8 netchg,netdpl real*8 netqpl(3) real*8 xdpl,ydpl,zdpl real*8 xxqpl,xyqpl,xzqpl real*8 yxqpl,yyqpl,yzqpl real*8 zxqpl,zyqpl,zzqpl save end c c c ################################################### c ## COPYRIGHT (C) 2000 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine moments -- total electric multipole moments ## c ## ## c ################################################################ c c c "moments" computes the total electric charge, dipole components c and quadrupole components as a sum over the partial charges, c bond dipoles and atomic multipole moments over active atoms or c the full system c c literature reference: c c C. Gray and K. E. Gubbins, "Theory of Molecular Fluids, Volume 1: c Fundamentals", Oxford University Press, (1984) [factor of 3/2 in c conversion of traced to traceless quadrupoles; pages 50-51] c c subroutine moments (mode) use atomid use atoms use bound use charge use dipole use limits use moment use mpole use polar use potent use rigid use solpot use units use usage implicit none integer i,j,k real*8 xc,yc,zc real*8 xi,yi,zi,ri real*8 weigh,trace real*8 xmid,ymid,zmid real*8 xbnd,ybnd,zbnd real*8, allocatable :: xcm(:) real*8, allocatable :: ycm(:) real*8, allocatable :: zcm(:) real*8 a(3,3),b(3,3) logical, allocatable :: temp(:) character*6 mode c c c zero out total charge, dipole and quadrupole components c netchg = 0.0d0 netdpl = 0.0d0 netqpl(1) = 0.0d0 netqpl(2) = 0.0d0 netqpl(3) = 0.0d0 xdpl = 0.0d0 ydpl = 0.0d0 zdpl = 0.0d0 xxqpl = 0.0d0 xyqpl = 0.0d0 xzqpl = 0.0d0 yxqpl = 0.0d0 yyqpl = 0.0d0 yzqpl = 0.0d0 zxqpl = 0.0d0 zyqpl = 0.0d0 zzqpl = 0.0d0 c c perform dynamic allocation of some local arrays c if (mode .eq. 'FULL') allocate (temp(n)) c c store active atom list, and make all atoms active c if (mode.eq.'FULL' .and. nuse.ne.n) then do i = 1, n temp(i) = use(i) use(i) = .true. end do end if c c maintain periodic boundaries and neighbor lists c if (use_bounds .and. .not.use_rigid) call bounds if (use_clist .or. use_mlist) call nblist c c perform dynamic allocation of some local arrays c allocate (xcm(n)) allocate (ycm(n)) allocate (zcm(n)) c c find the center of mass of the set of active atoms c weigh = 0.0d0 xmid = 0.0d0 ymid = 0.0d0 zmid = 0.0d0 do i = 1, n if (use(i)) then weigh = weigh + mass(i) xmid = xmid + x(i)*mass(i) ymid = ymid + y(i)*mass(i) zmid = zmid + z(i)*mass(i) end if end do if (weigh .ne. 0.0d0) then xmid = xmid / weigh ymid = ymid / weigh zmid = zmid / weigh end if do i = 1, n xcm(i) = x(i) - xmid ycm(i) = y(i) - ymid zcm(i) = z(i) - zmid end do c c alter partial charges and monopoles via charge flux c if (use_chgflx) call alterchg c c set the multipole moment components due to partial charges c do i = 1, nion k = iion(i) if (use(k)) then netchg = netchg + pchg(k) xdpl = xdpl + xcm(k)*pchg(k) ydpl = ydpl + ycm(k)*pchg(k) zdpl = zdpl + zcm(k)*pchg(k) xxqpl = xxqpl + xcm(k)*xcm(k)*pchg(k) xyqpl = xyqpl + xcm(k)*ycm(k)*pchg(k) xzqpl = xzqpl + xcm(k)*zcm(k)*pchg(k) yxqpl = yxqpl + ycm(k)*xcm(k)*pchg(k) yyqpl = yyqpl + ycm(k)*ycm(k)*pchg(k) yzqpl = yzqpl + ycm(k)*zcm(k)*pchg(k) zxqpl = zxqpl + zcm(k)*xcm(k)*pchg(k) zyqpl = zyqpl + zcm(k)*ycm(k)*pchg(k) zzqpl = zzqpl + zcm(k)*zcm(k)*pchg(k) end if end do c c set the multipole moment components due to bond dipoles c do i = 1, ndipole j = idpl(1,i) k = idpl(2,i) if (use(j) .or. use(k)) then xi = x(j) - x(k) yi = y(j) - y(k) zi = z(j) - z(k) ri = sqrt(xi*xi + yi*yi + zi*zi) xbnd = bdpl(i) * (xi/ri) / debye ybnd = bdpl(i) * (yi/ri) / debye zbnd = bdpl(i) * (zi/ri) / debye xc = x(j) - xi*sdpl(i) yc = y(j) - yi*sdpl(i) zc = z(j) - zi*sdpl(i) xdpl = xdpl + xbnd ydpl = ydpl + ybnd zdpl = zdpl + zbnd xxqpl = xxqpl + 2.0d0*xc*xbnd xyqpl = xyqpl + xc*ybnd + yc*xbnd xzqpl = xzqpl + xc*zbnd + zc*xbnd yxqpl = yxqpl + yc*xbnd + xc*ybnd yyqpl = yyqpl + 2.0d0*yc*ybnd yzqpl = yzqpl + yc*zbnd + zc*ybnd zxqpl = zxqpl + zc*xbnd + xc*zbnd zyqpl = zyqpl + zc*ybnd + yc*zbnd zzqpl = zzqpl + 2.0d0*zc*zbnd end if end do c c find atomic multipoles and induced dipoles in global frame c if (use_born) call born call chkpole call rotpole ('MPOLE') call induce if (solvtyp.eq.'GK' .or. solvtyp.eq.'PB') then do i = 1, npole k = ipole(i) rpole(2,k) = rpole(2,k) + uinds(1,k) rpole(3,k) = rpole(3,k) + uinds(2,k) rpole(4,k) = rpole(4,k) + uinds(3,k) end do else do i = 1, npole k = ipole(i) rpole(2,k) = rpole(2,k) + uind(1,k) rpole(3,k) = rpole(3,k) + uind(2,k) rpole(4,k) = rpole(4,k) + uind(3,k) end do end if c c set the moment components due to atomic monopoles and dipoles c do i = 1, npole k = ipole(i) if (use(k)) then netchg = netchg + rpole(1,k) xdpl = xdpl + xcm(k)*rpole(1,k) + rpole(2,k) ydpl = ydpl + ycm(k)*rpole(1,k) + rpole(3,k) zdpl = zdpl + zcm(k)*rpole(1,k) + rpole(4,k) xxqpl = xxqpl + xcm(k)*xcm(k)*rpole(1,k) & + 2.0d0*xcm(k)*rpole(2,k) xyqpl = xyqpl + xcm(k)*ycm(k)*rpole(1,k) & + xcm(k)*rpole(3,k) + ycm(k)*rpole(2,k) xzqpl = xzqpl + xcm(k)*zcm(k)*rpole(1,k) & + xcm(k)*rpole(4,k) + zcm(k)*rpole(2,k) yxqpl = yxqpl + ycm(k)*xcm(k)*rpole(1,k) & + ycm(k)*rpole(2,k) + xcm(k)*rpole(3,k) yyqpl = yyqpl + ycm(k)*ycm(k)*rpole(1,k) & + 2.0d0*ycm(k)*rpole(3,k) yzqpl = yzqpl + ycm(k)*zcm(k)*rpole(1,k) & + ycm(k)*rpole(4,k) + zcm(k)*rpole(3,k) zxqpl = zxqpl + zcm(k)*xcm(k)*rpole(1,k) & + zcm(k)*rpole(2,k) + xcm(k)*rpole(4,k) zyqpl = zyqpl + zcm(k)*ycm(k)*rpole(1,k) & + zcm(k)*rpole(3,k) + ycm(k)*rpole(4,k) zzqpl = zzqpl + zcm(k)*zcm(k)*rpole(1,k) & + 2.0d0*zcm(k)*rpole(4,k) end if end do c c perform deallocation of some local arrays c deallocate (xcm) deallocate (ycm) deallocate (zcm) c c convert the quadrupole from traced to traceless form c trace = (xxqpl + yyqpl + zzqpl) / 3.0d0 xxqpl = 1.5d0 * (xxqpl-trace) xyqpl = 1.5d0 * xyqpl xzqpl = 1.5d0 * xzqpl yxqpl = 1.5d0 * yxqpl yyqpl = 1.5d0 * (yyqpl-trace) yzqpl = 1.5d0 * yzqpl zxqpl = 1.5d0 * zxqpl zyqpl = 1.5d0 * zyqpl zzqpl = 1.5d0 * (zzqpl-trace) c c add the traceless atomic quadrupoles to total quadrupole c do i = 1, npole k = ipole(i) if (use(k)) then xxqpl = xxqpl + 3.0d0*rpole(5,k) xyqpl = xyqpl + 3.0d0*rpole(6,k) xzqpl = xzqpl + 3.0d0*rpole(7,k) yxqpl = yxqpl + 3.0d0*rpole(8,k) yyqpl = yyqpl + 3.0d0*rpole(9,k) yzqpl = yzqpl + 3.0d0*rpole(10,k) zxqpl = zxqpl + 3.0d0*rpole(11,k) zyqpl = zyqpl + 3.0d0*rpole(12,k) zzqpl = zzqpl + 3.0d0*rpole(13,k) end if end do c c revert to the original set of active atoms c if (mode.eq.'FULL' .and. nuse.ne.n) then do i = 1, n use(i) = temp(i) end do end if c c perform deallocation of some local arrays c if (mode .eq. 'FULL') deallocate (temp) c c convert dipole to Debye and quadrupole to Buckingham c xdpl = xdpl * debye ydpl = ydpl * debye zdpl = zdpl * debye xxqpl = xxqpl * debye xyqpl = xyqpl * debye xzqpl = xzqpl * debye yxqpl = yxqpl * debye yyqpl = yyqpl * debye yzqpl = yzqpl * debye zxqpl = zxqpl * debye zyqpl = zyqpl * debye zzqpl = zzqpl * debye c c get dipole magnitude and diagonalize quadrupole tensor c netdpl = sqrt(xdpl*xdpl + ydpl*ydpl + zdpl*zdpl) a(1,1) = xxqpl a(1,2) = xyqpl a(1,3) = xzqpl a(2,1) = yxqpl a(2,2) = yyqpl a(2,3) = yzqpl a(3,1) = zxqpl a(3,2) = zyqpl a(3,3) = zzqpl call jacobi (3,a,netqpl,b) return end c c c ################################################################ c ## COPYRIGHT (C) 2001 by ## c ## Michael Schnieders, Alan Grossfield & Jay William Ponder ## c ## All Rights Reserved ## c ################################################################ c c ################################################################# c ## ## c ## program monte -- Monte Carlo-Minimization search method ## c ## ## c ################################################################# c c c "monte" performs a Monte Carlo-Minimization conformational c search using Cartesian single atom or torsional move sets c c literature references: c c Z. Li and H. A. Scheraga, "Monte Carlo-Minimization Approach c to the Multiple-Minima Problem in Protein Folding", Proc. Natl. c Acad. Sci. USA, 84, 6611-6615 (1987) c c D. J. Wales, "Energy Landscapes with Applications to Clusters, c Biomolecules and Glasses", Cambridge University Press, 2003, c Section 6.7.4 c c program monte use atoms use files use inform use iounit use omega use output use units use usage use zcoord implicit none integer i,k,m,next integer keep,nbig integer nmap,lext integer istep,nstep integer ixyz,freeunit real*8 global,ratio real*8 big,eps,size real*8 grdmin,temper real*8 minimum,pminimum real*8 tsize,factor real*8 beta,boltz real*8 random,trial real*8 converge,delta real*8 efficient real*8 vector(3) real*8, allocatable :: xg(:) real*8, allocatable :: yg(:) real*8, allocatable :: zg(:) real*8, allocatable :: xi(:) real*8, allocatable :: yi(:) real*8, allocatable :: zi(:) real*8, allocatable :: xp(:) real*8, allocatable :: yp(:) real*8, allocatable :: zp(:) logical exist,reset,done logical torsmove character*1 answer character*6 status character*7 ext character*240 xyzfile character*240 record character*240 string external random c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c initialize values of some counters and parameters c istep = 0 keep = 0 nbig = 0 nmap = 0 delta = 0.00001d0 eps = 0.0001d0 big = 100000.0d0 reset = .false. c c get the desired number of Monte Carlo steps c nstep = -1 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) nstep 10 continue if (nstep .le. 0) then write (iout,20) 20 format (/,' Maximum Number of Monte Carlo Steps [1000] : ', $) read (input,30) nstep 30 format (i10) if (nstep .le. 0) nstep = 1000 end if c c get the search efficiency criterion for convergence c converge = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=40,end=40) converge 40 continue if (converge .lt. 0.0d0) then write (iout,50) 50 format (/,' Enter Search Efficiency Termination Criterion', & ' [0.01] : ', $) read (input,60) string 60 format (a240) read (string,*,err=70,end=70) converge 70 continue if (converge .lt. 0.0d0) converge = 0.01 end if converge = converge + delta c c choose either the torsional or single atom move set c torsmove = .false. call nextarg (answer, exist) if (.not. exist) then write (iout,80) 80 format (/,' Use [C]artesian or [T]orsional Moves [C] : ',$) read (input,90) record 90 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'T') torsmove = .true. c c for torsional moves, generate the internal coordinates c if (torsmove) then call makeint (0) call initrot c c set all atoms active to simplify torsional calculation c nuse = n do i = 1, n use(i) = .true. end do end if c c get the desired Cartesian or torsional step size c size = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=100,end=100) size 100 continue if (size .lt. 0.0d0) then if (torsmove) then write (iout,110) 110 format (/,' Enter Maximum Step in Degrees [180.0] : ', $) else write (iout,120) 120 format (/,' Enter Maximum Step in Angstroms [3.0] : ', $) end if read (input,130) string 130 format (a240) read (string,*,err=140,end=140) size 140 continue if (size .lt. 0.0d0) then if (torsmove) then size = 180.0d0 else size = 3.0d0 end if end if if (torsmove) size = min(size,180.0d0) end if c c get the gradient convergence for local minimizations c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=150,end=150) grdmin 150 continue if (grdmin .lt. 0.0d0) then write (iout,160) 160 format (/,' Enter RMS Gradient Criterion for Minima', & ' [0.01] : ', $) read (input,170) string 170 format (a240) read (string,*,err=180,end=180) grdmin 180 continue if (grdmin .lt. 0.0d0) grdmin = 0.01 end if c c get the desired temperature for Metropolis criterion c temper = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=190,end=190) temper 190 continue if (temper .lt. 0.0d0) then write (iout,200) 200 format (/,' Enter the Desired Temperature in Degrees', & ' K [500] : ', $) read (input,210) string 210 format (a240) read (string,*,err=220,end=220) temper 220 continue if (temper .lt. 0.0d0) temper = 500.0d0 end if beta = 1.0d0 / (gasconst*temper) c c perform dynamic allocation of some local arrays c allocate (xg(n)) allocate (yg(n)) allocate (zg(n)) allocate (xi(n)) allocate (yi(n)) allocate (zi(n)) allocate (xp(n)) allocate (yp(n)) allocate (zp(n)) c c print some information prior to initial iteration c write (iout,230) 230 format (/,' Monte Carlo Minimization Global Search :') write (iout,240) 240 format (/,' MCM Iter Current Global', & ' Efficiency Accept Status',/) flush (iout) c c create and open an output file if using archive mode c if (archive) then ixyz = freeunit () xyzfile = filename(1:leng) call suffix (xyzfile,'arc','new') open (unit=ixyz,file=xyzfile,status='new') close (unit=ixyz) end if c c store the coordinates, then perform a minimization c do i = 1, n xi(i) = x(i) yi(i) = y(i) zi(i) = z(i) end do call mcmstep (minimum,grdmin) pminimum = minimum write (iout,250) 0,minimum 250 format (i8,3x,f12.4) c c save coordinates as the initial global minimum c do i = 1, n xg(i) = x(i) yg(i) = y(i) zg(i) = z(i) end do global = minimum nmap = nmap + 1 lext = 3 call numeral (nmap,ext,lext) ixyz = freeunit () if (archive) then xyzfile = filename(1:leng) call suffix (xyzfile,'arc','old') inquire (file=xyzfile,exist=exist) if (exist) then call openend (ixyz,xyzfile) else open (unit=ixyz,file=xyzfile,status='new') end if else xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') end if call prtxyz (ixyz) close (unit=ixyz) write (iout,260) nmap,global 260 format (/,4x,'Minimum Energy Structure',i7,6x,f16.4,/) call flush (iout) c c optionally reset coordinates to before the minimization c if (reset) then do i = 1, n x(i) = xi(i) y(i) = yi(i) z(i) = zi(i) end do end if if (torsmove) call makeint (2) c c store the prior coordinates to start each MCM iteration c done = .false. do while (.not. done) istep = istep + 1 do i = 1, n xp(i) = x(i) yp(i) = y(i) zp(i) = z(i) end do c c generate random angle moves for a few torsions c if (torsmove) then m = int(-log(max(random(),0.0001d0))) + 1 do i = 1, m k = int(nomega * random()) + 1 k = zline(k) tsize = 2.0d0 * size * (random()-0.5d0) ztors(k) = ztors(k) + tsize if (ztors(k) .gt. 180.0d0) then ztors(k) = ztors(k) - 360.0d0 else if (ztors(k) .lt. -180.0d0) then ztors(k) = ztors(k) + 360.0d0 end if end do call makexyz c c generate a random Cartesian move for each atom c else do i = 1, nuse k = iuse(i) call ranvec (vector) factor = size * random () x(k) = x(k) + factor*vector(1) y(k) = y(k) + factor*vector(2) z(k) = z(k) + factor*vector(3) end do end if c c store the coordinates, then perform a minimization c do i = 1, n xi(i) = x(i) yi(i) = y(i) zi(i) = z(i) end do call mcmstep (minimum,grdmin) c c test for an unreasonably low energy at the minimum c if (minimum .lt. -big) minimum = big c c step is probably degenerate if energy is identical c if (abs(minimum-pminimum) .le. eps) then status = 'Same' pminimum = minimum c c accept the step if the new minimum has lower energy c else if (minimum .le. pminimum) then status = 'Accept' pminimum = minimum c c if the energy increased, apply the Metropolis criterion c else boltz = exp(-beta*(minimum-pminimum)) trial = random () c c reject the step if the energy increase is too large c if (boltz .lt. trial) then status = 'Reject' c c accept the step if the energy increase is small enough c else status = 'Accept' pminimum = minimum end if end if c c save coordinates with the best energy as global minimum c if (minimum .lt. global-eps) then do i = 1, n xg(i) = x(i) yg(i) = y(i) zg(i) = z(i) end do global = minimum nmap = nmap + 1 lext = 3 call numeral (nmap,ext,lext) ixyz = freeunit () if (archive) then xyzfile = filename(1:leng) call suffix (xyzfile,'arc','old') inquire (file=xyzfile,exist=exist) if (exist) then call openend (ixyz,xyzfile) else open (unit=ixyz,file=xyzfile,status='new') end if else xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') end if call prtxyz (ixyz) close (unit=ixyz) write (iout,270) nmap,global 270 format (/,4x,'Minimum Energy Structure',i7,6x,f16.4,/) flush (iout) end if c c update the efficiency and Monte Carlo acceptance ratio c efficient = dble(nmap) / dble(istep) if (status .eq. 'Accept') keep = keep + 1 ratio = dble(keep) / dble(istep) c c print intermediate results for the current iteration c if (istep.ne.1 .and. mod(istep,100).eq.1) then write (iout,280) 280 format (/,' MCM Iter Current Global', & ' Efficiency Accept Status',/) end if if (minimum .lt. big) then nbig = 0 write (iout,290) istep,minimum,global,efficient, & ratio,status 290 format (i8,3x,f12.4,3x,f12.4,3x,f9.4,3x,f9.4,6x,a6) else nbig = nbig + 1 write (iout,300) istep,global,efficient,ratio,status 300 format (i8,9x,'------',3x,f12.4,3x,f9.4,3x,f9.4,6x,a6) end if flush (iout) c c restore global minimum after repeated bad iterations c if (nbig .ge. 3) then nbig = 0 do i = 1, n x(i) = xg(i) y(i) = yg(i) z(i) = zg(i) end do c c optionally reset coordinates to before the minimization c else if (status.eq.'Same' .or. status.eq.'Accept') then if (reset) then do i = 1, n x(i) = xi(i) y(i) = yi(i) z(i) = zi(i) end do end if c c restore coordinates to those from the previous iteration c else if (status .eq. 'Reject') then do i = 1, n x(i) = xp(i) y(i) = yp(i) z(i) = zp(i) end do end if c c update internal coordinates if using torsional moves c if (torsmove) call makeint (2) c c check criteria based on search efficiency and step number c if (efficient .le. converge) then done = .true. write (iout,310) 310 format (/,' MONTE -- Termination based on Overall', & ' Search Efficiency') end if if (istep .ge. nstep) then done = .true. write (iout,320) 320 format (/,' MONTE -- Termination based on Maximum', & ' MCM Step Limit') end if end do c c perform deallocation of some local arrays c deallocate (xg) deallocate (yg) deallocate (zg) deallocate (xi) deallocate (yi) deallocate (zi) deallocate (xp) deallocate (yp) deallocate (zp) c c write out the final global minimum energy value c if (digits .ge. 8) then write (iout,330) global 330 format (/,' Global Minimum Energy Value :',2x,f18.8) else if (digits .ge. 6) then write (iout,340) global 340 format (/,' Global Minimum Energy Value :',4x,f16.6) else write (iout,350) global 350 format (/,' Global Minimum Energy Value :',6x,f14.4) end if c c perform any final tasks before program exit c call final end c c c ############################################################### c ## ## c ## function mcmstep -- minimization phase of an MCM step ## c ## ## c ############################################################### c c c "mcmstep" implements the minimization phase of an MCM step c via Cartesian minimization following a Monte Carlo step c c subroutine mcmstep (minimum,grdmin) use atoms use bound use files use inform use output use potent use usage implicit none integer i,k,nvar real*8 mcm1,minimum,grdmin real*8, allocatable :: xx(:) character*6 mode,method external mcm1,mcm2,optsave c c c prepare for the truncated Newton minimization c mode = 'AUTO' method = 'AUTO' verbose = .false. iprint = 0 iwrite = 0 coordtype = 'CARTESIAN' c c perform dynamic allocation of some local arrays c allocate (xx(3*n)) c c convert atomic coordinates to optimization parameters c nvar = 0 do i = 1, nuse 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 make the call to the optimization routine c call tncg (mode,method,nvar,xx,minimum,grdmin, & mcm1,mcm2,optsave) 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 maintain any periodic boundary conditions c if (use_bounds) call bounds c c perform deallocation of some local arrays c deallocate (xx) return end c c c ############################################################# c ## ## c ## function mcm1 -- energy and gradient for MCM search ## c ## ## c ############################################################# c c c "mcm1" is a service routine that computes the energy and c gradient for truncated Newton optimization in Cartesian c coordinate space c c function mcm1 (xx,g) use atoms use usage implicit none integer i,k,nvar real*8 mcm1,e real*8 xx(*) real*8 g(*) 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 perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute and store the energy and gradient c call gradient (e,derivs) mcm1 = e c c store gradient components to optimization parameters c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 g(nvar) = derivs(1,k) nvar = nvar + 1 g(nvar) = derivs(2,k) nvar = nvar + 1 g(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 mcm2 -- Hessian values for MCM search ## c ## ## c ########################################################## c c c "mcm2" is a service routine that computes the sparse matrix c Hessian elements for truncated Newton optimization in Cartesian c coordinate space c c subroutine mcm2 (mode,xx,h,hinit,hstop,hindex,hdiag) use atoms use usage implicit none integer i,j,k,nvar integer hinit(*) integer hstop(*) integer hindex(*) integer, allocatable :: hvar(:) integer, allocatable :: huse(:) real*8 xx(*) real*8 hdiag(*) real*8 h(*) character*4 mode c c c convert optimization parameters to atomic coordinates c if (mode .eq. 'NONE') return 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 compute and store the Hessian elements c call hessian (h,hinit,hstop,hindex,hdiag) c c perform dynamic allocation of some local arrays c allocate (hvar(nvar)) allocate (huse(3*n)) c c transform the sparse Hessian to use only active atoms c nvar = 0 if (nuse .ne. n) then do i = 1, n k = 3 * (i-1) if (use(i)) then do j = 1, 3 nvar = nvar + 1 hvar(nvar) = j + k huse(j+k) = nvar end do else do j = 1, 3 huse(j+k) = 0 end do end if end do do i = 1, nvar k = hvar(i) hinit(i) = hinit(k) hstop(i) = hstop(k) hdiag(i) = hdiag(k) do j = hinit(i), hstop(i) hindex(j) = huse(hindex(j)) end do end do end if c c convert atomic coordinates to optimization parameters c nvar = 0 do i = 1, nuse 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 deallocation of some local arrays c deallocate (hvar) deallocate (huse) return end c c c ################################################### c ## COPYRIGHT (C) 2001 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## module mplpot -- multipole functional form details ## c ## ## c ############################################################ c c c m2scale scale factor for 1-2 multipole energy interactions c m3scale scale factor for 1-3 multipole energy interactions c m4scale scale factor for 1-4 multipole energy interactions c m5scale scale factor for 1-5 multipole energy interactions c use_chgpen flag to use charge penetration damped potential c pentyp type of penetration damping (NONE, GORDON1, GORDON2) c c module mplpot implicit none real*8 m2scale,m3scale real*8 m4scale,m5scale logical use_chgpen character*7 pentyp save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module mpole -- atomic multipoles in current structure ## c ## ## c ################################################################ c c c maxpole max components (monopole=1,dipole=4,quadrupole=13) c c npole total number of multipole sites in the system c ipole number of the atom for each multipole site c polsiz number of multipole components for each atom c pollist multipole site for each atom (0=no multipole) c zaxis number of the z-axis defining atom for each atom c xaxis number of the x-axis defining atom for each atom c yaxis number of the y-axis defining atom for each atom c pole local frame Cartesian multipoles for each atom c rpole global frame Cartesian multipoles for each atom c mono0 original atomic monopole values for charge flux c polaxe local coordinate frame type for each atom c c module mpole implicit none integer maxpole parameter (maxpole=13) integer npole integer, allocatable :: ipole(:) integer, allocatable :: polsiz(:) integer, allocatable :: pollist(:) integer, allocatable :: zaxis(:) integer, allocatable :: xaxis(:) integer, allocatable :: yaxis(:) real*8, allocatable :: pole(:,:) real*8, allocatable :: rpole(:,:) real*8, allocatable :: mono0(:) character*8, allocatable :: polaxe(:) save end c c c ################################################### c ## COPYRIGHT (C) 2015 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module mrecip -- reciprocal PME for permanent multipoles ## c ## ## c ################################################################## c c c vmxx scalar sum xx-component of virial due to multipoles c vmyy scalar sum yy-component of virial due to multipoles c vmzz scalar sum zz-component of virial due to multipoles c vmxy scalar sum xy-component of virial due to multipoles c vmxz scalar sum xz-component of virial due to multipoles c vmyz scalar sum yz-component of virial due to multipoles c cmp Cartesian permenent multipoles as polytensor vector c fmp fractional permanent multipoles as polytensor vector c cphi Cartesian permanent multipole potential and field c fphi fractional permanent multipole potential and field c c module mrecip implicit none real*8 vmxx,vmyy,vmzz real*8 vmxy,vmxz,vmyz real*8, allocatable :: cmp(:,:) real*8, allocatable :: fmp(:,:) real*8, allocatable :: cphi(:,:) real*8, allocatable :: fphi(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module mutant -- free energy calculation hybrid atoms ## c ## ## c ############################################################### c c c nmut number of atoms mutated from initial to final state c vcouple van der Waals lambda type (0=decouple, 1=annihilate) c imut atom sites differing in initial and final state c type0 atom type of each atom in the initial state system c class0 atom class of each atom in the initial state system c type1 atom type of each atom in the final state system c class1 atom class of each atom in the final state system c lambda generic weighting between initial and final states c vlambda state weighting value for van der Waals potentials c elambda state weighting value for electrostatic potentials c tlambda state weighting value for torsional potential c scexp scale factor for soft core buffered 14-7 potential c scalpha scale factor for soft core buffered 14-7 potential c mut true if an atom is to be mutated, false otherwise c c module mutant implicit none integer nmut integer vcouple integer, allocatable :: imut(:) integer, allocatable :: type0(:) integer, allocatable :: class0(:) integer, allocatable :: type1(:) integer, allocatable :: class1(:) real*8 lambda real*8 vlambda real*8 elambda real*8 tlambda real*8 scexp real*8 scalpha logical, allocatable :: mut(:) save end c c c ############################################################## c ## COPYRIGHT (C) 2009 by Chuanjie Wu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ############################################################### c ## ## c ## subroutine mutate -- set parameters for hybrid system ## c ## ## c ############################################################### c c c "mutate" constructs the hybrid hamiltonian for a specified c initial state, final state and mutation parameter "lambda" c c note torsional and most electrostatics terms apply "lambda" c by directly scaling parameters, while vdw and repulsion energy c terms use soft core functions from the references cited below c c literature references: c c T. Steinbrecher, D. L. Mobley and D. A. Case, "Nonlinear Scaling c Schemes for Lennard-Jones Interactions in Free Energy c Calculations", Journal of Chemical Physics, 127, 214108 (2007) c c D. Jiao, P. A. Golubkov, T. A. Darden and P. Ren, "Calculation c of Protein-Ligand Binding Free Energy by Using a Polarizable c Potential", PNAS, 105, 6290-6295 (2008) c c subroutine mutate use atomid use atoms use bndstr use inform use iounit use katoms use keys use mutant use potent implicit none integer i,j,k,ihyb integer it0,it1 integer next,size integer ntbnd integer, allocatable :: list(:) integer, allocatable :: itbnd(:,:) character*20 keyword character*240 record character*240 string c c c perform dynamic allocation of some global arrays c if (allocated(imut)) deallocate (imut) if (allocated(type0)) deallocate (type0) if (allocated(class0)) deallocate (class0) if (allocated(type1)) deallocate (type1) if (allocated(class1)) deallocate (class1) if (allocated(mut)) deallocate (mut) allocate (imut(n)) allocate (type0(n)) allocate (class0(n)) allocate (type1(n)) allocate (class1(n)) allocate (mut(n)) c c perform dynamic allocation of some local arrays c size = 40 allocate (list(size)) allocate (itbnd(2,nbond)) c c set defaults for lambda perturbation scaling values c lambda = 1.0d0 vlambda = 1.0d0 elambda = 1.0d0 tlambda = 1.0d0 c c set defaults for vdw coupling type and soft core vdw c vcouple = 0 scexp = 5.0d0 scalpha = 0.7d0 c c zero out number of hybrid atoms and mutated torsions c nmut = 0 do i = 1, n mut(i) = .false. end do ntbnd = 0 do i = 1, nbond itbnd(1,i) = 0 itbnd(2,i) = 0 end do c c search keywords for free energy perturbation options c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:7) .eq. 'LAMBDA ') then string = record(next:240) read (string,*,err=30) lambda else if (keyword(1:11) .eq. 'VDW-LAMBDA ') then string = record(next:240) read (string,*,err=30) vlambda else if (keyword(1:11) .eq. 'ELE-LAMBDA ') then string = record(next:240) read (string,*,err=30) elambda else if (keyword(1:12) .eq. 'TORS-LAMBDA ') then string = record(next:240) read (string,*,err=30) tlambda else if (keyword(1:15) .eq. 'VDW-ANNIHILATE ') then vcouple = 1 else if (keyword(1:7) .eq. 'MUTATE ') then string = record(next:240) read (string,*,err=30) ihyb,it0,it1 nmut = nmut + 1 imut(nmut) = ihyb mut(ihyb) = .true. type0(nmut) = it0 type1(nmut) = it1 class0(nmut) = atmcls(it0) class1(nmut) = atmcls(it1) else if (keyword(1:7) .eq. 'LIGAND ') then do k = 1, size list(k) = 0 end do string = record(next:240) read (string,*,err=10,end=10) (list(k),k=1,size) 10 continue k = 1 do while (list(k) .ne. 0) if (list(k).gt.0 .and. list(k).le.n) then j = list(k) nmut = nmut + 1 imut(nmut) = j mut(j) = .true. type0(nmut) = 0 type1(nmut) = type(j) class0(nmut) = 0 class1(nmut) = class(j) k = k + 1 else do j = max(1,abs(list(k))), min(n,abs(list(k+1))) nmut = nmut + 1 imut(nmut) = j mut(j) = .true. type0(nmut) = 0 type1(nmut) = type(i) class0(nmut) = 0 class1(nmut) = class(i) end do k = k + 2 end if end do else if (keyword(1:15) .eq. 'ROTATABLE-BOND ') then do k = 1, size list(k) = 0 end do string = record(next:240) read (string,*,err=20,end=20) (list(k),k=1,size) 20 continue k = 1 do while (list(k) .ne. 0) ntbnd = ntbnd + 1 itbnd(1,ntbnd) = list(k) itbnd(2,ntbnd) = list(k+1) k = k + 2 end do end if 30 continue end do c c scale electrostatic parameter values based on lambda c if (elambda.ge.0.0d0 .and. elambda.lt.1.0d0) then call altelec end if c c scale torsional parameter values based on lambda c if (tlambda.ge.0.0d0 .and. tlambda.lt.1.0d0) then if (ntbnd .ne. 0) call alttors (ntbnd,itbnd) end if c c scale implicit solvation parameter values based on lambda c if (elambda.ge.0.0d0 .and. elambda.lt.1.0d0) then call altsolv end if c c turn off hybrid potentials if no sites are mutated c use_mutate = .true. if (nmut .eq. 0) use_mutate = .false. c c write status of current hybrid potential lambda values c if (use_mutate .and. .not.silent) then write (iout,40) vlambda 40 format (/,' Free Energy Perturbation :',f15.3, & ' Lambda for van der Waals') write (iout,50) elambda 50 format (' Free Energy Perturbation :',f15.3, & ' Lambda for Electrostatics') write (iout,60) tlambda 60 format (' Free Energy Perturbation :',f15.3, & ' Lambda for Torsional Angles') end if c c perform deallocation of some local arrays c deallocate (list) deallocate (itbnd) return end c c c ################################################################ c ## ## c ## subroutine altelec -- mutated electrostatic parameters ## c ## ## c ################################################################ c c c "altelec" constructs mutated electrostatic parameters based c on the lambda mutation parameter "elambda" c c note charge transfer electrostatics is not treated by parameter c scaling due to the functional form used, and must be done via c modification of pairwise energy terms in the potential routines c c subroutine altelec use angbnd use atoms use bndstr use cflux use charge use chgpen use dipole use mplpot use mpole use mutant use polar use potent implicit none integer i,j,k integer k1,k2 integer ia,ib,ic c c c set scaled parameters for partial charge models c if (use_charge) then do i = 1, nion k = iion(i) if (mut(k)) then pchg(k) = pchg(k) * elambda end if pchg0(k) = pchg(k) end do end if c c set scaled parameters for bond dipole models c if (use_dipole) then do i = 1, ndipole k1 = idpl(1,i) k2 = idpl(2,i) if (mut(k1) .or. mut(k2)) then bdpl(i) = bdpl(i) * elambda end if end do end if c c set scaled parameters for atomic multipole models c if (use_mpole) then do i = 1, npole k = ipole(i) if (mut(k)) then do j = 1, 13 pole(j,k) = pole(j,k) * elambda end do mono0(k) = pole(1,k) if (use_chgpen) then pcore(k) = pcore(k) * elambda pval(k) = pval(k) * elambda pval0(k) = pval(k) end if end if end do end if c c set scaled parameters for atomic polarizability models c if (use_polar) then do i = 1, npole k = ipole(i) if (mut(k)) then polarity(k) = polarity(k) * elambda if (elambda .eq. 0.0d0) douind(k) = .false. end if end do end if c c set scaled parameters for bond stretch charge flux c if (use_chgflx) then do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (mut(ia) .and. mut(ib)) then bflx(i) = bflx(i) * elambda end if end do end if c c set scaled parameters for angle bend charge flux c if (use_chgflx) then do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) if (mut(ia) .and. mut(ib) .and. mut(ic)) then aflx(1,i) = aflx(1,i) * elambda aflx(2,i) = aflx(2,i) * elambda abflx(1,i) = abflx(1,i) * elambda abflx(2,i) = abflx(2,i) * elambda end if end do end if return end c c c ############################################################ c ## ## c ## subroutine alttors -- mutated torsional parameters ## c ## ## c ############################################################ c c c "alttors" constructs mutated torsional parameters based c on the lambda mutation parameter "tlambda" c c subroutine alttors (ntbnd,itbnd) use mutant use potent use tors implicit none integer i,j integer ia,ib,ic,id integer kb,kc integer ntbnd integer itbnd(2,*) c c c set scaled parameters for specified rotatable bonds c if (use_tors) then do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) if (mut(ia) .and. mut(ib) .and. mut(ic) .and. mut(id)) then do j = 1, ntbnd kb = itbnd(1,j) kc = itbnd(2,j) if ((kb.eq.ib .and. kc.eq.ic) .or. & (kb.eq.ic .and. kc.eq.ib)) then tors1(1,i) = tors1(1,i) * tlambda tors2(1,i) = tors2(1,i) * tlambda tors3(1,i) = tors3(1,i) * tlambda tors4(1,i) = tors4(1,i) * tlambda tors5(1,i) = tors5(1,i) * tlambda tors6(1,i) = tors6(1,i) * tlambda end if end do end if end do end if return end c c c ############################################################ c ## ## c ## subroutine altsolv -- mutated solvation parameters ## c ## ## c ############################################################ c c c "altsolv" constructs mutated implicit solvation parameters c based on the lambda mutation parameter "elambda" c c subroutine altsolv use atoms use mutant use nonpol use potent use solute implicit none integer i c c c set scaled parameters for implicit solvation models c if (use_solv) then do i = 1, n if (mut(i)) then shct(i) = shct(i) * elambda radcav(i) = radcav(i) * elambda raddsp(i) = raddsp(i) * elambda epsdsp(i) = epsdsp(i) * elambda cdsp(i) = cdsp(i) * elambda end if end do end if return end c c c ############################################################### c ## COPYRIGHT (C) 2006 by David Gohara & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################### c c ############################################################### c ## ## c ## subroutine nblist -- maintain pairwise neighbor lists ## c ## ## c ############################################################### c c c "nblist" builds and maintains nonbonded pair neighbor lists c for vdw, dispersion, electrostatic and polarization terms c c subroutine nblist use limits use neigh use potent implicit none c c c rebuild list if using both vdw and dispersion terms c if (use_vdw .and. use_disp) then dovlst = .true. dodlst = .true. end if c c rebuild list if using both charge and multipole terms c if (use_charge .and. use_mpole) then doclst = .true. domlst = .true. end if c c update the appropriate nonbonded neighbor lists c if (use_vdw .and. use_vlist) call vlist if (use_disp .and. use_dlist) call dlist if ((use_charge.or.use_solv) .and. use_clist) call clist if ((use_repel.or.use_mpole.or.use_polar & .or.use_chgtrn.or.use_solv) .and. use_mlist) call mlist if (use_polar .and. use_ulist) call ulist return end c c c ############################################################## c ## ## c ## subroutine vlist -- get van der Waals neighbor lists ## c ## ## c ############################################################## c c c "vlist" performs an update or a complete rebuild of the c nonbonded neighbor lists for vdw sites c c subroutine vlist use atoms use bound use boxes use iounit use neigh use vdw implicit none integer i,j,k integer ii,kk,iv real*8 xi,yi,zi real*8 xr,yr,zr real*8 radius real*8 rdn,r2 logical, allocatable :: update(:) c c c apply reduction factors to find coordinates for each site c do ii = 1, nvdw i = ivdw(ii) 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 neighbor list cannot be used with the replicates method c radius = sqrt(vbuf2) call replica (radius) if (use_replica) then write (iout,10) 10 format (/,' VLIST -- Pairwise Neighbor List cannot', & ' be used with Replicas') call fatal end if c c perform a complete list build instead of an update c if (dovlst) then dovlst = .false. if (nonprism) then call vbuild else call vlight end if return end if c c perform dynamic allocation of some local arrays c allocate (update(n)) c c test sites for displacement exceeding half the buffer c !$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,xr,yr,zr,r2) !$OMP DO schedule(guided) do ii = 1, nvdw i = ivdw(ii) xi = xred(i) yi = yred(i) zi = zred(i) xr = xi - xvold(i) yr = yi - yvold(i) zr = zi - zvold(i) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr update(i) = .false. if (r2 .ge. lbuf2) then update(i) = .true. xvold(i) = xi yvold(i) = yi zvold(i) = zi end if end do !$OMP END DO c c rebuild the higher numbered neighbors of updated sites c !$OMP DO schedule(guided) do ii = 1, nvdw i = ivdw(ii) if (update(i)) then xi = xvold(i) yi = yvold(i) zi = zvold(i) nvlst(i) = 0 do kk = ii+1, nvdw k = ivdw(kk) xr = xi - xvold(k) yr = yi - yvold(k) zr = zi - zvold(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. vbuf2) then nvlst(i) = nvlst(i) + 1 vlst(nvlst(i),i) = k end if end do end if end do !$OMP END DO c c adjust lists for lower numbered neighbors of updated sites c !$OMP DO schedule(guided) do ii = 1, nvdw i = ivdw(ii) if (update(i)) then xi = xvold(i) yi = yvold(i) zi = zvold(i) do kk = 1, ii-1 k = ivdw(kk) if (.not. update(k)) then xr = xi - xvold(k) yr = yi - yvold(k) zr = zi - zvold(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. vbuf2) then !$OMP CRITICAL do j = 1, nvlst(k) if (vlst(j,k) .eq. i) goto 20 end do nvlst(k) = nvlst(k) + 1 vlst(nvlst(k),k) = i 20 continue !$OMP END CRITICAL else if (r2 .le. vbufx) then !$OMP CRITICAL do j = 1, nvlst(k) if (vlst(j,k) .eq. i) then vlst(j,k) = vlst(nvlst(k),k) nvlst(k) = nvlst(k) - 1 goto 30 end if end do 30 continue !$OMP END CRITICAL end if end if end do end if end do !$OMP END DO c c check to see if any neighbor lists are too long c !$OMP DO schedule(guided) do ii = 1, nvdw i = ivdw(ii) if (nvlst(i) .ge. maxvlst) then write (iout,40) 40 format (/,' VLIST -- Too many Neighbors;', & ' Increase MAXVLST') call fatal end if end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (update) return end c c c ########################################################### c ## ## c ## subroutine vbuild -- build vdw list for all sites ## c ## ## c ########################################################### c c c "vbuild" performs a complete rebuild of the van der Waals c pair neighbor list for all sites c c subroutine vbuild use bound use iounit use neigh use vdw implicit none integer i,k,ii,kk real*8 xi,yi,zi real*8 xr,yr,zr,r2 c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(shared) private(i,k,ii,kk,xi,yi,zi,xr,yr,zr,r2) !$OMP DO schedule(guided) c c store coordinates to reflect update of the site c do ii = 1, nvdw i = ivdw(ii) xi = xred(i) yi = yred(i) zi = zred(i) xvold(i) = xi yvold(i) = yi zvold(i) = zi c c generate all neighbors for the site being rebuilt c nvlst(i) = 0 do kk = ii+1, nvdw k = ivdw(kk) xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. vbuf2) then nvlst(i) = nvlst(i) + 1 vlst(nvlst(i),i) = k end if end do c c check to see if the neighbor list is too long c if (nvlst(i) .ge. maxvlst) then write (iout,10) 10 format (/,' VBUILD -- Too many Neighbors;', & ' Increase MAXVLST') call fatal 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 ## ## c ## subroutine vlight -- build vdw pair list via lights ## c ## ## c ############################################################# c c c "vlight" performs a complete rebuild of the van der Waals c pair neighbor list for all sites using the method of lights c c subroutine vlight use atoms use bound use cell use iounit use light use neigh use vdw implicit none integer i,j,k integer ii,kk integer kgy,kgz integer start,stop real*8 xi,yi,zi real*8 xr,yr,zr real*8 r2,off real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical unique,repeat c c c perform dynamic allocation of some local arrays c allocate (xsort(nvdw)) allocate (ysort(nvdw)) allocate (zsort(nvdw)) c c transfer interaction site coordinates to sorting arrays c do ii = 1, nvdw i = ivdw(ii) nvlst(i) = 0 xvold(i) = xred(i) yvold(i) = yred(i) zvold(i) = zred(i) xsort(ii) = xred(i) ysort(ii) = yred(i) zsort(ii) = zred(i) end do c c use the method of lights to generate neighbors c unique = .false. off = sqrt(vbuf2) call lights (off,nvdw,xsort,ysort,zsort,unique) c c perform deallocation of some local arrays c deallocate (xsort) deallocate (ysort) deallocate (zsort) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(shared) private(i,j,k,ii,kk, !$OMP& xi,yi,zi,xr,yr,zr,r2,kgy,kgz,start,stop,repeat) !$OMP DO schedule(guided) c c loop over all atoms computing the neighbor lists c do ii = 1, nvdw i = ivdw(ii) xi = xred(i) yi = yred(i) zi = zred(i) if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) if (kk .le. ii) goto 20 k = ivdw(kk) 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 xr = xi - xred(k) yr = yi - yred(k) zr = zi - zred(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. vbuf2) then nvlst(i) = nvlst(i) + 1 vlst(nvlst(i),i) = k end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) stop = nvdw goto 10 end if c c check to see if the neighbor list is too long c if (nvlst(i) .ge. maxvlst) then write (iout,30) 30 format (/,' VLIGHT -- Too many Neighbors;', & ' Increase MAXVLST') call fatal 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 ## ## c ## subroutine dlist -- get damped dispersion neighbor lists ## c ## ## c ################################################################## c c c "dlist" performs an update or a complete rebuild of the c nonbonded neighbor lists for damped dispersion sites c c subroutine dlist use atoms use bound use boxes use disp use iounit use neigh implicit none integer i,j,k integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 radius,r2 logical, allocatable :: update(:) c c c perform dynamic allocation of some local arrays c allocate (update(n)) c c neighbor list cannot be used with the replicates method c radius = sqrt(dbuf2) call replica (radius) if (use_replica) then write (iout,10) 10 format (/,' DLIST -- Pairwise Neighbor List cannot', & ' be used with Replicas') call fatal end if c c perform a complete list build instead of an update c if (dodlst) then dodlst = .false. if (nonprism) then call dbuild else call dlight end if return end if c c test sites for displacement exceeding half the buffer c !$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,xr,yr,zr,r2) !$OMP DO schedule(guided) do ii = 1, ndisp i = idisp(ii) xi = x(i) yi = y(i) zi = z(i) xr = xi - xvold(i) yr = yi - yvold(i) zr = zi - zvold(i) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr update(i) = .false. if (r2 .ge. lbuf2) then update(i) = .true. xvold(i) = xi yvold(i) = yi zvold(i) = zi end if end do !$OMP END DO c c rebuild the higher numbered neighbors of updated sites c !$OMP DO schedule(guided) do ii = 1, ndisp i = idisp(ii) if (update(i)) then xi = xvold(i) yi = yvold(i) zi = zvold(i) nvlst(i) = 0 do kk = ii+1, ndisp k = idisp(kk) xr = xi - xvold(k) yr = yi - yvold(k) zr = zi - zvold(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. dbuf2) then nvlst(i) = nvlst(i) + 1 vlst(nvlst(i),i) = k end if end do end if end do !$OMP END DO c c adjust lists for lower numbered neighbors of updated sites c !$OMP DO schedule(guided) do ii = 1, ndisp i = idisp(ii) if (update(i)) then xi = xvold(i) yi = yvold(i) zi = zvold(i) do k = 1, i-1 if (.not. update(k)) then xr = xi - xvold(k) yr = yi - yvold(k) zr = zi - zvold(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. dbuf2) then !$OMP CRITICAL do j = 1, nvlst(k) if (vlst(j,k) .eq. i) goto 20 end do nvlst(k) = nvlst(k) + 1 vlst(nvlst(k),k) = i 20 continue !$OMP END CRITICAL else if (r2 .le. dbufx) then !$OMP CRITICAL do j = 1, nvlst(k) if (vlst(j,k) .eq. i) then vlst(j,k) = vlst(nvlst(k),k) nvlst(k) = nvlst(k) - 1 goto 30 end if end do 30 continue !$OMP END CRITICAL end if end if end do end if end do !$OMP END DO c c check to see if any neighbor lists are too long c !$OMP DO schedule(guided) do ii = 1, ndisp i = idisp(ii) if (nvlst(i) .ge. maxvlst) then write (iout,40) 40 format (/,' DLIST -- Too many Neighbors;', & ' Increase MAXVLST') call fatal end if end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (update) return end c c c ################################################################## c ## ## c ## subroutine dbuild -- build dispersion list for all sites ## c ## ## c ################################################################## c c c "dbuild" performs a complete rebuild of the damped dispersion c neighbor list for all sites c c subroutine dbuild use atoms use bound use disp use iounit use neigh implicit none integer i,k,ii,kk real*8 xi,yi,zi real*8 xr,yr,zr,r2 c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(shared) private(i,k,ii,kk,xi,yi,zi,xr,yr,zr,r2) !$OMP DO schedule(guided) c c store new coordinates to reflect update of the site c do ii = 1, ndisp i = idisp(ii) xi = x(i) yi = y(i) zi = z(i) xvold(i) = xi yvold(i) = yi zvold(i) = zi c c generate all neighbors for the site being rebuilt c nvlst(i) = 0 do kk = ii+1, ndisp k = idisp(kk) xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. dbuf2) then nvlst(i) = nvlst(i) + 1 vlst(nvlst(i),i) = k end if end do c c check to see if the neighbor list is too long c if (nvlst(i) .ge. maxvlst) then write (iout,10) 10 format (/,' DBUILD -- Too many Neighbors;', & ' Increase MAXVLST') call fatal 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 ## ## c ## subroutine dlight -- get damp dispersion list via lights ## c ## ## c ################################################################## c c c "dlight" performs a complete rebuild of the damped dispersion c pair neighbor list for all sites using the method of lights c c subroutine dlight use atoms use bound use cell use disp use iounit use light use neigh implicit none integer i,j,k integer ii,kk integer kgy,kgz integer start,stop real*8 xi,yi,zi real*8 xr,yr,zr real*8 r2,off real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical unique,repeat c c c perform dynamic allocation of some local arrays c allocate (xsort(ndisp)) allocate (ysort(ndisp)) allocate (zsort(ndisp)) c c transfer interaction site coordinates to sorting arrays c do ii = 1, ndisp i = idisp(ii) nvlst(i) = 0 xvold(i) = x(i) yvold(i) = y(i) zvold(i) = z(i) 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 = .false. off = sqrt(dbuf2) call lights (off,ndisp,xsort,ysort,zsort,unique) c c perform deallocation of some local arrays c deallocate (xsort) deallocate (ysort) deallocate (zsort) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi, !$OMP& xr,yr,zr,r2,kgy,kgz,start,stop,repeat) !$OMP DO schedule(guided) c c loop over all atoms computing the neighbor lists c do ii = 1, ndisp i = idisp(ii) xi = x(i) yi = y(i) zi = z(i) if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) if (kk .le. ii) goto 20 k = idisp(kk) 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 xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. dbuf2) then nvlst(i) = nvlst(i) + 1 vlst(nvlst(i),i) = k end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) stop = ndisp goto 10 end if c c check to see if the neighbor list is too long c if (nvlst(i) .ge. maxvlst) then write (iout,30) 30 format (/,' DLIGHT -- Too many Neighbors;', & ' Increase MAXVLST') call fatal 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 ## ## c ## subroutine clist -- get partial charge neighbor lists ## c ## ## c ############################################################### c c c "clist" performs an update or a complete rebuild of the c nonbonded neighbor lists for partial charges c c subroutine clist use atoms use bound use boxes use charge use iounit use neigh implicit none integer i,j,k integer ii,kk,ic real*8 xi,yi,zi real*8 xr,yr,zr real*8 radius,r2 logical, allocatable :: update(:) c c c perform dynamic allocation of some local arrays c allocate (update(n)) c c neighbor list cannot be used with the replicates method c radius = sqrt(cbuf2) call replica (radius) if (use_replica) then write (iout,10) 10 format (/,' CLIST -- Pairwise Neighbor List cannot', & ' be used with Replicas') call fatal end if c c perform a complete list build instead of an update c if (doclst) then doclst = .false. if (nonprism) then call cbuild else call clight end if return end if c c test sites for displacement exceeding half the buffer c !$OMP PARALLEL default(shared) private(i,j,k,ii,kk,ic, !$OMP& xi,yi,zi,xr,yr,zr,r2) !$OMP DO schedule(guided) do ii = 1, nion i = iion(ii) ic = kion(i) xi = x(ic) yi = y(ic) zi = z(ic) xr = xi - xeold(i) yr = yi - yeold(i) zr = zi - zeold(i) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr update(i) = .false. if (r2 .ge. lbuf2) then update(i) = .true. xeold(i) = xi yeold(i) = yi zeold(i) = zi end if end do !$OMP END DO c c rebuild the higher numbered neighbors of updated sites c !$OMP DO schedule(guided) do ii = 1, nion i = iion(ii) if (update(i)) then xi = xeold(i) yi = yeold(i) zi = zeold(i) nelst(i) = 0 do kk = ii+1, nion k = iion(kk) xr = xi - xeold(k) yr = yi - yeold(k) zr = zi - zeold(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. cbuf2) then nelst(i) = nelst(i) + 1 elst(nelst(i),i) = k end if end do end if end do !$OMP END DO c c adjust lists for lower numbered neighbors of updated sites c !$OMP DO schedule(guided) do ii = 1, nion i = iion(ii) if (update(i)) then xi = xeold(i) yi = yeold(i) zi = zeold(i) do kk = 1, ii-1 k = iion(kk) if (.not. update(k)) then xr = xi - xeold(k) yr = yi - yeold(k) zr = zi - zeold(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. cbuf2) then !$OMP CRITICAL do j = 1, nelst(k) if (elst(j,k) .eq. i) goto 20 end do nelst(k) = nelst(k) + 1 elst(nelst(k),k) = i 20 continue !$OMP END CRITICAL else if (r2 .le. cbufx) then !$OMP CRITICAL do j = 1, nelst(k) if (elst(j,k) .eq. i) then elst(j,k) = elst(nelst(k),k) nelst(k) = nelst(k) - 1 goto 30 end if end do 30 continue !$OMP END CRITICAL end if end if end do end if end do !$OMP END DO c c check to see if any neighbor lists are too long c !$OMP DO schedule(guided) do ii = 1, nion i = iion(ii) if (nelst(i) .ge. maxelst) then write (iout,40) 40 format (/,' CLIST -- Too many Neighbors;', & ' Increase MAXELST') call fatal end if end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (update) return end c c c ############################################################## c ## ## c ## subroutine cbuild -- build charge list for all sites ## c ## ## c ############################################################## c c c "cbuild" performs a complete rebuild of the partial charge c electrostatic neighbor list for all sites c c subroutine cbuild use atoms use bound use charge use iounit use neigh implicit none integer i,k integer ii,kk integer ic,kc real*8 xi,yi,zi real*8 xr,yr,zr,r2 c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(shared) private(i,k,ii,kk,ic,kc, !$OMP& xi,yi,zi,xr,yr,zr,r2) !$OMP DO schedule(guided) c c store new coordinates to reflect update of the site c do ii = 1, nion i = iion(ii) ic = kion(i) xi = x(ic) yi = y(ic) zi = z(ic) xeold(i) = xi yeold(i) = yi zeold(i) = zi c c generate all neighbors for the site being rebuilt c nelst(i) = 0 do kk = ii+1, nion k = iion(kk) kc = kion(k) xr = xi - x(kc) yr = yi - y(kc) zr = zi - z(kc) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. cbuf2) then nelst(i) = nelst(i) + 1 elst(nelst(i),i) = k end if end do c c check to see if the neighbor list is too long c if (nelst(i) .ge. maxelst) then write (iout,10) 10 format (/,' CBUILD -- Too many Neighbors;', & ' Increase MAXELST') call fatal 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 ## ## c ## subroutine clight -- get partial charge list via lights ## c ## ## c ################################################################# c c c "clight" performs a complete rebuild of the partial charge c pair neighbor list for all sites using the method of lights c c subroutine clight use atoms use bound use cell use charge use iounit use light use neigh implicit none integer i,j,k integer ii,kk integer ic,kc integer kgy,kgz integer start,stop real*8 xi,yi,zi real*8 xr,yr,zr real*8 r2,off real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical unique,repeat c c c perform dynamic allocation of some local arrays c allocate (xsort(nion)) allocate (ysort(nion)) allocate (zsort(nion)) c c transfer interaction site coordinates to sorting arrays c do ii = 1, nion i = iion(ii) ic = kion(i) nelst(i) = 0 xeold(i) = x(ic) yeold(i) = y(ic) zeold(i) = z(ic) 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 = .false. off = sqrt(cbuf2) call lights (off,nion,xsort,ysort,zsort,unique) c c perform deallocation of some local arrays c deallocate (xsort) deallocate (ysort) deallocate (zsort) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(shared) private(i,j,k,ii,kk,ic,kc, !$OMP& xi,yi,zi,xr,yr,zr,r2,kgy,kgz,start,stop,repeat) !$OMP DO schedule(guided) c c loop over all atoms computing the neighbor lists c do ii = 1, nion i = iion(ii) ic = kion(i) xi = x(ic) yi = y(ic) zi = z(ic) if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) if (kk .le. ii) goto 20 k = iion(kk) kc = kion(k) 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 xr = xi - x(kc) yr = yi - y(kc) zr = zi - z(kc) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. cbuf2) then nelst(i) = nelst(i) + 1 elst(nelst(i),i) = k end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) stop = nion goto 10 end if c c check to see if the neighbor list is too long c if (nelst(i) .ge. maxelst) then write (iout,30) 30 format (/,' CLIGHT -- Too many Neighbors;', & ' Increase MAXELST') call fatal 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 ## ## c ## subroutine mlist -- get atomic multipole neighbor lists ## c ## ## c ################################################################# c c c "mlist" performs an update or a complete rebuild of the c nonbonded neighbor lists for atomic multipoles c c subroutine mlist use atoms use bound use boxes use iounit use mpole use neigh implicit none integer i,j,k integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 radius,r2 logical, allocatable :: update(:) c c c perform dynamic allocation of some local arrays c allocate (update(n)) c c neighbor list cannot be used with the replicates method c radius = sqrt(mbuf2) call replica (radius) if (use_replica) then write (iout,10) 10 format (/,' MLIST -- Pairwise Neighbor List cannot', & ' be used with Replicas') call fatal end if c c perform a complete list build instead of an update c if (domlst) then domlst = .false. if (nonprism) then call mbuild else call mlight end if return end if c c test sites for displacement exceeding half the buffer c !$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,xr,yr,zr,r2) !$OMP DO schedule(guided) do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) xr = xi - xeold(i) yr = yi - yeold(i) zr = zi - zeold(i) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr update(i) = .false. if (r2 .ge. lbuf2) then update(i) = .true. xeold(i) = xi yeold(i) = yi zeold(i) = zi end if end do !$OMP END DO c c rebuild the higher numbered neighbors of updated sites c !$OMP DO schedule(guided) do ii = 1, npole i = ipole(ii) if (update(i)) then xi = xeold(i) yi = yeold(i) zi = zeold(i) nelst(i) = 0 do kk = ii+1, npole k = ipole(kk) xr = xi - xeold(k) yr = yi - yeold(k) zr = zi - zeold(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. mbuf2) then nelst(i) = nelst(i) + 1 elst(nelst(i),i) = k end if end do end if end do !$OMP END DO c c adjust lists for lower numbered neighbors of updated sites c !$OMP DO schedule(guided) do ii = 1, npole i = ipole(ii) if (update(i)) then xi = xeold(i) yi = yeold(i) zi = zeold(i) do kk = 1, ii-1 k = ipole(kk) if (.not. update(k)) then xr = xi - xeold(k) yr = yi - yeold(k) zr = zi - zeold(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. mbuf2) then !$OMP CRITICAL do j = 1, nelst(k) if (elst(j,k) .eq. i) goto 20 end do nelst(k) = nelst(k) + 1 elst(nelst(k),k) = i 20 continue !$OMP END CRITICAL else if (r2 .le. mbufx) then !$OMP CRITICAL do j = 1, nelst(k) if (elst(j,k) .eq. i) then elst(j,k) = elst(nelst(k),k) nelst(k) = nelst(k) - 1 goto 30 end if end do 30 continue !$OMP END CRITICAL end if end if end do end if end do !$OMP END DO c c check to see if any neighbor lists are too long c !$OMP DO schedule(guided) do ii = 1, npole i = ipole(ii) if (nelst(i) .ge. maxelst) then write (iout,40) 40 format (/,' MLIST -- Too many Neighbors;', & ' Increase MAXELST') call fatal end if end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (update) return end c c c ############################################################# c ## ## c ## subroutine mbuild -- build mpole list for all sites ## c ## ## c ############################################################# c c c "mbuild" performs a complete rebuild of the atomic multipole c electrostatic neighbor list for all sites c c subroutine mbuild use atoms use bound use iounit use mpole use neigh implicit none integer i,k,ii,kk real*8 xi,yi,zi real*8 xr,yr,zr,r2 c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(shared) private(i,k,ii,kk,xi,yi,zi,xr,yr,zr,r2) !$OMP DO schedule(guided) c c store new coordinates to reflect update of the site c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) xeold(i) = xi yeold(i) = yi zeold(i) = zi c c generate all neighbors for the site being rebuilt c nelst(i) = 0 do kk = ii+1, npole k = ipole(kk) xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. mbuf2) then nelst(i) = nelst(i) + 1 elst(nelst(i),i) = k end if end do c c check to see if the neighbor list is too long c if (nelst(i) .ge. maxelst) then write (iout,10) 10 format (/,' MBUILD -- Too many Neighbors;', & ' Increase MAXELST') call fatal 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 ## ## c ## subroutine mlight -- get multipole pair list via lights ## c ## ## c ################################################################# c c c "mlight" performs a complete rebuild of the atomic multipole c pair neighbor list for all sites using the method of lights c c subroutine mlight use atoms use bound use cell use iounit use light use mpole use neigh implicit none integer i,j,k integer ii,kk integer kgy,kgz integer start,stop real*8 xi,yi,zi real*8 xr,yr,zr real*8 r2,off real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical unique,repeat c c c perform dynamic allocation of some local arrays c allocate (xsort(npole)) allocate (ysort(npole)) allocate (zsort(npole)) c c transfer interaction site coordinates to sorting arrays c do ii = 1, npole i = ipole(ii) nelst(i) = 0 xeold(i) = x(i) yeold(i) = y(i) zeold(i) = z(i) 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 = .false. off = sqrt(mbuf2) call lights (off,npole,xsort,ysort,zsort,unique) c c perform deallocation of some local arrays c deallocate (xsort) deallocate (ysort) deallocate (zsort) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi, !$OMP& xr,yr,zr,r2,kgy,kgz,start,stop,repeat) !$OMP DO schedule(guided) c c loop over all atoms computing the neighbor lists c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) if (kk .le. ii) goto 20 k = ipole(kk) 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 xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. mbuf2) then nelst(i) = nelst(i) + 1 elst(nelst(i),i) = k end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) stop = npole goto 10 end if c c check to see if the neighbor list is too long c if (nelst(i) .ge. maxelst) then write (iout,30) 30 format (/,' MLIGHT -- Too many Neighbors;', & ' Increase MAXELST') call fatal 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 ## ## c ## subroutine ulist -- get preconditioner neighbor lists ## c ## ## c ############################################################### c c c "ulist" performs an update or a complete rebuild of the c neighbor lists for the polarization preconditioner c c subroutine ulist use atoms use bound use boxes use iounit use mpole use neigh implicit none integer i,j,k integer ii,kk real*8 xi,yi,zi real*8 xr,yr,zr real*8 radius,r2 logical, allocatable :: update(:) c c c perform dynamic allocation of some local arrays c allocate (update(n)) c c neighbor list cannot be used with the replicates method c radius = sqrt(ubuf2) call replica (radius) if (use_replica) then write (iout,10) 10 format (/,' ULIST -- Pairwise Neighbor List cannot', & ' be used with Replicas') call fatal end if c c perform a complete list build instead of an update c if (doulst) then doulst = .false. if (nonprism) then call ubuild else call ulight end if return end if c c test sites for displacement exceeding half the buffer c !$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi,xr,yr,zr,r2) !$OMP DO schedule(guided) do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) xr = xi - xuold(i) yr = yi - yuold(i) zr = zi - zuold(i) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr update(i) = .false. if (r2 .ge. pbuf2) then update(i) = .true. xuold(i) = xi yuold(i) = yi zuold(i) = zi end if end do !$OMP END DO c c rebuild the higher numbered neighbors of updated sites c !$OMP DO schedule(guided) do ii = 1, npole i = ipole(ii) if (update(i)) then xi = xuold(i) yi = yuold(i) zi = zuold(i) nulst(i) = 0 do kk = ii+1, npole k = ipole(kk) xr = xi - xuold(k) yr = yi - yuold(k) zr = zi - zuold(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. ubuf2) then nulst(i) = nulst(i) + 1 ulst(nulst(i),i) = k end if end do end if end do !$OMP END DO c c adjust lists for lower numbered neighbors of updated sites c !$OMP DO schedule(guided) do ii = 1, npole i = ipole(ii) if (update(i)) then xi = xuold(i) yi = yuold(i) zi = zuold(i) do kk = 1, ii-1 k = ipole(kk) if (.not. update(k)) then xr = xi - xuold(k) yr = yi - yuold(k) zr = zi - zuold(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. ubuf2) then !$OMP CRITICAL do j = 1, nulst(k) if (ulst(j,k) .eq. i) goto 20 end do nulst(k) = nulst(k) + 1 ulst(nulst(k),k) = i 20 continue !$OMP END CRITICAL else if (r2 .le. ubufx) then !$OMP CRITICAL do j = 1, nulst(k) if (ulst(j,k) .eq. i) then ulst(j,k) = ulst(nulst(k),k) nulst(k) = nulst(k) - 1 goto 30 end if end do 30 continue !$OMP END CRITICAL end if end if end do end if end do !$OMP END DO c c check to see if any neighbor lists are too long c !$OMP DO schedule(guided) do ii = 1, npole i = ipole(ii) if (nulst(i) .ge. maxulst) then write (iout,40) 40 format (/,' ULIST -- Too many Neighbors;', & ' Increase MAXULST') call fatal end if end do !$OMP END DO !$OMP END PARALLEL c c perform deallocation of some local arrays c deallocate (update) return end c c c ################################################################ c ## ## c ## subroutine ubuild -- preconditioner list for all sites ## c ## ## c ################################################################ c c c "ubuild" performs a complete rebuild of the polarization c preconditioner neighbor list for all sites c c subroutine ubuild use atoms use bound use iounit use mpole use neigh implicit none integer i,k,ii,kk real*8 xi,yi,zi real*8 xr,yr,zr,r2 c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(shared) private(i,k,ii,kk,xi,yi,zi,xr,yr,zr,r2) !$OMP DO schedule(guided) c c store new coordinates to reflect update of the site c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) xuold(i) = xi yuold(i) = yi zuold(i) = zi c c generate all neighbors for the site being rebuilt c nulst(i) = 0 do kk = ii+1, npole k = ipole(kk) xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. ubuf2) then nulst(i) = nulst(i) + 1 ulst(nulst(i),i) = k end if end do c c check to see if the neighbor list is too long c if (nulst(i) .ge. maxulst) then write (iout,10) 10 format (/,' UBUILD -- Too many Neighbors;', & ' Increase MAXULST') call fatal 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 ## ## c ## subroutine ulight -- get preconditioner list via lights ## c ## ## c ################################################################# c c c "ulight" performs a complete rebuild of the polarization c preconditioner pair neighbor list for all sites using the c method of lights c c subroutine ulight use atoms use bound use cell use iounit use light use mpole use neigh implicit none integer i,j,k integer ii,kk integer kgy,kgz integer start,stop real*8 xi,yi,zi real*8 xr,yr,zr real*8 r2,off real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) logical unique,repeat c c c perform dynamic allocation of some local arrays c allocate (xsort(npole)) allocate (ysort(npole)) allocate (zsort(npole)) c c transfer interaction site coordinates to sorting arrays c do ii = 1, npole i = ipole(ii) nulst(i) = 0 xuold(i) = x(i) yuold(i) = y(i) zuold(i) = z(i) 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 = .false. off = sqrt(ubuf2) call lights (off,npole,xsort,ysort,zsort,unique) c c perform deallocation of some local arrays c deallocate (xsort) deallocate (ysort) deallocate (zsort) c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(shared) private(i,j,k,ii,kk,xi,yi,zi, !$OMP& xr,yr,zr,r2,kgy,kgz,start,stop,repeat) !$OMP DO schedule(guided) c c loop over all atoms computing the neighbor lists c do ii = 1, npole i = ipole(ii) xi = x(i) yi = y(i) zi = z(i) if (kbx(ii) .le. kex(ii)) then repeat = .false. start = kbx(ii) stop = kex(ii) else repeat = .true. start = 1 stop = kex(ii) end if 10 continue do j = start, stop kk = locx(j) if (kk .le. ii) goto 20 k = ipole(kk) 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 xr = xi - x(k) yr = yi - y(k) zr = zi - z(k) call imagen (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .le. ubuf2) then nulst(i) = nulst(i) + 1 ulst(nulst(i),i) = k end if 20 continue end do if (repeat) then repeat = .false. start = kbx(ii) stop = npole goto 10 end if c c check to see if the neighbor list is too long c if (nulst(i) .ge. maxulst) then write (iout,30) 30 format (/,' ULIGHT -- Too many Neighbors;', & ' Increase MAXULST') call fatal 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) 2023 by Rae Corrigan & Jay W. Ponder ## c ## All Rights Reserved ## c ########################################################## c c ################################################################# c ## ## c ## subroutine neck -- neck contribution to effective radii ## c ## ## c ################################################################# c c c "neck" calculates the descreening contribution of any neck c formed between two atoms c c literature reference: 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 c Computation, 6, 3613-3630 (2010) c c variables and parameters: c c r separation distance between two atoms c intstarti start of descreening integral for atom i c desck descreening radius of atom k c mixsn mixed Sneck scale factor for atoms i and k c c subroutine neck (r,intstarti,desck,mixsn,neckval) use math use solute implicit none real*8 r,intstarti real*8 desck,mixsn real*8 neckval real*8 usea,useb real*8 rhow,pi43 real*8 rminb,radminr real*8 rminb4,radminr4 c c c assign and initialize probe radius and constants c rhow = 1.4d0 usea = 0.0d0 useb = 0.0d0 c c if atoms too far separated then no neck is formed c if (r .gt. intstarti+desck+2.0d0*rhow) then neckval = 0.0d0 c c if atoms form a neck then calculate neck contribution c else call neckcon (intstarti,desck,usea,useb) pi43 = 4.0d0 * third * pi rminb = r - useb rminb4 = rminb**4 radminr = intstarti + desck + 2.0d0*rhow - r radminr4 = radminr**4 neckval = pi43 * mixsn * usea * rminb4 * radminr4 end if return end c c c ################################################################ c ## ## c ## subroutine neckder -- get neck descreening derivatives ## c ## ## c ################################################################ c c c "neckder" returns the derivative of the neck descreening c integral for the Born chain rule term c c subroutine neckder (r,intstarti,desck,mixsn,neckderi) use math use solute implicit none real*8 r,intstarti real*8 desck,mixsn real*8 neckderi real*8 usea,useb real*8 rhow,pi43 real*8 rminb,radminr real*8 rminb3,radminr3 real*8 rminb4,radminr4 c c assign and initialize probe radius and constants c rhow = 1.4d0 usea = 0.0d0 useb = 0.0d0 c c if atoms too far separated then no neck is formed c if (r .gt. intstarti+desck+2.0d0*rhow) then neckderi = 0.0d0 c c if atoms form a neck then calculate neck contribution c else call neckcon (intstarti,desck,usea,useb) pi43 = 4.0d0 * third * pi rminb = r - useb rminb3 = rminb**3 rminb4 = rminb3 * rminb radminr = intstarti + desck + 2.0d0*rhow - r radminr3 = radminr**3 radminr4 = radminr3 * radminr neckderi = 4.0d0 * pi43 * (mixsn*usea*rminb3*radminr4 & - mixsn*usea*rminb4*radminr3) end if return end c c c ############################################################# c ## ## c ## subroutine getbounds -- get the radii array indices ## c ## ## c ############################################################# c c c "getbounds" returns the indices in the radii array table c to use for interpolation of Aij and Bij values c c variables and parameters: c c rho value of the input atom radius c below radius bin index for radius next smaller than rho c above radius bin index for radius next larger than rho c c subroutine getbounds (rho,below,above) integer below,above integer numpoints real*8 rho real*8 calcindex real*8 minrad,maxrad real*8 space c c minrad = 0.80d0 maxrad = 3.00d0 space = 0.05d0 numpoints = 45 calcindex = 0.0d0 below = 0 above = 0 calcindex = (rho-minrad) / space below = floor(calcindex) + 1 above = below + 1 if (above .ge. numpoints) then below = numpoints above = numpoints - 1 else if (below .lt. 0) then below = 1 above = 2 end if return end c c c ################################################################ c ## ## c ## subroutine interp2d -- interpolation of Aij/Bij values ## c ## ## c ################################################################ c c c "interp2d" returns the Aij and Bij values interpolated from c benchmark tables derived from Poisson-Boltzmann calculations c c variables and parameters: c c x1 radius bin immediately smaller than descreened atom c x2 radius bin immediately larger than descreened atom c y1 radius bin immediately smaller than descreening atom c y2 radius bin immediately larger than descreening atom c x descreened atom radius + descreening offset, if used c y descreening atom radius c fx1y1 constant for interacting atoms with radii x1 and y1 c fx2y1 constant for interacting atoms with radii x2 and y1 c fx1y2 constant for interacting atoms with radii x1 and y2 c fx2y2 constant for interacting atoms with radii x2 and y2 c val returned interpolated constant value c c subroutine interp2d (x1,x2,y1,y2,x,y,fx1y1,fx2y1,fx1y2,fx2y2,val) real*8 x,x1,x2 real*8 y,y1,y2 real*8 fx1y1,fx1y2 real*8 fx2y1,fx2y2 real*8 fxy1,fxy2 real*8 val c c c perform 2D interpolation of neck correction constant c fxy1 = (x2-x)/(x2-x1)*fx1y1 + (x-x1)/(x2-x1)*fx2y1 fxy2 = (x2-x)/(x2-x1)*fx1y2 + (x-x1)/(x2-x1)*fx2y2 val = (y2-y)/(y2-y1)*fxy1 + (y-y1)/(y2-y1)*fxy2 return end c c c ########################################################### c ## ## c ## subroutine neckcon -- generate the neck constants ## c ## ## c ########################################################### c c c "neckcon" returns the neck correction values for a specific c pair of input radii c c variables and parameters: c c rhdsd rho descreened, radius of descreened atom c rhdsg rho descreening, radius of descreening atom c aloc returned value of "aneck" parameter value c bloc returned value of "bneck" parameter value c c subroutine neckcon (rhdsd,rhdsg,aloc,bloc) use solute integer lowi,highi integer lowj,highj real*8 rhdsd,rhdsg real*8 aloc,bloc real*8 rli,rhi real*8 rlj,rhj real*8 lla,hla real*8 lha,hha real*8 llb,hlb real*8 lhb,hhb c c c initialize some bounds and values c lowi = 0 lowj = 0 highi = 0 highj = 0 aloc = 0.0d0 bloc = 0.0d0 c c find neck correction values via the bin index array c call getbounds (rhdsd,lowi,highi) call getbounds (rhdsg,lowj,highj) rli = rneck(lowi) rhi = rneck(highi) rlj = rneck(lowj) rhj = rneck(highj) lla = aneck(lowi,lowj) hla = aneck(highi,lowj) lha = aneck(lowi,highj) hha = aneck(highi,highj) llb = bneck(lowi,lowj) hlb = bneck(highi,lowj) lhb = bneck(lowi,highj) hhb = bneck(highi,highj) call interp2d (rli,rhi,rlj,rhj,rhdsd,rhdsg,lla,hla,lha,hha,aloc) call interp2d (rli,rhi,rlj,rhj,rhdsd,rhdsg,llb,hlb,lhb,hhb,bloc) if (aloc .lt. 0.0d0) then aloc = 0.0d0 end if return end c c c ################################################################ c ## COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ################################################################## c ## ## c ## module neigh -- pairwise neighbor list indices & storage ## c ## ## c ################################################################## c c c maxvlst maximum size of van der Waals pair neighbor lists c maxelst maximum size of electrostatic pair neighbor lists c maxulst maximum size of dipole preconditioner pair lists c nvlst number of sites in list for each vdw site c vlst site numbers in neighbor list of each vdw site c nelst number of sites in list for each electrostatic site c elst site numbers in list of each electrostatic site c nulst number of sites in list for each preconditioner site c ulst site numbers in list of each preconditioner site c lbuffer width of the neighbor list buffer region c pbuffer width of the preconditioner list buffer region c lbuf2 square of half the neighbor list buffer width c pbuf2 square of half the preconditioner list buffer width c vbuf2 square of van der Waals cutoff plus the list buffer c vbufx square of van der Waals cutoff plus 2X list buffer c dbuf2 square of dispersion cutoff plus the list buffer c dbufx square of dispersion cutoff plus 2X list buffer c cbuf2 square of charge cutoff plus the list buffer c cbufx square of charge cutoff plus 2X list buffer c mbuf2 square of multipole cutoff plus the list buffer c mbufx square of multipole cutoff plus 2X list buffer c ubuf2 square of preconditioner cutoff plus the list buffer c ubufx square of preconditioner cutoff plus 2X list buffer c xvold x-coordinate at last vdw/dispersion list update c yvold y-coordinate at last vdw/dispersion list update c zvold z-coordinate at last vdw/dispersion list update c xeold x-coordinate at last electrostatic list update c yeold y-coordinate at last electrostatic list update c zeold z-coordinate at last electrostatic list update c xuold x-coordinate at last preconditioner list update c yuold y-coordinate at last preconditioner list update c zuold z-coordinate at last preconditioner list update c dovlst logical flag to rebuild vdw neighbor list c dodlst logical flag to rebuild dispersion neighbor list c doclst logical flag to rebuild charge neighbor list c domlst logical flag to rebuild multipole neighbor list c doulst logical flag to rebuild preconditioner neighbor list c c module neigh implicit none integer maxvlst integer maxelst integer maxulst integer, allocatable :: nvlst(:) integer, allocatable :: vlst(:,:) integer, allocatable :: nelst(:) integer, allocatable :: elst(:,:) integer, allocatable :: nulst(:) integer, allocatable :: ulst(:,:) real*8 lbuffer,pbuffer real*8 lbuf2,pbuf2 real*8 vbuf2,vbufx real*8 dbuf2,dbufx real*8 cbuf2,cbufx real*8 mbuf2,mbufx real*8 ubuf2,ubufx real*8, allocatable :: xvold(:) real*8, allocatable :: yvold(:) real*8, allocatable :: zvold(:) real*8, allocatable :: xeold(:) real*8, allocatable :: yeold(:) real*8, allocatable :: zeold(:) real*8, allocatable :: xuold(:) real*8, allocatable :: yuold(:) real*8, allocatable :: zuold(:) logical dovlst,dodlst logical doclst,domlst logical doulst save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## program newton -- perform TNCG Cartesian optimization ## c ## ## c ############################################################### c c c "newton" performs an energy minimization in Cartesian c coordinate space using a truncated Newton method c c program newton use atoms use bound use files use inform use iounit use usage implicit none integer i,j,k,next integer imin,nvar integer freeunit real*8 gnorm,grms,grdmin real*8 minimum,newton1 real*8, allocatable :: xx(:) real*8, allocatable :: derivs(:,:) logical exist character*1 answer character*6 mode,method character*240 minfile character*240 record character*240 string external newton1 external newton2 external optsave c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c perform the setup functions needed for optimization c call optinit c c get the type of optimization algorithm to use c mode = 'AUTO' call nextarg (answer,exist) if (.not. exist) then answer = 'A' write (iout,10) answer 10 format (/,' Choose Automatic, Newton, TNCG or DTNCG', & ' Method [',a1,'] : ',$) read (input,20) record 20 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'A') mode = 'AUTO' if (answer .eq. 'N') mode = 'NEWTON' if (answer .eq. 'T') mode = 'TNCG' if (answer .eq. 'D') mode = 'DTNCG' c c get the type of linear equation preconditioning to use c method = 'AUTO' call nextarg (answer,exist) if (.not. exist) then answer = 'A' write (iout,30) answer 30 format (/,' Precondition via Auto/None/Diag/Block/', & 'SSOR/ICCG [',a1,'] : ',$) read (input,40) record 40 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'A') method = 'AUTO' if (answer .eq. 'N') method = 'NONE' if (answer .eq. 'D') method = 'DIAG' if (answer .eq. 'B') method = 'BLOCK' if (answer .eq. 'S') method = 'SSOR' if (answer .eq. 'I') method = 'ICCG' c c get the termination criterion as RMS gradient per atom c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=50,end=50) grdmin 50 continue if (grdmin .le. 0.0d0) then write (iout,60) 60 format (/,' Enter RMS Gradient per Atom Criterion', & ' [0.01] : ',$) read (input,70) grdmin 70 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.01d0 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 convert atomic coordinates to optimization parameters c nvar = 0 do i = 1, nuse 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 make the call to the optimization routine c call tncg (mode,method,nvar,xx,minimum,grdmin, & newton1,newton2,optsave) 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 compute the final function and RMS gradient values c call gradient (minimum,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,80) minimum,grms,gnorm 80 format (/,' Final Function Value :',2x,f20.8, & /,' Final RMS Gradient :',4x,f20.8, & /,' Final Gradient Norm :',3x,f20.8) else write (iout,90) minimum,grms,gnorm 90 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,100) minimum,grms,gnorm 100 format (/,' Final Function Value :',2x,f18.6, & /,' Final RMS Gradient :',4x,f18.6, & /,' Final Gradient Norm :',3x,f18.6) else write (iout,110) minimum,grms,gnorm 110 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,120) minimum,grms,gnorm 120 format (/,' Final Function Value :',2x,f16.4, & /,' Final RMS Gradient :',4x,f16.4, & /,' Final Gradient Norm :',3x,f16.4) else write (iout,130) minimum,grms,gnorm 130 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 move stray molecules into periodic box if desired c c if (use_bounds) call bounds 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 ## function newton1 -- energy and gradient for newton ## c ## ## c ############################################################ c c c "newton1" is a service routine that computes the energy c and gradient for truncated Newton optimization in Cartesian c coordinate space c c function newton1 (xx,g) use atoms use usage implicit none integer i,k,nvar real*8 newton1,e real*8 xx(*) real*8 g(*) 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 perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute and store the energy and gradient c call gradient (e,derivs) newton1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 g(nvar) = derivs(1,k) nvar = nvar + 1 g(nvar) = derivs(2,k) nvar = nvar + 1 g(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 newton2 -- Hessian values for newton ## c ## ## c ######################################################### c c c "newton2" is a service routine that computes the sparse c matrix Hessian elements for truncated Newton optimization c in Cartesian coordinate space c c subroutine newton2 (mode,xx,h,hinit,hstop,hindex,hdiag) use atoms use usage implicit none integer i,j,k,nvar integer hinit(*) integer hstop(*) integer hindex(*) integer, allocatable :: hvar(:) integer, allocatable :: huse(:) real*8 xx(*) real*8 hdiag(*) real*8 h(*) character*4 mode c c c convert optimization parameters to atomic coordinates c if (mode .eq. 'NONE') return nvar = 0 do i = 1, n 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 compute and store the Hessian elements c call hessian (h,hinit,hstop,hindex,hdiag) c c perform dynamic allocation of some local arrays c allocate (hvar(nvar)) allocate (huse(3*n)) c c transform the sparse Hessian to use only active atoms c nvar = 0 if (nuse .ne. n) then do i = 1, n k = 3 * (i-1) if (use(i)) then do j = 1, 3 nvar = nvar + 1 hvar(nvar) = j + k huse(j+k) = nvar end do else do j = 1, 3 huse(j+k) = 0 end do end if end do do i = 1, nvar k = hvar(i) hinit(i) = hinit(k) hstop(i) = hstop(k) hdiag(i) = hdiag(k) do j = hinit(i), hstop(i) hindex(j) = huse(hindex(j)) end do end do end if c c convert atomic coordinates to optimization parameters c nvar = 0 do i = 1, nuse 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 deallocation of some local arrays c deallocate (hvar) deallocate (huse) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## program newtrot -- perform TNCG torsional optimization ## c ## ## c ################################################################ c c c "newtrot" performs an energy minimization in torsional angle c space using a truncated Newton conjugate gradient method c c program newtrot use files use inform use iounit use math use omega use zcoord implicit none integer i,imin,next integer freeunit real*8 grdmin,gnorm,grms real*8 minimum,newtrot1 real*8, allocatable :: xx(:) real*8, allocatable :: derivs(:) logical exist character*1 answer character*6 mode,method character*240 minfile character*240 record character*240 string external newtrot1 external newtrot2 external optsave c c c set up the molecular mechanics calculation c call initial call getint call mechanic c c perform the setup functions needed for optimization c call optinit call initrot c c get the type of optimization algorithm to use c mode = 'AUTO' call nextarg (answer,exist) if (.not. exist) then answer = 'A' write (iout,10) answer 10 format (/,' Choose Automatic, Newton, TNCG or DTNCG', & ' Method [',a1,'] : ',$) read (input,20) record 20 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'A') mode = 'AUTO' if (answer .eq. 'N') mode = 'NEWTON' if (answer .eq. 'T') mode = 'TNCG' if (answer .eq. 'D') mode = 'DTNCG' c c get the type of linear equation preconditioning to use c method = 'DIAG' call nextarg (answer,exist) if (.not. exist) then answer = 'D' write (iout,30) answer 30 format (/,' Precondition via Auto/None/Diag/', & 'SSOR/ICCG [',a1,'] : ',$) read (input,40) record 40 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'A') method = 'AUTO' if (answer .eq. 'N') method = 'NONE' if (answer .eq. 'D') method = 'DIAG' if (answer .eq. 'S') method = 'SSOR' if (answer .eq. 'I') method = 'ICCG' c c get termination criterion as RMS torsional gradient c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=50,end=50) grdmin 50 continue if (grdmin .le. 0.0d0) then write (iout,60) 60 format (/,' Enter RMS Gradient per Torsion Criterion', & ' [0.01] : ',$) read (input,70) grdmin 70 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.01d0 c c write out a copy of coordinates for later update c imin = freeunit () minfile = filename(1:leng)//'.int' call version (minfile,'new') open (unit=imin,file=minfile,status='new') call prtint (imin) close (unit=imin) outfile = minfile c c perform dynamic allocation of some local arrays c allocate (xx(nomega)) c c convert dihedral angles to optimization parameters c do i = 1, nomega xx(i) = dihed(i) end do c c make the call to the optimization routine c call tncg (mode,method,nomega,xx,minimum,grdmin, & newtrot1,newtrot2,optsave) c c convert optimization parameters to dihedral angles c do i = 1, nomega dihed(i) = xx(i) ztors(zline(i)) = dihed(i) * radian end do c c perform deallocation of some local arrays c deallocate (xx) c c perform dynamic allocation of some local arrays c allocate (derivs(nomega)) c c compute the final function and RMS gradient values c call gradrot (minimum,derivs) gnorm = 0.0d0 do i = 1, nomega gnorm = gnorm + derivs(i)**2 end do gnorm = sqrt(gnorm) grms = gnorm / sqrt(dble(nomega)) c c perform deallocation of some local arrays c 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,80) minimum,grms,gnorm 80 format (/,' Final Function Value :',2x,f20.8, & /,' Final RMS Gradient :',4x,f20.8, & /,' Final Gradient Norm :',3x,f20.8) else write (iout,90) minimum,grms,gnorm 90 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,100) minimum,grms,gnorm 100 format (/,' Final Function Value :',2x,f18.6, & /,' Final RMS Gradient :',4x,f18.6, & /,' Final Gradient Norm :',3x,f18.6) else write (iout,110) minimum,grms,gnorm 110 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,120) minimum,grms,gnorm 120 format (/,' Final Function Value :',2x,f16.4, & /,' Final RMS Gradient :',4x,f16.4, & /,' Final Gradient Norm :',3x,f16.4) else write (iout,130) minimum,grms,gnorm 130 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 prtint (imin) close (unit=imin) c c perform any final tasks before program exit c call final end c c c ############################################################## c ## ## c ## function newtrot1 -- energy and gradient for newtrot ## c ## ## c ############################################################## c c c "newtrot1" is a service routine that computes the energy c and gradient for truncated Newton conjugate gradient c optimization in torsional angle space c c function newtrot1 (xx,g) use math use omega use zcoord implicit none integer i real*8 newtrot1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:) c c c translate optimization variables into dihedrals c do i = 1, nomega dihed(i) = xx(i) ztors(zline(i)) = dihed(i) * radian end do c c perform dynamic allocation of some local arrays c allocate (derivs(nomega)) c c get coordinates, then compute energy and gradient c call makexyz call gradrot (e,derivs) newtrot1 = e c c store torsional gradient as optimization gradient c do i = 1, nomega g(i) = derivs(i) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ########################################################### c ## ## c ## subroutine newtrot2 -- Hessian values for newtrot ## c ## ## c ########################################################### c c c "newtrot2" is a service routine that computes the sparse c matrix Hessian elements for truncated Newton optimization c in torsional angle space c c subroutine newtrot2 (mode,xx,h,hinit,hstop,hindex,hdiag) use hescut use math use omega use zcoord implicit none integer i,j,ihess integer hinit(*) integer hstop(*) integer hindex(*) real*8 xx(*) real*8 hdiag(*) real*8 h(*) real*8, allocatable :: hrot(:,:) character*4 mode c c c translate optimization parameters and compute c Cartesian coordinates from internal coordinates c if (mode .eq. 'NONE') return do i = 1, nomega dihed(i) = xx(i) ztors(zline(i)) = dihed(i) * radian end do c c perform dynamic allocation of some local arrays c allocate (hrot(nomega,nomega)) c c compute the desired portion of the Hessian c call makexyz call hessrot (mode,hrot) c c store the large elements in sparse matrix format c if (mode .eq. 'FULL') then ihess = 0 do i = 1, nomega hdiag(i) = hrot(i,i) hinit(i) = ihess + 1 do j = i+1, nomega if (abs(hrot(j,i)) .ge. hesscut) then ihess = ihess + 1 hindex(ihess) = j h(ihess) = hrot(j,i) end if end do hstop(i) = ihess end do c c store only the Hessian matrix diagonal c else if (mode .eq. 'DIAG') then do i = 1, nomega hdiag(i) = hrot(i,i) end do end if c c perform deallocation of some local arrays c deallocate (hrot) return end c c c ################################################### c ## COPYRIGHT (C) 1996 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine nextarg -- find next command line argument ## c ## ## c ############################################################### c c c "nextarg" finds the next unused command line argument c and returns it in the input character string c c subroutine nextarg (string,exist) use argue implicit none integer i,length logical exist character*(*) string c c c initialize the command argument as a blank string c string = ' ' exist = .false. c c get the next command line argument and mark it as used c if (narg .ne. 0) then length = min(len(string),len(arg(maxarg))) do i = 1, narg if (listarg(i)) then listarg(i) = .false. string = arg(i)(1:length) exist = .true. goto 10 end if end do 10 continue end if return end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## function nexttext -- find next non-blank character ## c ## ## c ############################################################ c c c "nexttext" finds and returns the location of the first c non-blank character within an input text string; zero c is returned if no such character is found c c function nexttext (string) implicit none integer i,size integer len,nexttext character*(*) string c c c move forward through the string, one character c at a time, looking for first non-blank character c nexttext = 0 size = len(string) do i = 1, size if (string(i:i) .gt. ' ') then nexttext = i goto 10 end if end do 10 continue return end c c c ################################################################ c ## COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ################################################################## c ## ## c ## module nonpol -- nonpolar cavity & dispersion parameters ## c ## ## c ################################################################## c c c epso water oxygen eps for implicit dispersion term c epsh water hydrogen eps for implicit dispersion term c rmino water oxygen Rmin for implicit dispersion term c rminh water hydrogen Rmin for implicit dispersion term c awater water number density at standard temp & pressure c slevy enthalpy-to-free energy scale factor for dispersion c shctd HCT overlap scale factor for the dispersion integral c dspoff radius offset for the start of dispersion integral c c cavprb probe radius for use in computing cavitation energy c solvprs limiting microscopic solvent pressure value c surften limiting macroscopic surface tension value c spcut starting radius for solvent pressure tapering c spoff cutoff radius for solvent pressure tapering c stcut starting radius for surface tension tapering c stoff cutoff radius for surface tension tapering c radcav atomic radius of each atom for cavitation energy c raddsp atomic radius of each atom for dispersion energy c epsdsp vdw well depth of each atom for dispersion energy c cdsp maximum dispersion energy for each atom c c module nonpol implicit none real*8 epso,epsh real*8 rmino,rminh real*8 awater,slevy real*8 shctd,dspoff parameter (epso=0.1100d0) parameter (epsh=0.0135d0) parameter (rmino=1.7025d0) parameter (rminh=1.3275d0) parameter (awater=0.033428d0) parameter (slevy=1.0d0) parameter (shctd=0.75d0) parameter (dspoff=1.056d0) real*8 cavprb real*8 solvprs real*8 surften real*8 spcut,spoff real*8 stcut,stoff real*8, allocatable :: radcav(:) real*8, allocatable :: raddsp(:) real*8, allocatable :: epsdsp(:) real*8, allocatable :: cdsp(:) save end c c c ################################################################ c ## COPYRIGHT (C) 2011 by Teresa Head-Gordon & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ############################################################### c ## ## c ## subroutine nose -- Nose-Hoover NPT molecular dynamics ## c ## ## c ############################################################### c c c "nose" performs a single molecular dynamics time step via c a Nose-Hoover extended system isothermal-isobaric algorithm c c literature reference: c c G. J. Martyna, M. E. Tuckerman, D. J. Tobias and M. L. Klein, c "Explicit Reversible Integrators for Extended Systems Dynamics", c Molecular Physics, 87, 1117-1157 (1996) c c original version written by Teresa Head-Gordon, November 2011 c c subroutine nose (istep,dt) use atomid use atoms use bath use boxes use freeze use moldyn use units use usage use virial implicit none integer i,j,k integer istep real*8 dt,dt_2 real*8 epot,etot real*8 eksum,temp real*8 pres,press real*8 poly,factor real*8 term,expterm real*8 term2,eterm2 real*8 e2,e4,e6,e8 real*8 ekin(3,3) real*8 stress(3,3) real*8, allocatable :: derivs(:,:) save press c c c set some time values for the dynamics integration c dt_2 = 0.5d0 * dt if (istep .eq. 1) press = atmsph c c update thermostat and barostat values, scale atomic velocities c call hoover (dt,press) c c get half-step velocities via 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 update atomic positions via coupling to barostat c term = vbar * dt_2 term2 = term * term expterm = exp(term) eterm2 = expterm * expterm e2 = 1.0d0 / 6.0d0 e4 = e2 / 20.0d0 e6 = e4 / 42.0d0 e8 = e6 / 72.0d0 poly = 1.0d0 + term2*(e2+term2*(e4+term2*(e6+term2*e8))) poly = expterm * poly * dt do i = 1, nuse k = iuse(i) x(k) = x(k)*eterm2 + v(1,k)*poly y(k) = y(k)*eterm2 + v(2,k)*poly z(k) = z(k)*eterm2 + v(3,k)*poly end do c c constraints under NH-NPT require the ROLL algorithm c if (use_rattle) call fatal c c update the periodic box size and total volume c xbox = xbox * eterm2 ybox = ybox * eterm2 zbox = zbox * eterm2 call lattice c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) 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 (derivs) c c constraints under NH-NPT require the ROLL algorithm c if (use_rattle) call fatal c c update thermostat and barostat values, scale atomic velocities c call hoover (dt,press) c c set isotropic pressure to the average of tensor diagonal c factor = prescon / volbox do i = 1, 3 do j = 1, 3 stress(j,i) = factor * (-vir(j,i)) end do end do press = (stress(1,1)+stress(2,2)+stress(3,3)) / 3.0d0 c c accumulate the kinetic energy and its outer product c call kinetic (eksum,ekin,temp) c c calculate the stress tensor for anisotropic systems c do i = 1, 3 do j = 1, 3 stress(j,i) = factor * (2.0d0*ekin(j,i)-vir(j,i)) end do end do pres = (stress(1,1)+stress(2,2)+stress(3,3)) / 3.0d0 c c get the instantaneous temperature from the kinetic energy c etot = epot + eksum 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 hoover -- Nose-Hoover thermostat/barostat ## c ## ## c ############################################################## c c c "hoover" applies a combined thermostat and barostat via a c Nose-Hoover chain algorithm c c subroutine hoover (dt,press) use atoms use bath use boxes use mdstuf use moldyn use units use usage implicit none integer i,j,k integer nc,ns real*8 dt,dtc,dts real*8 dt2,dt4,dt8 real*8 ekt,eksum,temp real*8 df,odnf,gn1kt real*8 press,dpress real*8 expterm,scale real*8 w(3),ekin(3,3) c c c find kinetic energy and set an initial scale factor c call kinetic (eksum,ekin,temp) ekt = gasconst * kelvin nc = 5 ns = 3 dtc = dt / dble(nc) w(1) = 1.0d0 / (2.0d0-2.0d0**(1.0d0/3.0d0)) w(2) = 1.0d0 - 2.0d0*w(1) w(3) = w(1) df = dble(nfree) odnf = 1.0d0 + 3.0d0/df gn1kt = (1.0d0+df) * ekt dpress = (press-atmsph) / prescon scale = 1.0d0 c c use multiple time steps to apply thermostat and barostat c do k = 1, nc do j = 1, ns dts = w(j) * dtc dt2 = 0.5d0 * dts dt4 = 0.25d0 * dts dt8 = 0.125d0 * dts c c update thermostat and barostat velocities and forces c gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4) vnh(4) = vnh(4) + gnh(4)*dt4 gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3) expterm = exp(-vnh(4)*dt8) vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4) gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2) expterm = exp(-vnh(3)*dt8) vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4) gnh(1) = (2.0d0*eksum+qbar*vbar*vbar-gn1kt) / qnh(1) expterm = exp(-vnh(2)*dt8) vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4) gbar = (2.0d0*eksum*odnf+3.0d0*volbox*dpress) / qbar expterm = exp(-vnh(1)*dt8) vbar = expterm * (vbar*expterm+gbar*dt4) c c find velocity scale factor and update kinetic energy c expterm = exp(-(vnh(1)+vbar*odnf)*dt2) scale = scale * expterm eksum = eksum * expterm * expterm c c update barostat and thermostat velocities and forces c gbar = (2.0d0*eksum*odnf+3.0d0*volbox*dpress) / qbar expterm = exp(-vnh(1)*dt8) vbar = expterm * (vbar*expterm+gbar*dt4) gnh(1) = (2.0d0*eksum+qbar*vbar*vbar-gn1kt) / qnh(1) expterm = exp(-vnh(2)*dt8) vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4) gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2) expterm = exp(-vnh(3)*dt8) vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4) gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3) expterm = exp(-vnh(4)*dt8) vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4) gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4) vnh(4) = vnh(4) + gnh(4)*dt4 end do end do c c use scale factor to update the atomic velocities c do i = 1, nuse k = iuse(i) do j = 1, 3 v(j,k) = scale * v(j,k) end do end do return end c c c ################################################################ c ## COPYRIGHT (C) 2006 by Chuanjie Wu and Jay William Ponder ## c ## All Rights Reserved ## c ################################################################ c c ################################################################## c ## ## c ## subroutine nspline -- nonperiodic natural cubic spline ## c ## ## c ################################################################## c c c "nspline" computes coefficients for an nonperiodic cubic spline c with natural boundary conditions where the first and last second c derivatives are already known c c subroutine nspline (n,x0,y0,s1,s2,h,g,dy,dla,dmu) implicit none integer i,n real*8 t,y21,y2n real*8 x0(0:*) real*8 y0(0:*) real*8 s1(0:*) real*8 s2(0:*) real*8 h(0:*) real*8 g(0:*) real*8 dy(0:*) real*8 dla(0:*) real*8 dmu(0:*) c c c set first and last second deriviatives to zero c y21 = 0.0d0 y2n = 0.0d0 c c find the intervals to be used c do i = 0, n-1 h(i) = x0(i+1) - x0(i) dy(i) = (y0(i+1)-y0(i)) / h(i) end do c c calculate the spline coeffcients c do i = 1, n-1 dla(i) = h(i) / (h(i)+h(i-1)) dmu(i) = 1.0d0 - dla(i) g(i) = 3.0d0 * (dla(i)*dy(i-1)+dmu(i)*dy(i)) end do c c set the initial value via natural boundary condition c dla(n) = 1.0d0 dla(0) = 0.0d0 dmu(n) = 0.0d0 dmu(0) = 1.0d0 g(0) = 3.0d0*dy(0) - 0.5d0*h(0)*y21 g(n) = 3.0d0*dy(n-1) + 0.5d0*h(n-1)*y2n c c solve the triagonal system of linear equations c dmu(0) = 0.5d0 * dmu(0) g(0) = 0.5d0 * g(0) do i = 1, n t = 2.0d0 - dmu(i-1)*dla(i) dmu(i) = dmu(i) / t g(i) = (g(i)-g(i-1)*dla(i)) / t end do do i = n-1, 0, -1 g(i) = g(i) - dmu(i)*g(i+1) end do c c get the first derivative at each grid point c do i = 0, n s1(i) = g(i) end do c c get the second derivative at each grid point c s2(0) = y21 s2(n) = y2n do i = 1, n-1 s2(i) = 6.0d0*(y0(i+1)-y0(i))/(h(i)*h(i)) & - 4.0d0*s1(i)/h(i) - 2.0d0*s1(i+1)/h(i) end do return end c c c ############################################################# c ## COPYRIGHT (C) 1999 by ## c ## Marina A. Vorobieva, Nina N. Sokolova & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################# c c ############################################################### c ## ## c ## program nucleic -- build a nucleic acid from sequence ## c ## ## c ############################################################### c c c "nucleic" builds the internal and Cartesian coordinates c of a polynucleotide from nucleic acid sequence and torsional c angle values for the nucleic acid backbone and side chains c c program nucleic use atoms use couple use files use iounit use nucleo use titles implicit none integer i,natom,mode integer izmt,ixyz,iseq integer freeunit integer trimtext logical exist character*240 seqfile character*240 intfile character*240 xyzfile c c c get the name to use for the output structure files c call initial call nextarg (filename,exist) if (.not. exist) then write (iout,10) 10 format (/,' Enter Name to be Used for Output Files : ',$) read (input,20) filename 20 format (a240) end if call basefile (filename) c c get the title line for the output files c write (iout,30) 30 format (/,' Enter Title : ',$) read (input,40) title 40 format (a240) ltitle = trimtext (title) c c read the keyfile and force field parameter file c call getkey call field c c get the sequence and build Z-matrix for the structure c call getseqn call nucchain c c find connectivities and generate Cartesian coordinates c call connect call molecule call makexyz c c perform the alignment of the strands of a double helix c if (dblhlx) then call watson call inertia (2) end if c c remove dummy atoms and set undefined atoms to type zero c natom = n do i = natom, 1, -1 if (type(i) .eq. 0) call delete (i) if (type(i) .lt. 0) type(i) = 0 end do c c convert to internal and Cartesian coordinates c mode = 0 call makeint (mode) call makexyz c c write out a nucleic acid sequence file c iseq = freeunit () seqfile = filename(1:leng)//'.seq' call version (seqfile,'new') open (unit=iseq,file=seqfile,status='new') call prtseq (iseq) close (unit=iseq) c c write out an internal coordinates file c izmt = freeunit () intfile = filename(1:leng)//'.int' call version (intfile,'new') open (unit=izmt,file=intfile,status='new') call prtint (izmt) close (unit=izmt) c c write out a Cartesian coordinates file c ixyz = freeunit () xyzfile = filename(1:leng)//'.xyz' call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') call prtxyz (ixyz) close (unit=ixyz) end c c c ################################################################ c ## ## c ## subroutine getseqn -- nucleic acid sequence and angles ## c ## ## c ################################################################ c c c "getseqn" asks the user for the nucleotide sequence and c torsional angle values needed to define a nucleic acid c c subroutine getseqn use iounit use nucleo use resdue use sequen implicit none integer i,j,k,next integer start,stop integer length logical done logical, allocatable :: purine(:) character*1 answer character*1 ucase(26) character*3 name,resname character*240 record character*240 string data ucase / 'A','B','C','D','E','F','G','H','I','J','K','L', & 'M','N','O','P','Q','R','S','T','U','V','W','X', & 'Y','Z' / c c c choose to generate either an A-, B- or Z-form helix c write (iout,10) 10 format (/,' Enter A-, B- or Z-Form Helix for the Structure', & ' [B] : ',$) read (input,20) record 20 format (a240) call upcase (record) next = 1 call getword (record,answer,next) hlxform = 'B' if (answer .eq. 'A') hlxform = 'A' if (answer .eq. 'Z') hlxform = 'Z' c c provide a header to explain the method of sequence input c write (iout,30) 30 format (/,' Enter One Nucleotide per Line, 5'' to 3'': ', & ' Give PDB Residue Code, and', & /,' optionally, six Backbone Torsions (6F) and', & ' the Glycosidic Torsion (1F)', & //,' Use Residue=MOL to Start a New Strand,', & ' and Use to End Input') c c initially, assume that only a single strand is present c nchain = 1 ichain(1,1) = 1 chnnam(1) = ' ' c c get the nucleotide sequence data and dihedral angle values c i = 0 done = .false. do while (.not. done) i = i + 1 do j = 1, 6 bkbone(j,i) = 0.0d0 end do glyco(i) = 0.0d0 pucker(i) = 0 write (iout,40) i 40 format (/,' Enter Residue',i4,' : ',$) read (input,50) record 50 format (a240) call upcase (record) next = 1 call gettext (record,name,next) call justify (name) length = 3 c length = trimtext (name) string = record(next:240) read (string,*,err=60,end=60) (bkbone(j,i),j=1,6),glyco(i) 60 continue c c process and store the current nucleotide type c if (name .eq. 'MOL') then i = i - 1 ichain(2,nchain) = i nchain = nchain + 1 ichain(1,nchain) = i + 1 else if (name .eq. ' ') then done = .true. nseq = i - 1 ichain(2,nchain) = nseq else seq(i) = nuclz(maxnuc) seqtyp(i) = 0 if (length .eq. 1) then do j = 1, maxnuc if (name(1:1) .eq. nuclz1(j)) then seq(i) = nuclz(j) seqtyp(i) = j end if end do else do j = 1, maxnuc if (name .eq. nuclz(j)) then seq(i) = nuclz(j) seqtyp(i) = j end if end do end if if (seqtyp(i) .eq. 0) then i = i - 1 write (iout,70) name 70 format (/,' GETSEQN -- Nucleotide Type ',a3, & ' is Not Supported') end if end if end if end do c c offer the option to construct an idealized double helix c dblhlx = .false. if (nchain .eq. 1) then write (iout,80) 80 format (/,' Build a Double Helix using Complimentary Bases', & ' [N] : ',$) read (input,90) record 90 format (a240) next = 1 call gettext (record,answer,next) call upcase (answer) if (answer .eq. 'Y') dblhlx = .true. else if (nchain .eq. 2) then write (iout,100) 100 format (/,' Combine the Two Single Strands into Double Helix', & ' [Y] : ',$) read (input,110) record 110 format (a240) next = 1 call gettext (record,answer,next) call upcase (answer) if (answer .ne. 'N') dblhlx = .true. end if c c build a second strand as the reverse-complement sequence c if (nchain.eq.1 .and. dblhlx) then start = 1 stop = nseq resname = nuclz(seqtyp(1)) if (resname.eq.' MP' .or. resname.eq.' DP' & .or. resname.eq.' TP') then k = nseq + 1 seq(k) = seq(1) seqtyp(k) = seqtyp(1) start = 2 end if resname = nuclz(seqtyp(nseq)) if (resname.eq.' MP' .or. resname.eq.' DP' & .or. resname.eq.' TP') then k = 2 * nseq seq(k) = seq(nseq) seqtyp(k) = seqtyp(nseq) stop = nseq - 1 end if do i = start, stop resname = nuclz(seqtyp(i)) if (resname .eq. ' A') then resname = ' U' else if (resname .eq. ' G') then resname = ' C' else if (resname .eq. ' C') then resname = ' G' else if (resname .eq. ' U') then resname = ' A' else if (resname .eq. ' DA') then resname = ' DT' else if (resname .eq. ' DG') then resname = ' DC' else if (resname .eq. ' DC') then resname = ' DG' else if (resname .eq. ' DT') then resname = ' DA' end if k = nseq + stop + start - i do j = 1, maxnuc if (resname .eq. nuclz(j)) then seq(k) = nuclz(j) seqtyp(k) = j end if end do end do do i = 1, nseq k = nseq + i do j = 1, 6 bkbone(j,k) = bkbone(j,i) end do glyco(k) = glyco(i) pucker(k) = pucker(i) end do nchain = 2 nseq = 2 * nseq ichain(1,nchain) = nseq/2 + 1 ichain(2,nchain) = nseq end if c c set chain identifiers if multiple chains are present c if (nchain .gt. 1) then do i = 1, nchain chnnam(i) = ucase(i) end do end if c c perform dynamic allocation of some local arrays c allocate (purine(nseq)) c c set the nucleic acid base and sugar structural type c do i = 1, nseq resname = nuclz(seqtyp(i)) purine(i) = .false. if (resname .eq. ' A') purine(i) = .true. if (resname .eq. ' G') purine(i) = .true. if (resname .eq. ' DA') purine(i) = .true. if (resname .eq. ' DG') purine(i) = .true. deoxy(i) = .false. if (resname .eq. ' DA') deoxy(i) = .true. if (resname .eq. ' DG') deoxy(i) = .true. if (resname .eq. ' DC') deoxy(i) = .true. if (resname .eq. ' DT') deoxy(i) = .true. end do c c set the backbone and glycosidic torsions and sugar pucker c do i = 1, nseq done = .false. do j = 1, 6 if (bkbone(j,i) .ne. 0.0d0) done = .true. end do if (glyco(i) .ne. 0.0d0) done = .true. if (pucker(i) .ne. 0) done = .true. if (.not. done) then if (hlxform .eq. 'A') then bkbone(1,i) = -52.0d0 bkbone(2,i) = 175.0d0 bkbone(3,i) = 42.0d0 bkbone(4,i) = 79.0d0 bkbone(5,i) = -148.0d0 bkbone(6,i) = -75.0d0 glyco(i) = -157.0d0 pucker(i) = 3 else if (hlxform .eq. 'B') then bkbone(1,i) = -30.0d0 bkbone(2,i) = 136.0d0 bkbone(3,i) = 31.0d0 bkbone(4,i) = 143.0d0 bkbone(5,i) = -141.0d0 bkbone(6,i) = -161.0d0 glyco(i) = -98.0d0 pucker(i) = 2 else if (hlxform .eq. 'Z') then if (purine(i)) then bkbone(1,i) = 47.0d0 bkbone(2,i) = 179.0d0 bkbone(3,i) = -169.0d0 bkbone(4,i) = 99.0d0 bkbone(5,i) = -104.0d0 bkbone(6,i) = -69.0d0 glyco(i) = 68.0d0 pucker(i) = 3 else bkbone(1,i) = -137.0d0 bkbone(2,i) = -139.0d0 bkbone(3,i) = 56.0d0 bkbone(4,i) = 138.0d0 bkbone(5,i) = -95.0d0 bkbone(6,i) = 80.0d0 glyco(i) = -159.0d0 pucker(i) = 1 end if end if end if end do c c perform deallocation of some local arrays c deallocate (purine) return end c c c ############################################################## c ## ## c ## subroutine nucchain -- build polynucleotide backbone ## c ## ## c ############################################################## c c c "nucchain" builds up the internal coordinates for a nucleic c acid sequence from the sugar type, backbone and glycosidic c torsional values c c subroutine nucchain use atoms use nucleo use resdue use sequen implicit none integer i,k,m integer poi,o2i,c1i integer c2i,c3i,c4i integer c5i,o3i,o4i,o5i integer phtyp,ophtyp integer ostyp,ottyp logical single,last logical cap3,cap5 character*3 resname c c c initialize the atom counter to the first atom c n = 1 c c check for single residue and 3'- or 5'-phosphate caps c do m = 1, nchain single = .false. last = .false. cap5 = .false. cap3 = .false. if (ichain(1,m) .eq. ichain(2,m)) single = .true. i = ichain(1,m) k = seqtyp(i) resname = nuclz(k) if (resname.eq.' MP' .or. resname.eq.' DP' & .or. resname.eq.' TP') cap5 = .true. i = ichain(2,m) k = seqtyp(i) resname = nuclz(k) if (resname.eq.' MP' .or. resname.eq.' DP' & .or. resname.eq.' TP') cap3 = .true. c c build the first residue or a phosphate capping group; c for now, di- and triphosphate are set to monophosphate c i = ichain(1,m) k = seqtyp(i) resname = nuclz(k) if (resname .eq. ' MP') then if (deoxy(i+1)) then ostyp = 1246 phtyp = 1247 ophtyp = 1248 else ostyp = 1234 phtyp = 1235 ophtyp = 1236 end if if (m .eq. 1) then o3i = n call zatom (ophtyp,0.0d0,0.0d0,0.0d0,0,0,0,0) poi = n call zatom (phtyp,1.52d0,0.0d0,0.0d0,o3i,0,0,0) call zatom (ophtyp,1.52d0,113.0d0,0.0d0,poi,o3i,0,0) else o3i = n call zatom (ophtyp,30.0d0,150.0d0,180.0d0,n-1,n-2,n-3,0) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) poi = n call zatom (phtyp,1.52d0,150.0d0,180.0d0,o3i,n-2,n-3,0) call zatom (ophtyp,1.52d0,113.0d0,180.0d0,poi,o3i,n-3,0) end if call zatom (ophtyp,1.52d0,113.0d0,113.0d0,poi,o3i,n-1,1) o5i = n call zatom (ostyp,1.63d0,106.0d0,106.0d0,poi,o3i,n-2,-1) else if (resname .eq. ' DP') then if (deoxy(i+1)) then ostyp = 1246 phtyp = 1247 ophtyp = 1248 else ostyp = 1234 phtyp = 1235 ophtyp = 1236 end if if (m .eq. 1) then o3i = n call zatom (ophtyp,0.0d0,0.0d0,0.0d0,0,0,0,0) poi = n call zatom (phtyp,1.52d0,0.0d0,0.0d0,o3i,0,0,0) call zatom (ophtyp,1.52d0,113.0d0,0.0d0,poi,o3i,0,0) else o3i = n call zatom (ophtyp,30.0d0,150.0d0,180.0d0,n-1,n-2,n-3,0) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) poi = n call zatom (phtyp,1.52d0,150.0d0,180.0d0,o3i,n-2,n-3,0) call zatom (ophtyp,1.52d0,113.0d0,180.0d0,poi,o3i,n-3,0) end if call zatom (ophtyp,1.52d0,113.0d0,113.0d0,poi,o3i,n-1,1) o5i = n call zatom (ostyp,1.63d0,106.0d0,106.0d0,poi,o3i,n-2,-1) else if (resname .eq. ' TP') then if (deoxy(i+1)) then ostyp = 1246 phtyp = 1247 ophtyp = 1248 else ostyp = 1234 phtyp = 1235 ophtyp = 1236 end if if (m .eq. 1) then o3i = n call zatom (ophtyp,0.0d0,0.0d0,0.0d0,0,0,0,0) poi = n call zatom (phtyp,1.52d0,0.0d0,0.0d0,o3i,0,0,0) call zatom (ophtyp,1.52d0,113.0d0,0.0d0,poi,o3i,0,0) else o3i = n call zatom (ophtyp,30.0d0,150.0d0,180.0d0,n-1,n-2,n-3,0) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) poi = n call zatom (phtyp,1.52d0,150.0d0,180.0d0,o3i,n-2,n-3,0) call zatom (ophtyp,1.52d0,113.0d0,180.0d0,poi,o3i,n-3,0) end if call zatom (ophtyp,1.52d0,113.0d0,113.0d0,poi,o3i,n-1,1) o5i = n call zatom (ostyp,1.63d0,106.0d0,106.0d0,poi,o3i,n-2,-1) else if (deoxy(i)) then ottyp = 1244 else ottyp = 1232 end if if (m .eq. 1) then o5i = n call zatom (ottyp,0.0d0,0.0d0,0.0d0,0,0,0,0) c5i = n call zatom (c5typ(k),1.44d0,0.0d0,0.0d0,o5i,0,0,0) c4i = n call zatom (c4typ(k),1.52d0,110.1d0,0.0d0,c5i,o5i,0,0) else o5i = n call zatom (ottyp,0.96d0,150.0d0,180.0d0,n-1,n-2,n-3,0) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) c5i = n call zatom (c5typ(k),1.44d0,119.0d0,180.0d0, & o5i,n-2,n-3,0) c4i = n call zatom (c4typ(k),1.52d0,110.1d0,180.0d0, & c5i,o5i,n-3,0) end if o4i = n call zatom (o4typ(k),1.46d0,108.9d0,bkbone(3,i)-120.0d0, & c4i,c5i,o5i,0) c1i = n if (pucker(i) .eq. 3) then call zatom (c1typ(k),1.42d0,109.8d0,145.0d0, & o4i,c4i,c5i,0) else if (pucker(i) .eq. 2) then call zatom (c1typ(k),1.42d0,109.8d0,107.0d0, & o4i,c4i,c5i,0) else if (pucker(i) .eq. 1) then call zatom (c1typ(k),1.42d0,109.8d0,140.0d0, & o4i,c4i,c5i,0) end if c3i = n call zatom (c3typ(k),1.53d0,115.9d0,bkbone(3,i), & c4i,c5i,o5i,0) c2i = n call zatom (c2typ(k),1.53d0,102.4d0,bkbone(4,i)+120.0d0, & c3i,c4i,c5i,0) call zatom (-1,0.0d0,0.0d0,0.0d0,c1i,c2i,0,0) o3i = n if (deoxy(i)) then if (single) then call zatom (1249,1.42d0,112.1d0,bkbone(4,i), & c3i,c4i,c5i,0) else call zatom (o3typ(k),1.42d0,112.1d0,bkbone(4,i), & c3i,c4i,c5i,0) end if else if (single) then call zatom (1237,1.42d0,112.1d0,bkbone(4,i), & c3i,c4i,c5i,0) else call zatom (o3typ(k),1.42d0,112.1 d0,bkbone(4,i), & c3i,c4i,c5i,0) end if o2i = n call zatom (o2typ(k),1.43d0,109.5d0,109.5d0, & c2i,c3i,c1i,1) end if call zatom (h5ttyp(k),0.96d0,107.0d0,180.0d0, & o5i,c5i,c4i,0) call zatom (h51typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,1) call zatom (h52typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,-1) call zatom (h4typ(k),1.09d0,109.5d0,109.5d0,c4i,c5i,c3i,-1) if (pucker(i) .eq. 3) then call zatom (h1typ(k),1.09d0,109.5d0,120.0d0, & c1i,o4i,c2i,-1) else if (pucker(i) .eq. 2) then call zatom (h1typ(k),1.09d0,109.5d0,115.0d0, & c1i,o4i,c2i,-1) else if (pucker(i) .eq. 1) then call zatom (h1typ(k),1.09d0,109.5d0,90.0d0, & c1i,o4i,c2i,-1) end if call zatom (h3typ(k),1.09d0,109.5d0,109.5d0,c3i,c4i,c2i,-1) call zatom (h21typ(k),1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,-1) if (deoxy(i)) then call zatom (h22typ(k),1.09d0,109.5d0,109.5d0, & c2i,c3i,c1i,1) else call zatom (h22typ(k),0.96d0,107.0d0,180.0d0, & o2i,c2i,c3i,0) end if if (single) then call zatom (h3ttyp(k),0.96d0,115.0d0,180.0d0, & o3i,c3i,c4i,0) end if call nucbase (resname,i,c1i,o4i,c2i) end if c c build atoms for residues in the middle of the chain c do i = ichain(1,m)+1, ichain(2,m)-1 if (i .eq. ichain(2,m)-1) last = .true. k = seqtyp(i) resname = nuclz(k) if (cap5) then cap5 = .false. else poi = n call zatom (ptyp(k),1.60d0,119.0d0,bkbone(5,i-1), & o3i,c3i,c4i,0) call zatom (optyp(k),1.48d0,109.0d0, & bkbone(6,i-1)+120.0d0,poi,o3i,c3i,0) call zatom (optyp(k),1.48d0,109.0d0, & bkbone(6,i-1)-120.0d0,poi,o3i,c3i,0) o5i = n call zatom (o5typ(k),1.60d0,101.8d0,bkbone(6,i-1), & poi,o3i,c3i,0) end if c5i = n call zatom (c5typ(k),1.44d0,119.0d0,bkbone(1,i), & o5i,poi,o3i,0) c4i = n call zatom (c4typ(k),1.52d0,110.1d0,bkbone(2,i), & c5i,o5i,poi,0) o4i = n call zatom (o4typ(k),1.46d0,108.9d0,bkbone(3,i)-120.0d0, & c4i,c5i,o5i,0) c1i = n if (pucker(i) .eq. 3) then call zatom (c1typ(k),1.42d0,109.8d0,145.0d0, & o4i,c4i,c5i,0) else if (pucker(i) .eq. 2) then call zatom (c1typ(k),1.42d0,109.8d0,107.0d0, & o4i,c4i,c5i,0) else if (pucker(i) .eq. 1) then call zatom (c1typ(k),1.42d0,109.8d0,140.0d0, & o4i,c4i,c5i,0) end if c3i = n call zatom (c3typ(k),1.53d0,115.9d0,bkbone(3,i), & c4i,c5i,o5i,0) c2i = n call zatom (c2typ(k),1.53d0,102.4d0,bkbone(4,i)+120.0d0, & c3i,c4i,c5i,0) call zatom (-1,0.0d0,0.0d0,0.0d0,c1i,c2i,0,0) o3i = n if (deoxy(i)) then if (cap3 .and. last) then call zatom (1251,1.42d0,112.1d0,bkbone(4,i), & c3i,c4i,c5i,0) else call zatom (o3typ(k),1.42d0,112.1d0,bkbone(4,i), & c3i,c4i,c5i,0) end if else if (cap3 .and. last) then call zatom (1239,1.42d0,112.1d0,bkbone(4,i), & c3i,c4i,c5i,0) else call zatom (o3typ(k),1.42d0,112.1d0,bkbone(4,i), & c3i,c4i,c5i,0) end if o2i = n call zatom (o2typ(k),1.43d0,109.5d0,109.5d0, & c2i,c3i,c1i,1) end if call zatom (h51typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,1) call zatom (h52typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,-1) call zatom (h4typ(k),1.09d0,109.5d0,109.5d0,c4i,c5i,c3i,-1) if (pucker(i) .eq. 3) then call zatom (h1typ(k),1.09d0,109.5d0,120.0d0, & c1i,o4i,c2i,-1) else if (pucker(i) .eq. 2) then call zatom (h1typ(k),1.09d0,109.5d0,115.0d0, & c1i,o4i,c2i,-1) else if (pucker(i) .eq. 1) then call zatom (h1typ(k),1.09d0,109.5d0,90.0d0, & c1i,o4i,c2i,-1) end if call zatom (h3typ(k),1.09d0,109.5d0,109.5d0,c3i,c4i,c2i,-1) call zatom (h21typ(k),1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,-1) if (deoxy(i)) then call zatom (h22typ(k),1.09d0,109.5d0,109.5d0, & c2i,c3i,c1i,1) else call zatom (h22typ(k),0.96d0,107.0d0,180.0d0, & o2i,c2i,c3i,0) end if call nucbase (resname,i,c1i,o4i,c2i) end do c c build the last residue or a phosphate capping group; c for now, di- and triphosphate are set to monophosphate c i = ichain(2,m) k = seqtyp(i) resname = nuclz(k) if (single) then continue else if (resname .eq. ' MP') then poi = n if (deoxy(i-1)) then call zatom (1252,1.63d0,119.0d0,bkbone(5,i-1), & o3i,c3i,c4i,0) call zatom (1253,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0) call zatom (1253,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0) call zatom (1253,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0) else call zatom (1240,1.63d0,119.0d0,bkbone(5,i-1), & o3i,c3i,c4i,0) call zatom (1241,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0) call zatom (1241,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0) call zatom (1241,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0) end if else if (resname .eq. ' DP') then poi = n if (deoxy(i-1)) then call zatom (1252,1.63d0,119.0d0,bkbone(5,i-1), & o3i,c3i,c4i,0) call zatom (1253,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0) call zatom (1253,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0) call zatom (1253,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0) else call zatom (1240,1.63d0,119.0d0,bkbone(5,i-1), & o3i,c3i,c4i,0) call zatom (1241,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0) call zatom (1241,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0) call zatom (1241,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0) end if else if (resname .eq. ' TP') then poi = n if (deoxy(i-1)) then call zatom (1252,1.63d0,119.0d0,bkbone(5,i-1), & o3i,c3i,c4i,0) call zatom (1253,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0) call zatom (1253,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0) call zatom (1253,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0) else call zatom (1240,1.63d0,119.0d0,bkbone(5,i-1), & o3i,c3i,c4i,0) call zatom (1241,1.52d0,106.0d0,60.0d0,poi,o3i,c3i,0) call zatom (1241,1.52d0,106.0d0,-60.0d0,poi,o3i,c3i,0) call zatom (1241,1.52d0,106.0d0,180.0d0,poi,o3i,c3i,0) end if else if (cap5) then cap5 = .false. else poi = n call zatom (ptyp(k),1.60d0,119.0d0,bkbone(5,i-1), & o3i,c3i,c4i,0) call zatom (optyp(k),1.48d0,109.0d0, & bkbone(6,i-1)+120.0d0,poi,o3i,c3i,0) call zatom (optyp(k),1.48d0,109.0d0, & bkbone(6,i-1)-120.0d0,poi,o3i,c3i,0) o5i = n call zatom (o5typ(k),1.60d0,101.8d0,bkbone(6,i-1), & poi,o3i,c3i,0) end if c5i = n call zatom (c5typ(k),1.44d0,119.0d0,bkbone(1,i), & o5i,poi,o3i,0) c4i = n call zatom (c4typ(k),1.52d0,110.1d0,bkbone(2,i), & c5i,o5i,poi,0) o4i = n call zatom (o4typ(k),1.46d0,108.9d0,bkbone(3,i)-120.0d0, & c4i,c5i,o5i,0) c1i = n if (pucker(i) .eq. 3) then call zatom (c1typ(k),1.42d0,109.8d0,145.0d0, & o4i,c4i,c5i,0) else if (pucker(i) .eq. 2) then call zatom (c1typ(k),1.42d0,109.8d0,107.0d0, & o4i,c4i,c5i,0) else if (pucker(i) .eq. 1) then call zatom (c1typ(k),1.42d0,109.8d0,140.0d0, & o4i,c4i,c5i,0) end if c3i = n call zatom (c3typ(k),1.53d0,115.9d0,bkbone(3,i), & c4i,c5i,o5i,0) c2i = n call zatom (c2typ(k),1.53d0,102.4d0,bkbone(4,i)+120.0d0, & c3i,c4i,c5i,0) call zatom (-1,0.0d0,0.0d0,0.0d0,c1i,c2i,0,0) o3i = n if (deoxy(i)) then call zatom (1249,1.42d0,112.1d0,bkbone(4,i), & c3i,c4i,c5i,0) else call zatom (1237,1.42d0,112.1d0,bkbone(4,i), & c3i,c4i,c5i,0) o2i = n call zatom (o2typ(k),1.43d0,109.5d0,109.5d0, & c2i,c3i,c1i,1) end if call zatom (h51typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,1) call zatom (h52typ(k),1.09d0,109.5d0,109.5d0,c5i,o5i,c4i,-1) call zatom (h4typ(k),1.09d0,109.5d0,109.5d0,c4i,c5i,c3i,-1) if (pucker(i) .eq. 3) then call zatom (h1typ(k),1.09d0,109.5d0,120.0d0, & c1i,o4i,c2i,-1) else if (pucker(i) .eq. 2) then call zatom (h1typ(k),1.09d0,109.5d0,115.0d0, & c1i,o4i,c2i,-1) else if (pucker(i) .eq. 1) then call zatom (h1typ(k),1.09d0,109.5d0,90.0d0, & c1i,o4i,c2i,-1) end if call zatom (h3typ(k),1.09d0,109.5d0,109.5d0,c3i,c4i,c2i,-1) call zatom (h21typ(k),1.09d0,109.5d0,109.5d0,c2i,c3i,c1i,-1) if (deoxy(i)) then call zatom (h22typ(k),1.09d0,109.5d0,109.5d0, & c2i,c3i,c1i,1) else call zatom (h22typ(k),0.96d0,107.0d0,180.0d0, & o2i,c2i,c3i,0) end if call zatom (h3ttyp(k),0.96d0,115.0d0,180.0d0,o3i,c3i,c4i,0) call nucbase (resname,i,c1i,o4i,c2i) end if end do c c finally, set the total number of atoms c n = n - 1 return end c c c ################################################################ c ## ## c ## subroutine nucbase -- build nucleotide base side chain ## c ## ## c ################################################################ c c c "nucbase" builds the side chain for a single nucleotide base c in terms of internal coordinates c c resname 3-letter name of current nucleotide residue c i number of the current nucleotide residue c c1i atom number of carbon C1' in residue i c o4i atom number of oxygen O4' in residue i c c2i atom number of carbon C2' in residue i c c literature references: c c R. Lavery, K. Zakrzewska, "Base and Base Pair Morphologies, c Helical Parameters, and Definitions" in "Oxford Handbook of c Nucleic Acid Structure", S. Neidel, Editor, Oxford University c Press, 1999, pages 40-42 c c W. Saenger, "Principles of Nucleic Acid Structure", Springer- c Verlag, 1984, page 52 c c subroutine nucbase (resname,i,c1i,o4i,c2i) use atoms use nucleo implicit none integer i,c1i,o4i,c2i character*3 resname c c c adenine in adenosine residue (A) c if (resname .eq. ' A') then call zatom (1017,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1) call zatom (1021,1.37d0,128.4d0,glyco(i)+180.0d0, & n-1,c1i,o4i,0) call zatom (1020,1.30d0,113.8d0,180.0d0,n-1,n-2,c1i,0) call zatom (1019,1.39d0,104.0d0,0.0d0,n-1,n-2,n-3,0) call zatom (1025,1.40d0,132.4d0,180.0d0,n-1,n-2,n-3,0) call zatom (1027,1.34d0,123.5d0,0.0d0,n-1,n-2,n-3,0) call zatom (1024,1.35d0,117.4d0,180.0d0,n-2,n-3,n-4,0) call zatom (1023,1.33d0,118.8d0,0.0d0,n-1,n-3,n-4,0) call zatom (1022,1.32d0,129.2d0,0.0d0,n-1,n-2,n-4,0) call zatom (1018,1.35d0,110.9d0,0.0d0,n-1,n-2,n-3,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-7,0,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-10,0,0) call zatom (1030,1.08d0,123.1d0,180.0d0,n-9,n-8,n-7,0) call zatom (1028,1.00d0,120.0d0,180.0d0,n-6,n-7,n-8,0) call zatom (1029,1.00d0,120.0d0,0.0d0,n-7,n-8,n-9,0) call zatom (1026,1.08d0,115.4d0,180.0d0,n-6,n-5,n-4,0) c c guanine in guanosine residue (G) c else if (resname .eq. ' G') then call zatom (1047,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1) call zatom (1051,1.38d0,128.4d0,glyco(i)+180.0d0, & n-1,c1i,o4i,0) call zatom (1050,1.31d0,114.0d0,180.0d0,n-1,n-2,c1i,0) call zatom (1049,1.39d0,103.8d0,0.0d0,n-1,n-2,n-3,0) call zatom (1055,1.40d0,130.1d0,180.0d0,n-1,n-2,n-3,0) call zatom (1060,1.23d0,128.8d0,0.0d0,n-1,n-2,n-3,0) call zatom (1054,1.40d0,111.4d0,180.0d0,n-2,n-3,n-4,0) call zatom (1053,1.38d0,125.2d0,0.0d0,n-1,n-3,n-4,0) call zatom (1057,1.34d0,116.1d0,180.0d0,n-1,n-2,n-4,0) call zatom (1052,1.33d0,123.3d0,0.0d0,n-2,n-3,n-4,0) call zatom (1048,1.36d0,112.3d0,0.0d0,n-1,n-3,n-4,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-8,0,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-11,0,0) call zatom (1061,1.08d0,123.0d0,180.0d0,n-10,n-9,n-8,0) call zatom (1056,1.00d0,117.4d0,180.0d0,n-6,n-8,n-9,0) call zatom (1058,1.00d0,120.0d0,0.0d0,n-5,n-6,n-7,0) call zatom (1059,1.00d0,120.0d0,180.0d0,n-6,n-7,n-8,0) c c cytosine in cytidine residue (C) c else if (resname .eq. ' C') then call zatom (1078,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1) call zatom (1079,1.37d0,117.8d0,glyco(i),n-1,c1i,o4i,0) call zatom (1084,1.24d0,118.9d0,0.0d0,n-1,n-2,c1i,0) call zatom (1080,1.38d0,118.7d0,180.0d0,n-2,n-3,c1i,0) call zatom (1081,1.34d0,120.6d0,0.0d0,n-1,n-3,n-4,0) call zatom (1085,1.32d0,118.3d0,180.0d0,n-1,n-2,n-4,0) call zatom (1082,1.43d0,121.6d0,0.0d0,n-2,n-3,n-5,0) call zatom (1083,1.36d0,116.9d0,0.0d0,n-1,n-3,n-4,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-8,0,0) call zatom (1086,1.00d0,120.0d0,0.0d0,n-3,n-4,n-5,0) call zatom (1087,1.00d0,120.0d0,180.0d0,n-4,n-5,n-6,0) call zatom (1088,1.08d0,121.6d0,180.0d0,n-4,n-6,n-7,0) call zatom (1089,1.08d0,119.5d0,180.0d0,n-4,n-5,n-7,0) c c uracil in uridine residue (U) c else if (resname .eq. ' U') then call zatom (1106,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1) call zatom (1107,1.38d0,117.1d0,glyco(i),n-1,c1i,o4i,0) call zatom (1112,1.22d0,123.2d0,0.0d0,n-1,n-2,c1i,0) call zatom (1108,1.37d0,114.8d0,180.0d0,n-2,n-3,c1i,0) call zatom (1109,1.38d0,127.0d0,0.0d0,n-1,n-3,n-4,0) call zatom (1114,1.23d0,119.8d0,180.0d0,n-1,n-2,n-4,0) call zatom (1110,1.44d0,114.7d0,0.0d0,n-2,n-3,n-5,0) call zatom (1111,1.34d0,119.2d0,0.0d0,n-1,n-3,n-4,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-8,0,0) call zatom (1113,1.00d0,116.5d0,180.0d0,n-5,n-7,n-8,0) call zatom (1115,1.08d0,120.4d0,180.0d0,n-3,n-5,n-6,0) call zatom (1116,1.08d0,118.6d0,180.0d0,n-3,n-4,n-6,0) c c adenine in deoxyadenosine residue (DA) c else if (resname .eq. ' DA') then call zatom (1132,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1) call zatom (1136,1.37d0,128.4d0,glyco(i)+180.0d0, & n-1,c1i,o4i,0) call zatom (1135,1.30d0,113.8d0,180.0d0,n-1,n-2,c1i,0) call zatom (1134,1.39d0,104.0d0,0.0d0,n-1,n-2,n-3,0) call zatom (1140,1.40d0,132.4d0,180.0d0,n-1,n-2,n-3,0) call zatom (1142,1.34d0,123.5d0,0.0d0,n-1,n-2,n-3,0) call zatom (1139,1.35d0,117.4d0,180.0d0,n-2,n-3,n-4,0) call zatom (1138,1.33d0,118.8d0,0.0d0,n-1,n-3,n-4,0) call zatom (1137,1.32d0,129.2d0,0.0d0,n-1,n-2,n-4,0) call zatom (1133,1.35d0,110.9d0,0.0d0,n-1,n-2,n-3,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-7,0,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-10,0,0) call zatom (1145,1.08d0,123.1d0,180.0d0,n-9,n-8,n-7,0) call zatom (1143,1.00d0,120.0d0,180.0d0,n-6,n-7,n-8,0) call zatom (1144,1.00d0,120.0d0,0.0d0,n-7,n-8,n-9,0) call zatom (1141,1.08d0,115.4d0,180.0d0,n-6,n-5,n-4,0) c c guanine in deoxyguanosine residue (DG) c else if (resname .eq. ' DG') then call zatom (1161,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1) call zatom (1165,1.38d0,128.4d0,glyco(i)+180.0d0, & n-1,c1i,o4i,0) call zatom (1164,1.31d0,114.0d0,180.0d0,n-1,n-2,c1i,0) call zatom (1163,1.39d0,103.8d0,0.0d0,n-1,n-2,n-3,0) call zatom (1169,1.40d0,130.1d0,180.0d0,n-1,n-2,n-3,0) call zatom (1174,1.23d0,128.8d0,0.0d0,n-1,n-2,n-3,0) call zatom (1168,1.40d0,111.4d0,180.0d0,n-2,n-3,n-4,0) call zatom (1167,1.38d0,125.2d0,0.0d0,n-1,n-3,n-4,0) call zatom (1171,1.34d0,116.1d0,180.0d0,n-1,n-2,n-4,0) call zatom (1166,1.33d0,123.3d0,0.0d0,n-2,n-3,n-4,0) call zatom (1162,1.36d0,112.3d0,0.0d0,n-1,n-3,n-4,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-8,0,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-11,0,0) call zatom (1175,1.08d0,123.0d0,180.0d0,n-10,n-9,n-8,0) call zatom (1170,1.00d0,117.4d0,180.0d0,n-6,n-8,n-9,0) call zatom (1172,1.00d0,120.0d0,0.0d0,n-5,n-6,n-7,0) call zatom (1173,1.00d0,120.0d0,180.0d0,n-6,n-7,n-8,0) c c cytosine in deoxycytidine residue (DC) c else if (resname .eq. ' DC') then call zatom (1191,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1) call zatom (1192,1.37d0,117.8d0,glyco(i),n-1,c1i,o4i,0) call zatom (1197,1.24d0,118.9d0,0.0d0,n-1,n-2,c1i,0) call zatom (1193,1.38d0,118.7d0,180.0d0,n-2,n-3,c1i,0) call zatom (1194,1.34d0,120.6d0,0.0d0,n-1,n-3,n-4,0) call zatom (1198,1.32d0,118.3d0,180.0d0,n-1,n-2,n-4,0) call zatom (1195,1.43d0,121.6d0,0.0d0,n-2,n-3,n-5,0) call zatom (1196,1.36d0,116.9d0,0.0d0,n-1,n-3,n-4,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-8,0,0) call zatom (1199,1.00d0,120.0d0,0.0d0,n-3,n-4,n-5,0) call zatom (1200,1.00d0,120.0d0,180.0d0,n-4,n-5,n-6,0) call zatom (1201,1.08d0,121.6d0,180.0d0,n-4,n-6,n-7,0) call zatom (1202,1.08d0,119.5d0,180.0d0,n-4,n-5,n-7,0) c c thymine in deoxythymidine residue (DT) c else if (resname .eq. ' DT') then call zatom (1218,1.48d0,108.1d0,113.7d0,c1i,o4i,c2i,1) call zatom (1219,1.37d0,117.1d0,glyco(i),n-1,c1i,o4i,0) call zatom (1224,1.22d0,122.9d0,0.0d0,n-1,n-2,c1i,0) call zatom (1220,1.38d0,115.4d0,180.0d0,n-2,n-3,c1i,0) call zatom (1221,1.38d0,126.4d0,0.0d0,n-1,n-3,n-4,0) call zatom (1226,1.23d0,120.5d0,180.0d0,n-1,n-2,n-4,0) call zatom (1222,1.44d0,114.1d0,0.0d0,n-2,n-3,n-5,0) call zatom (1227,1.50d0,117.5d0,180.0d0,n-1,n-3,n-4,0) call zatom (1223,1.34d0,120.8d0,0.0d0,n-2,n-4,n-5,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-1,n-9,0,0) call zatom (1225,1.00d0,116.8d0,180.0d0,n-6,n-8,n-9,0) call zatom (1228,1.09d0,109.5d0,0.0d0,n-3,n-4,n-6,0) call zatom (1228,1.09d0,109.5d0,109.5d0,n-4,n-5,n-1,1) call zatom (1228,1.09d0,109.5d0,109.5d0,n-5,n-6,n-2,-1) call zatom (1229,1.08d0,119.4d0,180.0d0,n-5,n-7,n-9,0) end if return end c c c ############################################################## c ## ## c ## subroutine watson -- align strands of a double helix ## c ## ## c ############################################################## c c c "watson" uses a rigid body optimization to approximately c align the paired strands of a nucleic acid double helix c c subroutine watson use atoms use couple use group use inform use katoms use molcul use nucleo use output use potent use resdue use restrn use rigid use sequen use usage implicit none integer i,j,nvar integer ia,ib,ic,id integer start,stop integer kseq,offset integer nbase,nphos integer, allocatable :: iphos(:) integer, allocatable :: root(:) integer, allocatable :: list(:,:) real*8 minimum,grdmin real*8 watson1,sum,dist real*8, allocatable :: xx(:) character*3 resname external watson1,optsave c c c perform dynamic allocation of some global arrays c if (.not. allocated(iuse)) allocate (iuse(n)) if (.not. allocated(use)) allocate (use(0:n)) c c set all atoms to be active during energy evaluations c nuse = n do i = 1, n use(i) = .true. end do c c only geometric restraints will by used in optimization c call potoff use_geom = .true. c c set the default values for the restraint variables c npfix = 0 ndfix = 0 ntfix = 0 ngfix = 0 nchir = 0 use_basin = .false. use_wall = .false. c c perform dynamic allocation of some local arrays c allocate (iphos(nseq+10)) allocate (root(nseq)) allocate (list(2,nseq)) c c find root atom and hydrogen bond partners for each base c kseq = 0 nbase = 0 do i = 1, n if (atmnum(type(i)).eq.6 .and. n12(i).eq.4) then ia = atmnum(type(i12(1,i))) ib = atmnum(type(i12(2,i))) ic = atmnum(type(i12(3,i))) id = atmnum(type(i12(4,i))) sum = ia + ib + ic + id if (sum .eq. 22) then nbase = nbase + 1 j = i12(4,i) root(nbase) = j kseq = kseq + 1 resname = nuclz(seqtyp(kseq)) do while (resname.eq.' MP' .or. resname.eq.' DP' & .or. resname.eq.' TP') kseq = kseq + 1 resname = nuclz(seqtyp(kseq)) end do if (resname.eq.' A' .or. resname.eq.' DA') then list(1,nbase) = j + 6 list(2,nbase) = j + 11 else if (resname.eq.' G' .or. resname.eq.' DG') then list(1,nbase) = j + 12 list(2,nbase) = j + 5 else if (resname.eq.' C' .or. resname.eq.' DC') then list(1,nbase) = j + 3 list(2,nbase) = j + 8 else if (resname .eq. ' U') then list(1,nbase) = j + 8 list(2,nbase) = j + 5 else if (resname .eq. ' DT') then list(1,nbase) = j + 9 list(2,nbase) = j + 5 end if end if end if end do c c perform dynamic allocation of some global arrays c maxfix = 3 * nbase if (allocated(idfix)) deallocate(idfix) if (allocated(dfix)) deallocate(dfix) if (allocated(itfix)) deallocate(itfix) if (allocated(tfix)) deallocate(tfix) allocate (idfix(2,maxfix)) allocate (dfix(3,maxfix)) allocate (itfix(4,maxfix)) allocate (tfix(3,maxfix)) c c distance restraints for the base pair hydrogen bonds c do i = 1, nbase/2 j = nbase + 1 - i ndfix = ndfix + 1 idfix(1,ndfix) = list(1,i) idfix(2,ndfix) = list(1,j) dfix(1,ndfix) = 50.0d0 dfix(2,ndfix) = 1.85d0 dfix(3,ndfix) = 1.95d0 ndfix = ndfix + 1 idfix(1,ndfix) = list(2,i) idfix(2,ndfix) = list(2,j) dfix(1,ndfix) = 50.0d0 dfix(2,ndfix) = 1.85d0 dfix(3,ndfix) = 1.95d0 end do c c torsional restraints to enforce base pair planarity c do i = 1, nbase/2 j = nbase + 1 - i ntfix = ntfix + 1 itfix(1,ntfix) = root(i) itfix(2,ntfix) = list(1,i) itfix(3,ntfix) = list(2,i) itfix(4,ntfix) = list(1,j) tfix(1,ntfix) = 2.5d0 tfix(2,ntfix) = 180.0d0 tfix(3,ntfix) = 180.0d0 ntfix = ntfix + 1 itfix(1,ntfix) = root(i) itfix(2,ntfix) = list(2,i) itfix(3,ntfix) = list(1,i) itfix(4,ntfix) = list(2,j) tfix(1,ntfix) = 2.5d0 tfix(2,ntfix) = 180.0d0 tfix(3,ntfix) = 180.0d0 ntfix = ntfix + 1 itfix(1,ntfix) = root(j) itfix(2,ntfix) = list(1,j) itfix(3,ntfix) = list(2,j) itfix(4,ntfix) = list(1,i) tfix(1,ntfix) = 2.5d0 tfix(2,ntfix) = 180.0d0 tfix(3,ntfix) = 180.0d0 ntfix = ntfix + 1 itfix(1,ntfix) = root(j) itfix(2,ntfix) = list(2,j) itfix(3,ntfix) = list(1,j) itfix(4,ntfix) = list(2,i) tfix(1,ntfix) = 2.5d0 tfix(2,ntfix) = 180.0d0 tfix(3,ntfix) = 180.0d0 end do c c distance restraints between interstrand phosphates c nphos = 0 do i = 1, n if (atmnum(type(i)) .eq. 15) then nphos = nphos + 1 iphos(nphos) = i end if end do start = 1 stop = nphos / 2 resname = nuclz(seqtyp(1)) if (resname .eq. ' MP') start = start + 1 if (resname .eq. ' DP') start = start + 2 if (resname .eq. ' TP') start = start + 3 resname = nuclz(seqtyp(nseq)) if (resname .eq. ' MP') stop = stop - 1 if (resname .eq. ' DP') stop = stop - 2 if (resname .eq. ' TP') stop = stop - 3 offset = stop + nphos/2 + 1 if (hlxform .eq. 'A') dist = 17.78d0 if (hlxform .eq. 'B') dist = 17.46d0 if (hlxform .eq. 'Z') dist = 13.2d0 do i = start, stop ndfix = ndfix + 1 idfix(1,ndfix) = iphos(i) idfix(2,ndfix) = iphos(offset-i) dfix(1,ndfix) = 100.0d0 dfix(2,ndfix) = dist dfix(3,ndfix) = dist end do c c perform deallocation of some local arrays c deallocate (iphos) deallocate (root) deallocate (list) c c enable use of groups based on number of molecules c use_group = .true. ngrp = nmol c c perform dynamic allocation of some global arrays c if (.not. allocated(kgrp)) allocate (kgrp(n)) if (.not. allocated(grplist)) allocate (grplist(n)) if (.not. allocated(igrp)) allocate (igrp(2,0:ngrp)) if (.not. allocated(grpmass)) allocate (grpmass(0:ngrp)) if (.not. allocated(wgrp)) allocate (wgrp(0:ngrp,0:ngrp)) c c assign each strand to a separate molecule-based group c do i = 1, ngrp igrp(1,i) = imol(1,i) igrp(2,i) = imol(2,i) do j = igrp(1,i), igrp(2,i) kgrp(j) = kmol(j) grplist(kgrp(j)) = i end do end do do i = 0, ngrp do j = 0, ngrp wgrp(j,i) = 1.0d0 end do wgrp(i,i) = 0.0d0 end do c c get rigid body reference coordinates for each strand c call orient c c perform dynamic allocation of some local arrays c allocate (xx(6*ngrp)) c c convert rigid body coordinates to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 xx(nvar) = rbc(j,i) end do end do c c make the call to the optimization routine c iprint = 0 iwrite = 0 grdmin = 0.1d0 coordtype = 'NONE' call ocvm (nvar,xx,minimum,grdmin,watson1,optsave) c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c perform deallocation of some local arrays c deallocate (xx) c c convert from rigid body to Cartesian coordinates c call rigidxyz return end c c c ############################################################ c ## ## c ## function watson1 -- energy and gradient for watson ## c ## ## c ############################################################ c c c "watson1" is a service routine that computes the energy c and gradient for optimally conditioned variable metric c optimization of rigid bodies c c function watson1 (xx,g) use group use math use rigid implicit none integer i,j,nvar real*8 watson1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) c c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c perform dynamic allocation of some local arrays c allocate (derivs(6,ngrp)) c c compute and store the energy and gradient c call rigidxyz call gradrgd (e,derivs) watson1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 g(nvar) = derivs(j,i) end do end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ############################################################# c ## COPYRIGHT (C) 1999 by ## c ## Marina A. Vorobieva, Nina N. Sokolova & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################# c c ################################################################ c ## ## c ## module nucleo -- parameters for nucleic acid structure ## c ## ## c ################################################################ c c c pucker sugar pucker, either 2=2'-endo or 3=3'-endo c glyco glycosidic torsional angle for each nucleotide c bkbone phosphate backbone angles for each nucleotide c dblhlx flag to mark system as nucleic acid double helix c deoxy flag to mark deoxyribose or ribose sugar units c hlxform helix form (A, B or Z) of polynucleotide strands c c module nucleo use sizes implicit none integer pucker(maxres) real*8 glyco(maxres) real*8 bkbone(6,maxres) logical dblhlx logical deoxy(maxres) character*1 hlxform save end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################## c ## ## c ## function number -- convert text string to number ## c ## ## c ########################################################## c c c "number" converts a text numeral into an integer value; c the input string must contain only numeric characters c c function number (string) use inform use iounit implicit none integer i,j,number integer first,last,trimtext integer digit,place(10) character*1 letter character*(*) string data place / 1, 10, 100, 1000, 10000, 100000, 1000000, & 10000000, 100000000, 1000000000 / c c c initialize the integer value of number to zero c number = 0 c c get the first and last nonblank characters c last = trimtext (string) if (last .gt. 10) then write (iout,10) 10 format (' NUMBER -- Input Text String is Too Long') return end if first = 1 do i = 1, last letter = string(i:i) if (letter .ne. ' ') then first = i goto 20 end if end do 20 continue c c convert the text numeral into an integer number c j = 0 do i = last, first, -1 j = j + 1 letter = string(i:i) if (letter .eq. '0') then digit = 0 else if (letter .eq. '1') then digit = 1 else if (letter .eq. '2') then digit = 2 else if (letter .eq. '3') then digit = 3 else if (letter .eq. '4') then digit = 4 else if (letter .eq. '5') then digit = 5 else if (letter .eq. '6') then digit = 6 else if (letter .eq. '7') then digit = 7 else if (letter .eq. '8') then digit = 8 else if (letter .eq. '9') then digit = 9 else if (debug) then write (iout,30) 30 format (/,' NUMBER -- Non-Numeric Characters Found', & ' in Numeral String') end if number = 0 goto 40 end if number = number + digit * place(j) end do 40 continue return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine numeral -- convert number to text string ## c ## ## c ############################################################# c c c "numeral" converts an input integer number into the c corresponding right- or left-justified text numeral c c number integer value of the number to be transformed c string text string to be filled with corresponding numeral c size on input, the minimal acceptable numeral length, if c zero then output will be right justified, if c nonzero then numeral is left-justified and padded c with leading zeros as necessary; upon output, the c number of non-blank characters in the numeral c c subroutine numeral (number,string,size) implicit none integer i,j integer number,size integer multi,pos,len integer length,minsize integer hunmill,tenmill integer million,hunthou integer tenthou,thousand integer hundred,tens,ones logical right,negative character*1 digit(0:9) character*(*) string data digit / '0','1','2','3','4','5','6','7','8','9' / c c c set justification and size bounds for numeral string c if (size .eq. 0) then right = .true. size = 1 else right = .false. end if minsize = size length = len(string) c c test the sign of the original number c if (number .ge. 0) then negative = .false. else negative = .true. number = -number end if c c use modulo arithmetic to find place-holding digits c hunmill = number / 100000000 multi = 100000000 * hunmill tenmill = (number-multi) / 10000000 multi = multi + 10000000*tenmill million = (number-multi) / 1000000 multi = multi + 1000000*million hunthou = (number-multi) / 100000 multi = multi + 100000*hunthou tenthou = (number-multi) / 10000 multi = multi + 10000*tenthou thousand = (number-multi) / 1000 multi = multi + 1000*thousand hundred = (number-multi) / 100 multi = multi + 100*hundred tens = (number-multi) / 10 multi = multi + 10*tens ones = number - multi c c find the correct length to be used for the numeral c if (hunmill .ne. 0) then size = 9 else if (tenmill .ne. 0) then size = 8 else if (million .ne. 0) then size = 7 else if (hunthou .ne. 0) then size = 6 else if (tenthou .ne. 0) then size = 5 else if (thousand .ne. 0) then size = 4 else if (hundred .ne. 0) then size = 3 else if (tens .ne. 0) then size = 2 else size = 1 end if size = min(size,length) size = max(size,minsize) c c convert individual digits to a string of numerals c if (size .eq. 9) then string(1:1) = digit(hunmill) string(2:2) = digit(tenmill) string(3:3) = digit(million) string(4:4) = digit(hunthou) string(5:5) = digit(tenthou) string(6:6) = digit(thousand) string(7:7) = digit(hundred) string(8:8) = digit(tens) string(9:9) = digit(ones) else if (size .eq. 8) then string(1:1) = digit(tenmill) string(2:2) = digit(million) string(3:3) = digit(hunthou) string(4:4) = digit(tenthou) string(5:5) = digit(thousand) string(6:6) = digit(hundred) string(7:7) = digit(tens) string(8:8) = digit(ones) else if (size .eq. 7) then string(1:1) = digit(million) string(2:2) = digit(hunthou) string(3:3) = digit(tenthou) string(4:4) = digit(thousand) string(5:5) = digit(hundred) string(6:6) = digit(tens) string(7:7) = digit(ones) else if (size .eq. 6) then string(1:1) = digit(hunthou) string(2:2) = digit(tenthou) string(3:3) = digit(thousand) string(4:4) = digit(hundred) string(5:5) = digit(tens) string(6:6) = digit(ones) else if (size .eq. 5) then string(1:1) = digit(tenthou) string(2:2) = digit(thousand) string(3:3) = digit(hundred) string(4:4) = digit(tens) string(5:5) = digit(ones) else if (size .eq. 4) then string(1:1) = digit(thousand) string(2:2) = digit(hundred) string(3:3) = digit(tens) string(4:4) = digit(ones) else if (size .eq. 3) then string(1:1) = digit(hundred) string(2:2) = digit(tens) string(3:3) = digit(ones) else if (size .eq. 2) then string(1:1) = digit(tens) string(2:2) = digit(ones) else string(1:1) = digit(ones) end if c c right- or left-justify as desired, with padding c if (right) then do i = size, 1, -1 pos = length - size + i string(pos:pos) = string(i:i) end do do i = 1, length-size string(i:i) = ' ' end do else do i = size+1, length string(i:i) = ' ' end do end if c c handle negative numbers, if possible to do so c if (negative) then number = -number if (right) then pos = length - size if (pos .ne. 0) then string(pos:pos) = '-' size = min(size,length) end if else do i = 1, size if (string(i:i) .ne. '0') then if (i .eq. 1) then if (size .lt. length) then do j = size, 1, -1 string(j+1:j+1) = string(j:j) end do string(1:1) = '-' end if size = size + 1 else string(i-1:i-1) = '-' end if goto 10 end if end do 10 continue end if 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 numgrad -- numerical gradient of a function ## c ## ## c ################################################################ c c c "numgrad" computes the gradient of the objective function c "evalue" with respect to Cartesian coordinates of the atoms c via a one-sided or two-sided numerical differentiation c c subroutine numgrad (evalue,g,eps) use atoms implicit none integer i real*8 evalue,eps real*8 e,e0,old real*8 g(3,*) logical twosided external evalue c c c chose between use of one-sided or two-sided gradient c twosided = .true. if (.not. twosided) e0 = evalue () c c compute the numerical gradient from function values c do i = 1, n old = x(i) if (twosided) then x(i) = x(i) - 0.5d0*eps e0 = evalue () end if x(i) = x(i) + eps e = evalue () x(i) = old g(1,i) = (e - e0) / eps old = y(i) if (twosided) then y(i) = y(i) - 0.5d0*eps e0 = evalue () end if y(i) = y(i) + eps e = evalue () y(i) = old g(2,i) = (e - e0) / eps old = z(i) if (twosided) then z(i) = z(i) - 0.5d0*eps e0 = evalue () end if z(i) = z(i) + eps e = evalue () z(i) = old g(3,i) = (e - e0) / eps 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 ocvm -- variable metric optimization method ## c ## ## c ################################################################ c c c "ocvm" implements an optimally conditioned variable metric c nonlinear optimization routine without line searches c c literature references: c c W. C. Davidon, "Optimally Conditioned Optimization Algorithms c Without Line Searches", Mathematical Programming, 9, 1-30 (1975) c c D. F. Shanno and K-H. Phua, "Matrix Conditioning and Nonlinear c Optimization", Mathematical Programming, 14, 149-16 (1977) c c D. F. Shanno and K-H. Phua, "Numerical Comparison of Several c Variable-Metric Algorithms", Journal of Optimization Theory c and Applications, 25, 507-518 (1978) c c variables and parameters: c c nvar number of parameters in the objective function c x0 contains starting point upon input, upon return c contains the best point found c f0 during optimization contains best current function c value; returns final best function value c grdmin normal exit if rms gradient gets below this value c ncalls total number of function/gradient evaluations c c required external routines: c c fgvalue function to evaluate function and gradient values c optsave subroutine to write out info about current status c c subroutine ocvm (nvar,x0,f0,grdmin,fgvalue,optsave) use inform use iounit use keys use linmin use math use minima use output use potent use scales implicit none integer i,j,nvar integer mvar,next integer niter,ncalls integer nbig,nstep integer maxbig,maxstep real*8 fgvalue,eps real*8 f,f0,f0old real*8 fprime,f0prime real*8 grdmin,srchnorm real*8 sgangle,sg,snorm real*8 zeta,cosang real*8 fmove,xmove real*8 gnorm,grms,rms real*8 m2,n2,u2,v real*8 micron,mw,us,qk0 real*8 a,b,b0,c real*8 alpha,gamma,delta real*8 x0(*) real*8, allocatable :: x0old(:) real*8, allocatable :: x(:) real*8, allocatable :: g(:) real*8, allocatable :: hq(:) real*8, allocatable :: search(:) real*8, allocatable :: s(:) real*8, allocatable :: w(:) real*8, allocatable :: k(:) real*8, allocatable :: k0(:) real*8, allocatable :: m(:) real*8, allocatable :: n(:) real*8, allocatable :: p(:) real*8, allocatable :: q(:) real*8, allocatable :: u(:) real*8, allocatable :: h(:,:) logical restart,done character*9 status character*20 keyword character*240 record character*240 string external fgvalue,optsave c c c initialization and set-up for the optimization c mvar = nvar rms = sqrt(dble(nvar)) if (coordtype .eq. 'CARTESIAN') then rms = rms / sqrt(3.0d0) else if (coordtype .eq. 'RIGIDBODY') then rms = rms / sqrt(6.0d0) end if maxbig = 2 maxstep = 10 eps = 1.0d-16 restart = .true. done = .false. c c perform dynamic allocation of some global arrays c if (.not. allocated(scale)) allocate (scale(nvar)) c c set default values for variable scale factors c if (.not. set_scale) then do i = 1, nvar if (scale(i) .eq. 0.0d0) scale(i) = 1.0d0 end do end if c c set default parameters for the optimization c if (fctmin .eq. 0.0d0) fctmin = -100000000.0d0 if (maxiter .eq. 0) maxiter = 1000000 if (nextiter .eq. 0) nextiter = 1 if (iprint .lt. 0) iprint = 1 if (iwrite .lt. 0) iwrite = 1 if (stpmax .eq. 0.0d0) stpmax = 5.0d0 if (hguess .eq. 0.0d0) hguess = 0.4d0 angmax = 180.0d0 c c search the keywords for optimization parameters c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:7) .eq. 'FCTMIN ') then read (string,*,err=10,end=10) fctmin else if (keyword(1:8) .eq. 'MAXITER ') then read (string,*,err=10,end=10) maxiter else if (keyword(1:9) .eq. 'NEXTITER ') then read (string,*,err=10,end=10) nextiter else if (keyword(1:7) .eq. 'HGUESS ') then read (string,*,err=10,end=10) hguess else if (keyword(1:8) .eq. 'STEPMAX ') then read (string,*,err=10,end=10) stpmax else if (keyword(1:7) .eq. 'ANGMAX ') then read (string,*,err=10,end=10) angmax end if 10 continue end do c c print initial information prior to first iteration c if (iprint .gt. 0) then write (iout,20) 20 format (/,' Optimally Conditioned Variable Metric', & ' Optimization :') write (iout,30) 30 format (/,' VM Iter F Value G RMS F Move', & ' X Move Angle FG Call') flush (iout) end if c c perform dynamic allocation of some local arrays c allocate (x0old(nvar)) allocate (x(nvar)) allocate (g(nvar)) allocate (hq(nvar)) allocate (search(nvar)) allocate (s(mvar)) allocate (w(mvar)) allocate (k(mvar)) allocate (k0(mvar)) allocate (m(mvar)) allocate (n(mvar)) allocate (p(mvar)) allocate (q(mvar)) allocate (u(mvar)) allocate (h(nvar,mvar)) c c evaluate the function and get the initial gradient c niter = nextiter - 1 maxiter = niter + maxiter do i = 1, nvar x0old(i) = x0(i) end do ncalls = 1 f0 = fgvalue (x0,g) f0old = f0 c c set the "h" matrix to a diagonal upon restarting c do while (.not. done) if (restart) then do j = 1, mvar do i = 1, nvar h(i,j) = 0.0d0 end do end do do j = 1, mvar h(j,j) = hguess end do do j = 1, mvar k0(j) = 0.0d0 do i = 1, nvar k0(j) = k0(j) + h(i,j)*g(i) end do w(j) = k0(j) end do restart = .false. end if c c start the next iteration using either an updated "h" c matrix or the "h" matrix from the previous iteration c gnorm = 0.0d0 grms = 0.0d0 do i = 1, nvar gnorm = gnorm + g(i)**2 grms = grms + (g(i)*scale(i))**2 end do gnorm = sqrt(gnorm) grms = sqrt(grms) / rms xmove = 0.0d0 if (niter .ne. 0) then do i = 1, nvar xmove = xmove + ((x0(i)-x0old(i))/scale(i))**2 x0old(i) = x0(i) end do xmove = sqrt(xmove) / rms if (coordtype .eq. 'INTERNAL') then xmove = radian * xmove end if fmove = f0old - f0 f0old = f0 end if c c print intermediate results for the current iteration c if (iprint .gt. 0) then if (niter .eq. 0) then if (f0.lt.1.0d8 .and. f0.gt.-1.0d7 .and. & grms.lt.1.0d6) then write (iout,40) niter,f0,grms,ncalls 40 format (/,i6,f14.4,f12.4,32x,i9) else write (iout,50) niter,f0,grms,ncalls 50 format (/,i6,d14.4,d12.4,32x,i9) end if else if (mod(niter,iprint) .eq. 0) then if (f0.lt.1.0d8 .and. f0.gt.-1.0d7 .and. & grms.lt.1.0d6 .and. fmove.lt.1.0d6 .and. & fmove.gt.-1.0d5) then write (iout,60) niter,f0,grms,fmove, & xmove,sgangle,ncalls 60 format (i6,f14.4,f12.4,f12.4,f9.4,f11.4,i9) else write (iout,70) niter,f0,grms,fmove, & xmove,sgangle,ncalls 70 format (i6,d14.4,d12.4,d12.4,f9.4,f11.4,i9) end if end if flush (iout) end if c c write intermediate results for the current iteration c if (iwrite .gt. 0) then if (mod(niter,iwrite) .eq. 0) then call optsave (niter,f0,x0) end if end if c c before starting the next iteration, check to see whether c the gradient norm, function decrease or iteration limit c termination criteria have been satisfied c if (grms.lt.grdmin .or. f0.lt.fctmin & .or. niter.ge.maxiter) then if (iprint .gt. 0) then if (niter.ne.0 .and. mod(niter,iprint).ne.0) then if (f0.lt.1.0d8 .and. f0.gt.-1.0d7 .and. & grms.lt.1.0d6 .and. fmove.lt.1.0d6 .and. & fmove.gt.-1.0d5) then write (iout,80) niter,f0,grms,fmove, & xmove,sgangle,ncalls 80 format (i6,f14.4,f12.4,f12.4,f9.4,f11.4,i9) else write (iout,90) niter,f0,grms,fmove, & xmove,sgangle,ncalls 90 format (i6,d14.4,d12.4,d12.4,f9.4,f11.4,i9) end if end if if (niter .ge. maxiter) status = 'IterLimit' if (f0 .lt. fctmin) status = 'SmallFct ' if (grms .lt. grdmin) status = 'SmallGrad' if (status .eq. 'IterLimit') then write (iout,100) status 100 format (/,' OCVM -- Incomplete Convergence', & ' due to ',a9) else write (iout,110) status 110 format (/,' OCVM -- Normal Termination', & ' due to ',a9) end if flush (iout) end if if (iwrite .gt. 0) then if (mod(niter,iwrite) .ne. 0) then call optsave (niter,f0,x) end if end if done = .true. goto 160 end if c c start of the next iteration c niter = niter + 1 sg = 0.0d0 snorm = 0.0d0 do j = 1, mvar s(j) = -k0(j) snorm = snorm + s(j)**2 sg = sg - s(j)*g(j) end do f0prime = -snorm snorm = sqrt(snorm) cosang = sg / (snorm*gnorm) cosang = min(1.0d0,max(-1.0d0,cosang)) sgangle = radian * acos(cosang) if (sgangle .gt. angmax) then nbig = nbig + 1 else nbig = 0 end if zeta = 2.0d0 if (4.0d0*(f0-fctmin) .lt. -f0prime) then do j = 1, mvar s(j) = -s(j) * (4.0d0*(f0-fctmin)/f0prime) end do f0prime = -4.0d0 * (f0-fctmin) end if c c location of the next starting point c nstep = 0 120 continue do i = 1, nvar search(i) = 0.0d0 end do do j = 1, mvar do i = 1, nvar search(i) = search(i) + h(i,j)*s(j) end do end do srchnorm = 0.0d0 do i = 1, nvar srchnorm = srchnorm + search(i)**2 end do srchnorm = sqrt(srchnorm) if (srchnorm .gt. stpmax) then do j = 1, mvar s(j) = (stpmax/srchnorm) * s(j) end do do i = 1, nvar search(i) = (stpmax/srchnorm) * search(i) end do f0prime = (stpmax/srchnorm) * f0prime zeta = 0.5d0 end if c c invoke abnormal termination if -f0prime is too small c if (-f0prime .lt. eps) then if (iprint .gt. 0) then if (niter.ne.0 .and. mod(niter,iprint).ne.0) then if (f0.lt.1.0d8 .and. f0.gt.-1.0d7 .and. & grms.lt.1.0d6) then write (iout,130) niter,f0,grms,0.0,0.0, & sgangle,ncalls 130 format (i6,f14.4,f12.4,f12.4,f9.4,f11.4,i9) else write (iout,140) niter,f0,grms,0.0,0.0, & sgangle,ncalls 140 format (i6,d14.4,d12.4,f12.4,f9.4,f11.4,i9) end if end if status = 'SmallMove' write (iout,150) status 150 format (/,' OCVM -- Incomplete Convergence', & ' due to ',a9) flush (iout) end if if (iwrite .gt. 0) then if (mod(niter,iwrite) .ne. 0) then call optsave (niter,f0,x) end if end if done = .true. goto 160 end if do i = 1, nvar x(i) = x0(i) + search(i) end do ncalls = ncalls + 1 f = fgvalue (x,g) if (f .ge. f0) then do j = 1, mvar s(j) = 0.5d0 * s(j) end do f0prime = 0.5d0 * f0prime zeta = 0.5d0 goto 120 end if c c decide whether to update or take another step c do j = 1, mvar k(j) = 0.0d0 do i = 1, nvar k(j) = k(j) + h(i,j)*g(i) end do end do fprime = 0.0d0 do j = 1, mvar fprime = fprime + k(j)*s(j) end do b0 = fprime - f0prime do j = 1, mvar m(j) = s(j) + k0(j) - k(j) k0(j) = k(j) end do do i = 1, nvar x0(i) = x(i) end do f0 = f f0prime = fprime if (b0 .lt. eps) then nstep = nstep + 1 if (nstep .ge. maxstep) then restart = .true. goto 160 end if do j = 1, mvar s(j) = s(j) * zeta end do f0prime = f0prime * zeta goto 120 end if c c check to see if we need to update c if (nbig .ge. maxbig) then restart = .true. goto 160 end if m2 = 0.0d0 do j = 1, mvar m2 = m2 + m(j)**2 end do if (m2 .lt. eps) then goto 160 end if v = 0.0d0 do j = 1, mvar v = v + m(j)*s(j) end do micron = v - m2 mw = 0.0d0 do j = 1, mvar mw = mw + m(j)*w(j) end do do j = 1, mvar u(j) = w(j) - m(j)*(mw/m2) end do u2 = 0.0d0 do j = 1, mvar u2 = u2 + u(j)**2 end do if (m2*u2 .ge. eps) then us = 0.0d0 do j = 1, mvar us = us + u(j)*s(j) end do do j = 1, mvar n(j) = u(j)*(us/u2) end do n2 = us * us/u2 else do j = 1, mvar n(j) = 0.0d0 end do n2 = 0.0d0 end if c c test inner product of projected s and del-g c b = n2 + micron * v/m2 if (b .lt. eps) then do j = 1, mvar n(j) = s(j) - m(j)*(v/m2) end do n2 = b0 - micron * v/m2 b = b0 end if c c set "gamma" and "delta" for the update c if (micron*v .ge. m2*n2) then gamma = 0.0d0 delta = sqrt(v/micron) else a = b - micron c = b + v gamma = sqrt((1.0d0-micron*v/(m2*n2))/(a*b)) delta = sqrt(c/a) if (c .lt. a) then gamma = -gamma end if end if c c perform the update of the "h" matrix c alpha = v + micron*delta + m2*n2*gamma do j = 1, mvar p(j) = m(j)*(delta-n2*gamma) + n(j)*(gamma*v) q(j) = m(j)*((1.0d0+n2*gamma)/alpha) & - n(j)*(gamma * micron/alpha) w(j) = m(j)*(n2*(1.0d0+gamma*micron*v)/alpha) & - n(j)*((1.0d0+delta)*micron*v/alpha) end do qk0 = 0.0d0 do j = 1, mvar qk0 = qk0 + q(j)*k0(j) end do do j = 1, mvar k0(j) = k0(j) + p(j)*qk0 end do do i = 1, nvar hq(i) = 0.0d0 end do do j = 1, mvar do i = 1, nvar hq(i) = hq(i) + h(i,j)*q(j) end do end do do j = 1, mvar do i = 1, nvar h(i,j) = h(i,j) + hq(i)*p(j) end do end do if (n2 .le. 0.0d0) then do j = 1, mvar w(j) = k0(j) end do end if 160 continue end do c c perform deallocation of some local arrays c deallocate (x0old) deallocate (x) deallocate (g) deallocate (hq) deallocate (search) deallocate (s) deallocate (w) deallocate (k) deallocate (k0) deallocate (m) deallocate (n) deallocate (p) deallocate (q) deallocate (u) deallocate (h) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module omega -- torsional space dihedral angle values ## c ## ## c ############################################################### c c c nomega number of dihedral angles allowed to rotate c iomega numbers of two atoms defining rotation axis c zline line number in Z-matrix of each dihedral angle c dihed current value in radians of each dihedral angle c c module omega implicit none integer nomega integer, allocatable :: iomega(:,:) integer, allocatable :: zline(:) real*8, allocatable :: dihed(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module opbend -- out-of-plane bends in current structure ## c ## ## c ################################################################## c c c nopbend total number of out-of-plane bends in the system c iopb bond angle numbers used in out-of-plane bending c opbk force constant values for out-of-plane bending c c module opbend implicit none integer nopbend integer, allocatable :: iopb(:) real*8, allocatable :: opbk(:) save end c c c ################################################### c ## COPYRIGHT (C) 1999 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module opdist -- out-of-plane distances in structure ## c ## ## c ############################################################## c c c nopdist total number of out-of-plane distances in the system c iopd numbers of the atoms in each out-of-plane distance c opdk force constant values for out-of-plane distance c c module opdist implicit none integer nopdist integer, allocatable :: iopd(:,:) real*8, allocatable :: opdk(:) save end c c c ################################################### c ## COPYRIGHT (C) 2000 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine openend -- open a file positioned for append ## c ## ## c ################################################################# c c c "openend" opens a file on a Fortran unit such that the position c is set to the bottom for appending to the end of the file c c note this routine is system dependent since the Fortran 90 c standard is not supported by many Fortran 77 compilers; only c one of the various implementations below should be activated c by removing comment characters c c subroutine openend (iunit,name) implicit none integer iunit character*240 name c c c standard Fortran 90, unavailable in some Fortran 77 compilers c open (unit=iunit,file=name,status='old',position='append') c c common extension supported by many Fortran 77 compilers c c open (unit=iunit,file=name,status='old',access='append') c c some Fortran 77 compilers open files for append by default c c open (unit=iunit,file=name,status='old') c c read to the end of formatted file, slow but always correct c c open (unit=iunit,file=name,status='old') c do while (.true.) c read (iunit,10,err=20,end=20) c 10 format () c end do c 20 continue return end c c c ################################################### c ## COPYRIGHT (C) 2010 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## module openmp -- OpenMP processor and thread values ## c ## ## c ############################################################# c c c nproc number of processors available to OpenMP c nthread number of threads to be used with OpenMP c c module openmp implicit none integer nproc integer nthread save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## program optimize -- variable metric Cartesian optimizer ## c ## ## c ################################################################# c c c "optimize" performs energy minimization in Cartesian coordinate c space using an optimally conditioned variable metric method c c program optimize use atoms use bound use files use inform use iounit use scales use usage implicit none integer i,j,k integer imin,nvar integer freeunit real*8 minimum,optimiz1 real*8 grdmin,gnorm,grms real*8 energy,eps real*8, allocatable :: xx(:) real*8, allocatable :: derivs(:,:) logical exist,analytic character*240 minfile character*240 string external energy external optimiz1 external optsave c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c perform the setup functions needed for optimization c call optinit c c use either analytical or numerical gradients c analytic = .true. eps = 0.00001d0 c c get termination criterion as RMS gradient per atom c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) grdmin 10 continue if (grdmin .le. 0.0d0) then write (iout,20) 20 format (/,' Enter RMS Gradient per Atom Criterion', & ' [0.01] : ',$) read (input,30) grdmin 30 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.01d0 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 global arrays c if (.not. allocated(scale)) allocate (scale(3*n)) c c set scaling parameter for function and derivative values; c use square root of median eigenvalue of typical Hessian c set_scale = .true. nvar = 0 do i = 1, nuse do j = 1, 3 nvar = nvar + 1 scale(nvar) = 12.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (xx(nvar)) allocate (derivs(3,n)) c c convert atomic coordinates to optimization parameters c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 xx(nvar) = x(k) * scale(nvar) nvar = nvar + 1 xx(nvar) = y(k) * scale(nvar) nvar = nvar + 1 xx(nvar) = z(k) * scale(nvar) end do c c make the call to the optimization routine c call ocvm (nvar,xx,minimum,grdmin,optimiz1,optsave) 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) / scale(nvar) nvar = nvar + 1 y(k) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(k) = xx(nvar) / scale(nvar) end do c c compute the final function and RMS gradient values c if (analytic) then call gradient (minimum,derivs) else minimum = energy () call numgrad (energy,derivs,eps) end if 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,40) minimum,grms,gnorm 40 format (/,' Final Function Value :',2x,f20.8, & /,' Final RMS Gradient :',4x,f20.8, & /,' Final Gradient Norm :',3x,f20.8) else write (iout,50) minimum,grms,gnorm 50 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,60) minimum,grms,gnorm 60 format (/,' Final Function Value :',2x,f18.6, & /,' Final RMS Gradient :',4x,f18.6, & /,' Final Gradient Norm :',3x,f18.6) else write (iout,70) minimum,grms,gnorm 70 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,80) minimum,grms,gnorm 80 format (/,' Final Function Value :',2x,f16.4, & /,' Final RMS Gradient :',4x,f16.4, & /,' Final Gradient Norm :',3x,f16.4) else write (iout,90) minimum,grms,gnorm 90 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 move stray molecules into periodic box if desired c c if (use_bounds) call bounds 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 ## function optimiz1 -- energy and gradient for optimize ## c ## ## c ############################################################### c c c "optimiz1" is a service routine that computes the energy and c gradient for optimally conditioned variable metric optimization c in Cartesian coordinate space c c function optimiz1 (xx,g) use atoms use scales use usage implicit none integer i,k,nvar real*8 optimiz1,e real*8 energy,eps real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) logical analytic external energy c c c use either analytical or numerical gradients c analytic = .true. eps = 0.00001d0 c c convert optimization parameters to atomic coordinates c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 x(k) = xx(nvar) / scale(nvar) nvar = nvar + 1 y(k) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(k) = xx(nvar) / scale(nvar) end do c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute and store the energy and gradient c if (analytic) then call gradient (e,derivs) else e = energy () call numgrad (energy,derivs,eps) end if optimiz1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 g(nvar) = derivs(1,k) / scale(nvar) nvar = nvar + 1 g(nvar) = derivs(2,k) / scale(nvar) nvar = nvar + 1 g(nvar) = derivs(3,k) / scale(nvar) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ################################################### c ## COPYRIGHT (C) 2018 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine optinit -- initialize structure optimization ## c ## ## c ################################################################# c c c "optinit" initializes values and keywords used by multiple c structure optimization methods c c subroutine optinit use inform use keys use output use potent implicit none integer i,next character*20 keyword character*240 record character*240 string c c c set default values for optimization parameters c iprint = -1 iwrite = -1 frcsave = .false. uindsave = .false. c c check for keywords containing any altered parameters c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) 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 else if (keyword(1:11) .eq. 'SAVE-FORCE ') then frcsave = .true. else if (keyword(1:13) .eq. 'SAVE-INDUCED ') then uindsave = .true. end if 10 continue end do c c check for use of induced dipole prediction methods c if (use_polar) call predict return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## program optirot -- variable metric torsional optimizer ## c ## ## c ################################################################ c c c "optirot" performs an energy minimization in torsional angle c space using an optimally conditioned variable metric method c c program optirot use files use inform use iounit use math use omega use scales use zcoord implicit none integer i,imin integer freeunit real*8 minimum,optirot1 real*8 grdmin,gnorm,grms real*8, allocatable :: xx(:) real*8, allocatable :: derivs(:) logical exist character*240 minfile character*240 string external optirot1 external optsave c c c set up the molecular mechanics calculation c call initial call getint call mechanic c c perform the setup functions needed for optimization c call optinit call initrot c c get termination criterion as RMS torsional gradient c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) grdmin 10 continue if (grdmin .le. 0.0d0) then write (iout,20) 20 format (/,' Enter RMS Gradient per Torsion Criterion', & ' [0.01] : ',$) read (input,30) grdmin 30 format (f20.0) end if if (grdmin .eq. 0.0d0) grdmin = 0.01d0 c c write out a copy of coordinates for later update c imin = freeunit () minfile = filename(1:leng)//'.int' call version (minfile,'new') open (unit=imin,file=minfile,status='new') call prtint (imin) close (unit=imin) outfile = minfile c c perform dynamic allocation of some global arrays c if (.not. allocated(scale)) allocate (scale(nomega)) c c set scaling parameter for function and derivative values; c use square root of median eigenvalue of typical Hessian c set_scale = .true. do i = 1, nomega scale(i) = 5.0d0 end do c c perform dynamic allocation of some local arrays c allocate (xx(nomega)) c c convert dihedral angles to optimization parameters c do i = 1, nomega xx(i) = dihed(i) * scale(i) end do c c make the call to the optimization routine c call ocvm (nomega,xx,minimum,grdmin,optirot1,optsave) c c convert optimization parameters to dihedral angles c do i = 1, nomega dihed(i) = xx(i) / scale(i) ztors(zline(i)) = dihed(i) * radian end do c c perform deallocation of some local arrays c deallocate (xx) c c perform dynamic allocation of some local arrays c allocate (derivs(nomega)) c c compute the final function and RMS gradient values c call gradrot (minimum,derivs) gnorm = 0.0d0 do i = 1, nomega gnorm = gnorm + derivs(i)**2 end do gnorm = sqrt(gnorm) grms = gnorm / sqrt(dble(nomega)) c c perform deallocation of some local arrays c 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,40) minimum,grms,gnorm 40 format (/,' Final Function Value :',2x,f20.8, & /,' Final RMS Gradient :',4x,f20.8, & /,' Final Gradient Norm :',3x,f20.8) else write (iout,50) minimum,grms,gnorm 50 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,60) minimum,grms,gnorm 60 format (/,' Final Function Value :',2x,f18.6, & /,' Final RMS Gradient :',4x,f18.6, & /,' Final Gradient Norm :',3x,f18.6) else write (iout,70) minimum,grms,gnorm 70 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,80) minimum,grms,gnorm 80 format (/,' Final Function Value :',2x,f16.4, & /,' Final RMS Gradient :',4x,f16.4, & /,' Final Gradient Norm :',3x,f16.4) else write (iout,90) minimum,grms,gnorm 90 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 prtint (imin) close (unit=imin) c c perform any final tasks before program exit c call final end c c c ############################################################## c ## ## c ## function optirot1 -- energy and gradient for optirot ## c ## ## c ############################################################## c c c "optirot1" is a service routine that computes the energy and c gradient for optimally conditioned variable metric optimization c in torsional angle space c c function optirot1 (xx,g) use math use omega use scales use zcoord implicit none integer i real*8 optirot1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:) c c c convert optimization parameters to dihedral angles c do i = 1, nomega dihed(i) = xx(i) / scale(i) ztors(zline(i)) = dihed(i) * radian end do c c perform dynamic allocation of some local arrays c allocate (derivs(nomega)) c c get coordinates, then compute energy and gradient c call makexyz call gradrot (e,derivs) optirot1 = e c c convert torsional gradient to optimization parameters c do i = 1, nomega g(i) = derivs(i) / scale(i) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## program optrigid -- variable metric rigid body optimizer ## c ## ## c ################################################################## c c c "optrigid" performs an energy minimization of rigid body atom c groups using an optimally conditioned variable metric method c c program optrigid use files use group use inform use iounit use output use rigid implicit none integer i,j integer imin,nvar integer freeunit real*8 minimum,optrigid1 real*8 grdmin,grms,gnorm real*8, allocatable :: xx(:) real*8, allocatable :: derivs(:,:) logical exist character*240 minfile character*240 string external optrigid1 external optsave c c c set up the molecular mechanics calculation c call initial call getxyz call mechanic c c set up the use of rigid body coordinate system c coordtype = 'RIGIDBODY' use_rigid = .true. call orient c c perform the setup functions needed for optimization c call optinit c c get termination criterion as RMS rigid body gradient c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) grdmin 10 continue if (grdmin .le. 0.0d0) then write (iout,20) 20 format (/,' Enter RMS Gradient per Rigid Body Criterion', & ' [0.01] : ',$) read (input,30) grdmin 30 format (f20.0) end if if (grdmin .eq. 0.0d0) grdmin = 0.01d0 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(6*ngrp)) c c convert rigid body coordinates to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 xx(nvar) = rbc(j,i) end do end do c c make the call to the optimization routine c call ocvm (nvar,xx,minimum,grdmin,optrigid1,optsave) c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c perform deallocation of some local arrays c deallocate (xx) c c perform dynamic allocation of some local arrays c allocate (derivs(6,ngrp)) c c compute the final function and RMS gradient values c call gradrgd (minimum,derivs) gnorm = 0.0d0 do i = 1, ngrp do j = 1, 6 gnorm = gnorm + derivs(j,i)**2 end do end do gnorm = sqrt(gnorm) grms = gnorm / sqrt(dble(ngrp)) c c perform deallocation of some local arrays c 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,40) minimum,grms,gnorm 40 format (/,' Final Function Value :',2x,f20.8, & /,' Final RMS Gradient :',4x,f20.8, & /,' Final Gradient Norm :',3x,f20.8) else write (iout,50) minimum,grms,gnorm 50 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,60) minimum,grms,gnorm 60 format (/,' Final Function Value :',2x,f18.6, & /,' Final RMS Gradient :',4x,f18.6, & /,' Final Gradient Norm :',3x,f18.6) else write (iout,70) minimum,grms,gnorm 70 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,80) minimum,grms,gnorm 80 format (/,' Final Function Value :',2x,f16.4, & /,' Final RMS Gradient :',4x,f16.4, & /,' Final Gradient Norm :',3x,f16.4) else write (iout,90) minimum,grms,gnorm 90 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 ## function optrigid1 -- energy and gradient for optrigid ## c ## ## c ################################################################ c c c "optrigid1" is a service routine that computes the energy c and gradient for optimally conditioned variable metric c optimization of rigid bodies c c function optrigid1 (xx,g) use group use math use rigid implicit none integer i,j,nvar real*8 optrigid1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) c c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c perform dynamic allocation of some local arrays c allocate (derivs(6,ngrp)) c c compute and store the energy and gradient c call rigidxyz call gradrgd (e,derivs) optrigid1 = e c c convert rigid body gradient to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 g(nvar) = derivs(j,i) end do end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine optsave -- save optimization info and results ## c ## ## c ################################################################## c c c "optsave" is used by the optimizers to write imtermediate c coordinates and other relevant information; also checks for c user requested termination of an optimization c c subroutine optsave (ncycle,f,xx) use atomid use atoms use bound use deriv use files use group use iounit use math use mpole use omega use output use polar use potent use scales use socket use titles use units use usage use zcoord implicit none integer i,j,ii,lext integer ixyz,ifrc integer iind,iend integer ncycle,nvar integer freeunit integer trimtext real*8 f,xx(*) logical exist,first character*7 ext character*240 xyzfile character*240 frcfile character*240 indfile character*240 endfile c c c nothing to do if coordinate type is undefined c if (coordtype .eq. 'NONE') return c c check scaling factors for optimization parameters c if (.not. set_scale) then set_scale = .true. if (coordtype .eq. 'CARTESIAN') then if (.not. allocated(scale)) allocate (scale(3*n)) do i = 1, 3*n scale(i) = 1.0d0 end do else if (coordtype .eq. 'INTERNAL') then if (.not. allocated(scale)) allocate (scale(nomega)) do i = 1, nomega scale(i) = 1.0d0 end do else if (coordtype .eq. 'RIGIDBODY') then if (.not. allocated(scale)) allocate (scale(6*ngrp)) do i = 1, 6*ngrp scale(i) = 1.0d0 end do end if end if c c convert optimization parameters to atomic coordinates c if (coordtype .eq. 'CARTESIAN') then nvar = 0 do ii = 1, nuse i = iuse(ii) nvar = nvar + 1 x(i) = xx(nvar) / scale(nvar) nvar = nvar + 1 y(i) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(i) = xx(nvar) / scale(nvar) end do else if (coordtype .eq. 'INTERNAL') then do i = 1, nomega dihed(i) = xx(i) / scale(i) ztors(zline(i)) = dihed(i) * radian end do end if c c move stray molecules into periodic box if desired c if (coordtype .eq. 'CARTESIAN') then if (use_bounds) call bounds end if c c save coordinates to archive or numbered structure file c ixyz = freeunit () if (cyclesave) then if (dcdsave) then xyzfile = filename(1:leng) call suffix (xyzfile,'dcd','old') inquire (file=xyzfile,exist=exist) if (exist) then first = .false. open (unit=ixyz,file=xyzfile,form='unformatted', & status='old',position='append') else first = .true. open (unit=ixyz,file=xyzfile,form='unformatted', & status='new') end if call prtdcd (ixyz,first) else if (arcsave) then xyzfile = filename(1:leng) call suffix (xyzfile,'arc','old') inquire (file=xyzfile,exist=exist) if (exist) then call openend (ixyz,xyzfile) else open (unit=ixyz,file=xyzfile,status='new') end if else lext = 3 call numeral (ncycle,ext,lext) xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') end if else xyzfile = outfile call version (xyzfile,'old') open (unit=ixyz,file=xyzfile,status='old') rewind (unit=ixyz) end if c c update intermediate file with desired coordinate type c if (coordtype .eq. 'CARTESIAN') then if (.not. dcdsave) call prtxyz (ixyz) else if (coordtype .eq. 'INTERNAL') then call prtint (ixyz) else if (coordtype .eq. 'RIGIDBODY') then call prtxyz (ixyz) end if close (unit=ixyz) c c save the force vector components for the current step c if (frcsave .and. coordtype.eq.'CARTESIAN') then ifrc = freeunit () if (cyclesave) then frcfile = filename(1:leng)//'.'//ext(1:lext)//'f' call version (frcfile,'new') open (unit=ifrc,file=frcfile,status='new') else if (dcdsave) then frcfile = filename(1:leng) call suffix (frcfile,'dcdf','old') inquire (file=frcfile,exist=exist) if (exist) then first = .false. open (unit=ifrc,file=frcfile,form='unformatted', & status='old',position='append') else first = .true. open (unit=ifrc,file=frcfile,form='unformatted', & status='new') end if call prtdcdf (ifrc,first) else 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 call prtfrc (ifrc) end if close (unit=ifrc) write (iout,10) frcfile(1:trimtext(frcfile)) 10 format (' Force Vector File',11x,a) end if c c save the current induced dipole moment at each site c if (uindsave .and. use_polar .and. coordtype.eq.'CARTESIAN') then iind = freeunit () if (cyclesave) then indfile = filename(1:leng)//'.'//ext(1:lext)//'u' call version (indfile,'new') open (unit=iind,file=indfile,status='new') else if (dcdsave) then indfile = filename(1:leng) call suffix (indfile,'dcdu','old') inquire (file=indfile,exist=exist) if (exist) then first = .false. open (unit=iind,file=indfile,form='unformatted', & status='old',position='append') else first = .true. open (unit=iind,file=indfile,form='unformatted', & status='new') end if call prtdcdu (iind,first) else 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 call prtuind (iind) end if close (unit=iind) write (iout,20) indfile(1:trimtext(indfile)) 20 format (' Induced Dipole File',10x,a) end if c c send data via external socket communication if desired c if (.not.sktstart .or. use_socket) then if (coordtype .eq. 'INTERNAL') call makexyz call sktopt (ncycle,f) end if 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,30) 30 format (/,' OPTSAVE -- 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 ## subroutine orbital -- setup for pisystem calculation ## c ## ## c ############################################################## c c c "orbital" finds and organizes lists of atoms in a pisystem, c bonds connecting pisystem atoms and torsions whose central c atoms are both pisystem atoms c c subroutine orbital use atoms use bndstr use couple use iounit use keys use piorbs use potent use tors implicit none integer i,j,k,m,ii integer mi,mj,mk integer iorb,jorb,korb integer nlist,next integer, allocatable :: list(:) character*20 keyword character*240 record character*240 string c c c perform dynamic allocation of some global arrays c if (allocated(iorbit)) deallocate (iorbit) if (allocated(iconj)) deallocate (iconj) if (allocated(kconj)) deallocate (kconj) if (allocated(piperp)) deallocate (piperp) if (allocated(ibpi)) deallocate (ibpi) if (allocated(itpi)) deallocate (itpi) if (allocated(pbpl)) deallocate (pbpl) if (allocated(pnpl)) deallocate (pnpl) if (allocated(listpi)) deallocate (listpi) allocate (iorbit(n)) allocate (iconj(2,n)) allocate (kconj(n)) allocate (piperp(3,n)) allocate (ibpi(3,nbond)) allocate (itpi(2,ntors)) allocate (pbpl(nbond)) allocate (pnpl(nbond)) allocate (listpi(n)) c c perform dynamic allocation of some local arrays c allocate (list(n)) c c set the default values for the pisystem variables c nlist = 0 do i = 1, n list(i) = 0 end do reorbit = 1 c c check the keywords for any lists of pisystem atoms c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:9) .eq. 'PISYSTEM ') then string = record(next:240) read (string,*,err=10,end=10) (list(k),k=nlist+1,n) 10 continue do while (list(nlist+1) .ne. 0) nlist = nlist + 1 list(nlist) = max(-n,min(n,list(nlist))) end do end if end do c c quit if no pisystem was found for consideration c if (list(1) .eq. 0) then use_orbit = .false. return else use_orbit = .true. end if c c organize and make lists of the pisystem atoms c do i = 1, n listpi(i) = .false. end do i = 1 do while (list(i) .ne. 0) if (list(i) .gt. 0) then listpi(list(i)) = .true. i = i + 1 else do j = -list(i), list(i+1) listpi(j) = .true. end do i = i + 2 end if end do c c set number of orbitals and an initial orbital list c norbit = 0 nconj = 0 do i = 1, n list(i) = 0 if (listpi(i)) then norbit = norbit + 1 iorbit(norbit) = i end if end do c c assign each orbital to its respective pisystem c do i = 1, norbit iorb = iorbit(i) if (list(iorb) .eq. 0) then nconj = nconj + 1 list(iorb) = nconj end if mi = list(iorb) do ii = 1, n12(iorb) j = i12(ii,iorb) if (listpi(j)) then mj = list(j) if (mj .eq. 0) then list(j) = mi else if (mi .lt. mj) then nconj = nconj - 1 do k = 1, norbit korb = iorbit(k) mk = list(korb) if (mk .eq. mj) then list(korb) = mi else if (mk .gt. mj) then list(korb) = mk - 1 end if end do else if (mi .gt. mj) then nconj = nconj - 1 do k = 1, norbit korb = iorbit(k) mk = list(korb) if (mk .eq. mi) then list(korb) = mj else if (mk .gt. mi) then list(korb) = mk - 1 end if end do mi = mj end if end if end do end do c c pack atoms of each pisystem into a contiguous indexed list c call sort3 (n,list,kconj) k = n - norbit do i = 1, norbit k = k + 1 list(i) = list(k) kconj(i) = kconj(k) end do c c find the first and last piatom in each pisystem c k = 1 iconj(1,1) = 1 do i = 2, norbit j = list(i) if (j .ne. k) then iconj(2,k) = i - 1 k = j iconj(1,k) = i end if end do iconj(2,nconj) = norbit c c perform deallocation of some local arrays c deallocate (list) c c sort atoms in each pisystem, copy list to orbital sites c do i = 1, nconj k = iconj(2,i) - iconj(1,i) + 1 call sort (k,kconj(iconj(1,i))) end do do i = 1, norbit iorbit(i) = kconj(i) end do c c find atoms defining a plane perpendicular to each orbital c call piplane c c find and store all of the pisystem bonds c nbpi = 0 do ii = 1, nconj do i = iconj(1,ii), iconj(2,ii)-1 iorb = kconj(i) do j = i+1, iconj(2,ii) jorb = kconj(j) do k = 1, n12(iorb) if (i12(k,iorb) .eq. jorb) then nbpi = nbpi + 1 do m = 1, nbond if (iorb.eq.ibnd(1,m) .and. & jorb.eq.ibnd(2,m)) then ibpi(1,nbpi) = m ibpi(2,nbpi) = i ibpi(3,nbpi) = j goto 20 end if end do 20 continue end if end do end do end do end do return end c c c ############################################################## c ## ## c ## subroutine piplane -- plane perpendicular to orbital ## c ## ## c ############################################################## c c c "piplane" selects the three atoms which specify the plane c perpendicular to each p-orbital; the current version will c fail in certain situations, including ketenes, allenes, c and isolated or adjacent triple bonds c c subroutine piplane use atomid use atoms use couple use iounit use piorbs implicit none integer i,j,iorb integer atmnum,trial integer alpha,beta,gamma integer attach logical done c c c for each pisystem atom, find a set of atoms which define c the p-orbital's plane based on piatom's atomic number and c the number and type of attached atoms c do iorb = 1, norbit i = iorbit(iorb) attach = n12(i) atmnum = atomic(i) done = .false. c c most common case of an atom bonded to three atoms c if (attach .eq. 3) then piperp(1,i) = i12(1,i) piperp(2,i) = i12(2,i) piperp(3,i) = i12(3,i) done = .true. c c any non-alkyne atom bonded to exactly two atoms c else if (attach.eq.2 .and. atmnum.ne.6) then piperp(1,i) = i piperp(2,i) = i12(1,i) piperp(3,i) = i12(2,i) done = .true. c c atom bonded to four different atoms (usually two lone c pairs and two "real" atoms); use the "real" atoms c else if (attach .eq. 4) then piperp(1,i) = i do j = 1, n12(i) trial = i12(j,i) if (atomic(trial) .ne. 0) then if (piperp(2,i) .eq. 0) then piperp(2,i) = trial else piperp(3,i) = trial done = .true. end if end if end do c c "carbonyl"-type oxygen atom, third atom is any atom c attached to the "carbonyl carbon"; fails for ketenes c else if (attach.eq.1 .and. atmnum.eq.8) then alpha = i12(1,i) beta = i12(1,alpha) if (beta .eq. i) beta = i12(2,alpha) piperp(1,i) = i piperp(2,i) = alpha piperp(3,i) = beta done = .true. c c an sp nitrogen atom, third atom must be a gamma atom c else if (attach.eq.1 .and. atmnum.eq.7) then alpha = i12(1,i) do j = 1, n12(alpha) trial = i12(j,alpha) if (trial.ne.i .and. listpi(trial) .and. & n12(trial).eq.3) then beta = trial done = .true. end if end do gamma = i12(1,beta) if (gamma .eq. alpha) gamma = i12(2,beta) piperp(1,i) = i piperp(2,i) = alpha piperp(3,i) = gamma c c an sp carbon atom; third atom must be an atom attached c to the non-sp piatom bonded to the original carbon c else if (attach.eq.2 .and. atmnum.eq.6) then alpha = i12(1,i) if ((n12(alpha).eq.2 .and. atomic(alpha).eq.6) .or. & (n12(alpha).eq.1 .and. atomic(alpha).eq.7)) & alpha = i12(2,i) do j = 1, n12(i) trial = i12(j,i) if (trial.ne.i .and. trial.ne.alpha .and. & listpi(trial) .and. n12(trial).eq.3) then beta = trial done = .true. end if end do do j = 1, n12(alpha) trial = i12(j,alpha) if (trial.ne.i .and. trial.ne.alpha .and. & listpi(trial) .and. n12(trial).eq.3) then beta = trial done = .true. end if end do gamma = i12(1,beta) if (gamma.eq.i .or. gamma.eq.alpha) gamma = i12(2,beta) piperp(1,i) = i piperp(2,i) = alpha piperp(3,i) = gamma end if c c quit if the p-orbital plane remains undefined c if (.not. done) then write (iout,10) i 10 format(/,' PIPLANE -- Failure to Define', & ' p-Orbital Plane for Atom',i6) call fatal end if 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 orbits -- conjugated pisystem orbital energies ## c ## ## c ############################################################### c c c qorb number of pi-electrons contributed by each atom c worb ionization potential of each pisystem atom c emorb repulsion integral for each pisystem atom c c module orbits implicit none real*8, allocatable :: qorb(:) real*8, allocatable :: worb(:) real*8, allocatable :: emorb(:) save end c c c ############################################################## c ## COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ############################################################### c ## ## c ## subroutine orient -- rigid body reference coordinates ## c ## ## c ############################################################### c c c "orient" computes a set of reference Cartesian coordinates c in standard orientation for each rigid body atom group c c subroutine orient use atoms use group use rigid implicit none integer i,j,k integer init,stop real*8 xcm,ycm,zcm real*8 phi,theta,psi real*8 xterm,yterm,zterm real*8 cphi,ctheta,cpsi real*8 sphi,stheta,spsi real*8 a(3,3) c c c perform dynamic allocation of some global arrays c if (.not. allocated(xrb)) allocate (xrb(n)) if (.not. allocated(yrb)) allocate (yrb(n)) if (.not. allocated(zrb)) allocate (zrb(n)) if (.not. allocated(rbc)) allocate (rbc(6,ngrp)) c c use current coordinates as default reference coordinates c do i = 1, n xrb(i) = x(i) yrb(i) = y(i) zrb(i) = z(i) end do c c compute the rigid body coordinates for each atom group c call xyzrigid c c get the center of mass and Euler angles for each group c do i = 1, ngrp xcm = rbc(1,i) ycm = rbc(2,i) zcm = rbc(3,i) phi = rbc(4,i) theta = rbc(5,i) psi = rbc(6,i) cphi = cos(phi) sphi = sin(phi) ctheta = cos(theta) stheta = sin(theta) cpsi = cos(psi) spsi = sin(psi) c c construct the rotation matrix from Euler angle values c a(1,1) = ctheta * cphi a(2,1) = spsi*stheta*cphi - cpsi*sphi a(3,1) = cpsi*stheta*cphi + spsi*sphi a(1,2) = ctheta * sphi a(2,2) = spsi*stheta*sphi + cpsi*cphi a(3,2) = cpsi*stheta*sphi - spsi*cphi a(1,3) = -stheta a(2,3) = ctheta * spsi a(3,3) = ctheta * cpsi c c translate and rotate each atom group into inertial frame c init = igrp(1,i) stop = igrp(2,i) do j = init, stop k = kgrp(j) xterm = x(k) - xcm yterm = y(k) - ycm zterm = z(k) - zcm xrb(k) = a(1,1)*xterm + a(1,2)*yterm + a(1,3)*zterm yrb(k) = a(2,1)*xterm + a(2,2)*yterm + a(2,3)*zterm zrb(k) = a(3,1)*xterm + a(3,2)*yterm + a(3,3)*zterm end do end do return end c c c ################################################################# c ## ## c ## subroutine xyzrigid -- determine rigid body coordinates ## c ## ## c ################################################################# c c c "xyzrigid" computes the center of mass and Euler angle rigid c body coordinates for each atom group in the system c c literature reference: c c Herbert Goldstein, "Classical Mechanics, 2nd Edition", c Addison-Wesley, Reading, MA, 1980; see the Euler angle c xyz convention in Appendix B c c subroutine xyzrigid use atoms use atomid use group use rigid implicit none integer i,j,k,m integer init,stop real*8 xcm,ycm,zcm real*8 phi,theta,psi real*8 weigh,total,dot real*8 xx,xy,xz,yy,yz,zz real*8 xterm,yterm,zterm real*8 moment(3) real*8 vec(3,3) real*8 tensor(3,3) real*8 a(3,3) c c c get the first and last atom in the current group c do i = 1, ngrp init = igrp(1,i) stop = igrp(2,i) c c compute the position of the group center of mass c total = 0.0d0 xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 do j = init, stop k = kgrp(j) weigh = mass(k) total = total + weigh xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do if (total .ne. 0.0d0) then xcm = xcm / total ycm = ycm / total zcm = zcm / total end if c c compute and then diagonalize the inertia tensor c xx = 0.0d0 xy = 0.0d0 xz = 0.0d0 yy = 0.0d0 yz = 0.0d0 zz = 0.0d0 do j = init, stop k = kgrp(j) weigh = mass(k) xterm = x(k) - xcm yterm = y(k) - ycm zterm = z(k) - zcm xx = xx + xterm*xterm*weigh xy = xy + xterm*yterm*weigh xz = xz + xterm*zterm*weigh yy = yy + yterm*yterm*weigh yz = yz + yterm*zterm*weigh zz = zz + zterm*zterm*weigh end do tensor(1,1) = yy + zz tensor(2,1) = -xy tensor(3,1) = -xz tensor(1,2) = -xy tensor(2,2) = xx + zz tensor(3,2) = -yz tensor(1,3) = -xz tensor(2,3) = -yz tensor(3,3) = xx + yy call jacobi (3,tensor,moment,vec) c c select the direction for each principle moment axis c do m = 1, 2 do j = init, stop k = kgrp(j) xterm = vec(1,m) * (x(k)-xcm) yterm = vec(2,m) * (y(k)-ycm) zterm = vec(3,m) * (z(k)-zcm) dot = xterm + yterm + zterm if (dot .lt. 0.0d0) then vec(1,m) = -vec(1,m) vec(2,m) = -vec(2,m) vec(3,m) = -vec(3,m) end if if (dot .ne. 0.0d0) goto 10 end do 10 continue end do c c moment axes must give a right-handed coordinate system c xterm = vec(1,1) * (vec(2,2)*vec(3,3)-vec(2,3)*vec(3,2)) yterm = vec(2,1) * (vec(1,3)*vec(3,2)-vec(1,2)*vec(3,3)) zterm = vec(3,1) * (vec(1,2)*vec(2,3)-vec(1,3)*vec(2,2)) dot = xterm + yterm + zterm if (dot .lt. 0.0d0) then do j = 1, 3 vec(j,3) = -vec(j,3) end do end if c c principal moment axes form rows of Euler rotation matrix c do k = 1, 3 do j = 1, 3 a(k,j) = vec(j,k) end do end do c c compute Euler angles consistent with the rotation matrix c call roteuler (a,phi,theta,psi) c c set the rigid body coordinates for each atom group c rbc(1,i) = xcm rbc(2,i) = ycm rbc(3,i) = zcm rbc(4,i) = phi rbc(5,i) = theta rbc(6,i) = psi end do return end c c c ################################################################# c ## ## c ## subroutine roteuler -- rotation matrix to Euler angles ## c ## ## c ################################################################# c c c "roteuler" computes a set of Euler angle values consistent c with an input rotation matrix c c subroutine roteuler (a,phi,theta,psi) use math implicit none integer i real*8 phi,theta,psi,eps real*8 cphi,ctheta,cpsi real*8 sphi,stheta,spsi real*8 a(3,3),b(3) logical flip(3) c c c set the tolerance for Euler angles and rotation elements c eps = 1.0d-7 c c get a trial value of theta from a single rotation element c theta = asin(min(1.0d0,max(-1.0d0,-a(1,3)))) ctheta = cos(theta) stheta = -a(1,3) c c set the phi/psi difference when theta is either 90 or -90 c if (abs(ctheta) .le. eps) then phi = 0.0d0 if (abs(a(3,1)) .lt. eps) then psi = asin(min(1.0d0,max(-1.0d0,-a(2,1)/a(1,3)))) else if (abs(a(2,1)) .lt. eps) then psi = acos(min(1.0d0,max(-1.0d0,-a(3,1)/a(1,3)))) else psi = atan(a(2,1)/a(3,1)) end if c c set the phi and psi values for all other theta values c else if (abs(a(1,1)) .lt. eps) then phi = asin(min(1.0d0,max(-1.0d0,a(1,2)/ctheta))) else if (abs(a(1,2)) .lt. eps) then phi = acos(min(1.0d0,max(-1.0d0,a(1,1)/ctheta))) else phi = atan(a(1,2)/a(1,1)) end if if (abs(a(3,3)) .lt. eps) then psi = asin(min(1.0d0,max(-1.0d0,a(2,3)/ctheta))) else if (abs(a(2,3)) .lt. eps) then psi = acos(min(1.0d0,max(-1.0d0,a(3,3)/ctheta))) else psi = atan(a(2,3)/a(3,3)) end if end if c c find sine and cosine of the trial phi and psi values c cphi = cos(phi) sphi = sin(phi) cpsi = cos(psi) spsi = sin(psi) c c reconstruct the diagonal of the rotation matrix c b(1) = ctheta * cphi b(2) = spsi*stheta*sphi + cpsi*cphi b(3) = ctheta * cpsi c c compare the correct matrix diagonal to rebuilt diagonal c do i = 1, 3 flip(i) = .false. if (abs(a(i,i)-b(i)) .gt. eps) flip(i) = .true. end do c c alter Euler angles to get correct rotation matrix values c if (flip(1) .and. flip(2)) phi = phi - sign(pi,phi) if (flip(1) .and. flip(3)) theta = -theta + sign(pi,theta) if (flip(2) .and. flip(3)) psi = psi - sign(pi,psi) c c convert maximum negative angles to positive values c if (phi .le. -pi) phi = pi if (theta .le. -pi) theta = pi if (psi .le. -pi) psi = pi return end c c c ############################################################### c ## ## c ## subroutine rigidxyz -- rigid body to Cartesian coords ## c ## ## c ############################################################### c c c "rigidxyz" computes Cartesian coordinates for a rigid body c group via rotation and translation of reference coordinates c c literature reference: c c Herbert Goldstein, "Classical Mechanics, 2nd Edition", c Addison-Wesley, Reading, MA, 1980; see the Euler angle c xyz convention in Appendix B c c subroutine rigidxyz use atoms use group use rigid implicit none integer i,j,k integer init,stop real*8 xcm,ycm,zcm real*8 phi,theta,psi real*8 xterm,yterm,zterm real*8 cphi,ctheta,cpsi real*8 sphi,stheta,spsi real*8 a(3,3) c c c get the center of mass and Euler angles for each group c do i = 1, ngrp xcm = rbc(1,i) ycm = rbc(2,i) zcm = rbc(3,i) phi = rbc(4,i) theta = rbc(5,i) psi = rbc(6,i) cphi = cos(phi) sphi = sin(phi) ctheta = cos(theta) stheta = sin(theta) cpsi = cos(psi) spsi = sin(psi) c c construct the rotation matrix from Euler angle values c a(1,1) = ctheta * cphi a(2,1) = spsi*stheta*cphi - cpsi*sphi a(3,1) = cpsi*stheta*cphi + spsi*sphi a(1,2) = ctheta * sphi a(2,2) = spsi*stheta*sphi + cpsi*cphi a(3,2) = cpsi*stheta*sphi - spsi*cphi a(1,3) = -stheta a(2,3) = ctheta * spsi a(3,3) = ctheta * cpsi c c rotate and translate reference coordinates into global frame c init = igrp(1,i) stop = igrp(2,i) do j = init, stop k = kgrp(j) xterm = xrb(k) yterm = yrb(k) zterm = zrb(k) x(k) = a(1,1)*xterm + a(2,1)*yterm + a(3,1)*zterm + xcm y(k) = a(1,2)*xterm + a(2,2)*yterm + a(3,2)*zterm + ycm z(k) = a(1,3)*xterm + a(2,3)*yterm + a(3,3)*zterm + zcm end do 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 orthog -- Gram-Schmidt orthogonalization ## c ## ## c ############################################################# c c c "orthog" performs an orthogonalization of an input matrix c via the modified Gram-Schmidt algorithm c c variables and parameters: c c m first dimension of the matrix to orthogonalize c n second dimension of the matrix to orthogonalize c a matrix to orthogonalize; contains result on exit c c subroutine orthog (m,n,a) implicit none integer i,j,k integer m,n real*8 rkk,rkj real*8 a(m,*) c c c compute the modified Gram-Schmidt orthogonalization c do k = 1, n rkk = 0.0d0 do i = 1, m rkk = rkk + a(i,k)**2 end do rkk = sqrt(rkk) do i = 1, m a(i,k) = a(i,k) / rkk end do do j = k+1, n rkj = 0.0d0 do i = 1, m rkj = rkj + a(i,k)*a(i,j) end do do i = 1, m a(i,j) = a(i,j) - a(i,k)*rkj end do 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 output -- output file format control parameters ## c ## ## c ################################################################ c c c archive logical flag for coordinates in Tinker XYZ format c binary logical flag for coordinates in DCD binary format c noversion logical flag governing use of filename versions c overwrite logical flag to overwrite intermediate files inplace c arcsave logical flag to save coordinates in Tinker XYZ format c dcdsave logical flag to save coordinates in DCD binary format c cyclesave logical flag to mark use of numbered cycle files c velsave logical flag to save velocity vector components c frcsave logical flag to save force vector components c uindsave logical flag to save induced atomic dipoles c coordtype selects Cartesian, internal, rigid body or none c c module output implicit none logical archive logical binary logical noversion logical overwrite logical cyclesave logical arcsave logical dcdsave logical velsave logical frcsave logical uindsave character*9 coordtype save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine overlap -- p-orbital overlap for pisystem ## c ## ## c ############################################################## c c c "overlap" computes the overlap for two parallel p-orbitals c given the atomic numbers and distance of separation c c subroutine overlap (atmnum1,atmnum2,rang,ovlap) use units implicit none integer atmnum1 integer atmnum2 integer na,nb,la,lb real*8 ovlap real*8 rbohr,rang real*8 za,zb,s(3) real*8 zeta(18) save zeta c c Slater orbital exponents for hydrogen through argon c data zeta / 1.000, 1.700, 0.650, 0.975, 1.300, 1.625, & 1.950, 2.275, 2.600, 2.925, 0.733, 0.950, & 1.167, 1.383, 1.600, 1.817, 2.033, 2.250 / c c c principal quantum number from atomic number c na = 2 nb = 2 if (atmnum1 .gt. 10) na = 3 if (atmnum2 .gt. 10) nb = 3 c c azimuthal quantum number for p-orbitals c la = 1 lb = 1 c c orbital exponent from stored ideal values c za = zeta(atmnum1) zb = zeta(atmnum2) c c convert interatomic distance to bohrs c rbohr = rang / bohr c c get pi-overlap via generic overlap integral routine c call slater (na,la,za,nb,lb,zb,rbohr,s) ovlap = s(2) return end c c c ############################################################### c ## ## c ## subroutine slater -- find overlap integrals for STO's ## c ## ## c ############################################################### c c c "slater" is a general routine for computing the overlap c integrals between two Slater-type orbitals c c literature reference: c c D. B. Cook, "Structures and Approximations for Electrons in c Molecules", Ellis Horwood Limited, Sussex, England, 1978, c adapted from the code in Chapter 7 c c variables and parameters: c c na principle quantum number for first orbital c la azimuthal quantum number for first orbital c za orbital exponent for the first orbital c nb principle quantum number for second orbital c lb azimuthal quantum number for second orbital c zb orbital exponent for the second orbital c r interatomic distance in atomic units c s vector containing the sigma-sigma, pi-pi c and delta-delta overlaps upon output c c subroutine slater (na,la,za,nb,lb,zb,r,s) implicit none real*8 rmin,eps parameter (rmin=0.000001d0) parameter (eps=0.00000001d0) integer j,k,m,na,nb,la,lb,ja,jb integer nn,max,maxx,novi integer idsga(5),idsgb(5) integer icosa(2),icosb(2) integer isina(4),isinb(4) integer ia(200),ib(200) real*8 an,ana,anb,anr real*8 rhalf,coef,p,pt real*8 r,za,zb,cjkm real*8 s(3),fact(15) real*8 cbase(20),theta(6) real*8 cosa(2),cosb(2) real*8 sinab(4) real*8 dsiga(5),dsigb(5) real*8 a(20),b(20),c(200) logical done save icosa,icosb save cosa,cosb save idsga,idsgb save dsiga,dsigb save isina,isinb save sinab,theta,fact external cjkm data icosa / 0, 1 / data icosb / 0, 1 / data cosa / 1.0d0, 1.0d0 / data cosb / -1.0d0, 1.0d0 / data idsga / 0, 1, 2, 2, 0 / data idsgb / 0, 1, 2, 0, 2 / data dsiga / 3.0d0, 4.0d0, 3.0d0, -1.0d0, -1.0d0 / data dsigb / 3.0d0,-4.0d0, 3.0d0, -1.0d0, -1.0d0 / data isina / 0, 2, 0, 2 / data isinb / 0, 0, 2, 2 / data sinab / -1.0d0, 1.0d0, 1.0d0, -1.0d0 / data theta / 0.7071068d0, 1.2247450d0, 0.8660254d0, & 0.7905694d0, 1.9364916d0, 0.9682458d0 / data fact / 1.0d0, 1.0d0, 2.0d0, 6.0d0, 24.0d0, 120.0d0, & 720.0d0, 5040.0d0, 40320.0d0, 362880.0d0, & 3628800.0d0, 39916800.0d0, 479001600.0d0, & 6227020800.0d0, 87178291200.0d0 / c c c zero out the overlap integrals c done = .false. s(1) = 0.0d0 s(2) = 0.0d0 s(3) = 0.0d0 ana = (2.0d0*za)**(2*na+1) / fact(2*na+1) anb = (2.0d0*zb)**(2*nb+1) / fact(2*nb+1) c c orbitals are on the same atomic center c if (r .lt. rmin) then anr = 1.0d0 j = na + nb + 1 s(1) = fact(j) / ((za+zb)**j) an = sqrt(ana*anb) do novi = 1, 3 s(novi) = s(novi) * an * anr end do return end if c c compute overlap integrals for general case c rhalf = 0.5d0 * r p = rhalf * (za+zb) pt = rhalf * (za-zb) nn = na + nb call aset (p,nn,a) call bset (pt,nn,b) k = na - la m = nb - lb max = k + m + 1 do j = 1, max ia(j) = j - 1 ib(j) = max - j cbase(j) = cjkm(j-1,k,m) c(j) = cbase(j) end do maxx = max if (la .eq. 1) then call polyp (c,ia,ib,maxx,cosa,icosa,icosb,2) else if (la .eq. 2) then call polyp (c,ia,ib,maxx,dsiga,idsga,idsgb,5) end if if (lb .eq. 1) then call polyp (c,ia,ib,maxx,cosb,icosa,icosb,2) else if (lb .eq. 2) then call polyp (c,ia,ib,maxx,dsigb,idsga,idsgb,5) end if novi = 1 do while (.not. done) do j = 1, maxx ja = ia(j) + 1 jb = ib(j) + 1 coef = c(j) if (abs(coef) .ge. eps) then s(novi) = s(novi) + coef*a(ja)*b(jb) end if end do ja = la*(la+1)/2 + novi jb = lb*(lb+1)/2 + novi s(novi) = s(novi) * theta(ja) * theta(jb) if (novi.eq.1 .and. la.ne.0 .and. lb.ne.0) then maxx = max do j = 1, maxx c(j) = cbase(j) end do call polyp (c,ia,ib,maxx,sinab,isina,isinb,4) if (la .eq. 2) then call polyp (c,ia,ib,maxx,cosa,icosa,icosb,2) end if if (lb .eq. 2) then call polyp (c,ia,ib,maxx,cosb,icosa,icosb,2) end if novi = 2 else if (novi.eq.2 .and. la.eq.2 .and. lb.eq.2) then maxx = max do j = 1, maxx c(j) = cbase(j) end do call polyp (c,ia,ib,maxx,sinab,isina,isinb,4) call polyp (c,ia,ib,maxx,sinab,isina,isinb,4) novi = 3 else anr = rhalf**(na+nb+1) an = sqrt(ana*anb) do novi = 1, 3 s(novi) = s(novi) * an * anr end do done = .true. end if end do return end c c c ################################################################ c ## ## c ## subroutine polyp -- polynomial product for STO overlap ## c ## ## c ################################################################ c c c "polyp" is a polynomial product routine that multiplies two c algebraic forms c c subroutine polyp (c,ia,ib,max,d,iaa,ibb,n) implicit none integer i,j,k,m,max,n integer ia(200),ib(200) integer iaa(*),ibb(*) real*8 c(200),d(*) c c do j = 1, max do k = 1, n i = n - k + 1 m = (i-1)*max + j c(m) = c(j) * d(i) ia(m) = ia(j) + iaa(i) ib(m) = ib(j) + ibb(i) end do end do max = n * max return end c c c ############################################################## c ## ## c ## function cjkm -- coefficients of spherical harmonics ## c ## ## c ############################################################## c c c "cjkm" computes the coefficients of spherical harmonics c expressed in prolate spheroidal coordinates c c function cjkm (j,k,m) implicit none integer i,j,k,m integer min,max integer id,idd,ip1 real*8 cjkm,b1,b2,sum real*8 fact(15) save fact data fact / 1.0d0, 1.0d0, 2.0d0, 6.0d0, 24.0d0, 120.0d0, & 720.0d0, 5040.0d0, 40320.0d0, 362880.0d0, & 3628800.0d0, 39916800.0d0, 479001600.0d0, & 6227020800.0d0, 87178291200.0d0 / c c min = 1 if (j .gt. m) min = j - m + 1 max = j + 1 if (k .lt. j) max = k + 1 sum = 0.0d0 do ip1 = min, max i = ip1 - 1 id = k - i + 1 b1 = fact(k+1) / (fact(i+1)*fact(id)) if (j .lt. i) then b2 = 1.0d0 else id = m - (j-i) + 1 idd = j - i + 1 b2 = fact(m+1) / (fact(idd)*fact(id)) end if sum = sum + b1*b2*(-1.0d0)**i end do cjkm = sum * (-1.0d0)**(m-j) return end c c c ########################################################### c ## ## c ## subroutine aset -- get "A" functions by recursion ## c ## ## c ########################################################### c c c "aset" computes by recursion the A functions used in the c evaluation of Slater-type (STO) overlap integrals c c subroutine aset (alpha,n,a) implicit none integer i,n real*8 alpha,alp real*8 a(20) c c alp = 1.0d0 / alpha a(1) = exp(-alpha) * alp do i = 1, n a(i+1) = a(1) + dble(i)*a(i)*alp end do return end c c c ########################################################### c ## ## c ## subroutine bset -- get "B" functions by recursion ## c ## ## c ########################################################### c c c "bset" computes by downward recursion the B functions used c in the evaluation of Slater-type (STO) overlap integrals c c subroutine bset (beta,n,b) implicit none real*8 eps parameter (eps=0.000001d0) integer i,j,n real*8 beta,bmax real*8 betam,d1,d2 real*8 b(20) external bmax c c if (abs(beta) .lt. eps) then do i = 1, n+1 b(i) = 2.0d0 / dble(i) if ((i/2)*2 .eq. i) b(i) = 0.0d0 end do else if (abs(beta) .gt. (dble(n)/2.3d0)) then d1 = exp(beta) d2 = 1.0d0 / d1 betam = 1.0d0 / beta b(1) = (d1-d2) * betam do i = 1, n d1 = -d1 b(i+1) = (d1-d2+dble(i)*b(i)) * betam end do else b(n+1) = bmax(beta,n) d1 = exp(beta) d2 = 1.0d0 / d1 if ((n/2)*2 .ne. n) d1 = -d1 do i = 1, n j = n - i + 1 d1 = -d1 b(j) = (d1+d2+beta*b(j+1)) / dble(j) end do end if return end c c c ############################################################## c ## ## c ## function bmax -- find maximum order of "B" functions ## c ## ## c ############################################################## c c c "bmax" computes the maximum order of the B functions needed c for evaluation of Slater-type (STO) overlap integrals c c function bmax (beta,n) implicit none real*8 eps parameter (eps=0.0000001d0) integer n real*8 bmax,beta real*8 b,top,bot real*8 sum,fi real*8 sign,term logical done c c done = .false. b = beta**2 top = dble(n) + 1.0d0 sum = 1.0d0 / top fi = 2.0d0 sign = 2.0d0 if ((n/2)*2 .ne. n) then top = top + 1.0d0 sum = beta / top fi = fi + 1.0d0 sign = -2.0d0 end if term = sum do while (.not. done) bot = top + 2.0d0 term = term * b * top / (fi*(fi-1.0d0)*bot) sum = sum + term if (abs(term) .le. eps) then done = .true. else fi = fi + 2.0d0 top = bot end if end do bmax = sign * sum return end c c c ################################################### c ## COPYRIGHT (C) 2003 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module params -- force field parameter file contents ## c ## ## c ############################################################## c c c maxprm maximum number of lines in the parameter file c c nprm number of nonblank lines in the parameter file c prmline contents of each individual parameter file line c c module params implicit none integer maxprm parameter (maxprm=25000) integer nprm character*240 prmline(maxprm) save end c c c ############################################################### c ## COPYRIGHT (C) 1991 by Shawn Huston & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################### c c ################################################################ c ## ## c ## program path -- conformational interconversion pathway ## c ## ## c ################################################################ c c c "path" locates a series of structures equally spaced along c a conformational pathway connecting the input reactant and c product structures; a series of constrained optimizations c orthogonal to the path is done via Lagrangian multipliers c c literature reference: c c R. Czerminski and R. Elber, "Reaction Path Study of c Conformational Transitions in Flexible Systems: Applications c to Peptides", Journal of Chemical Physics, 92, 5580-5601 (1990) c c program path use align use atomid use atoms use files use inform use iounit use linmin use minima use output use paths implicit none integer i,j,k,nvar integer ix,iy,iz integer ipath,npath real*8 rmsvalue,project real*8 epot,etot real*8 epot0,epot1 real*8 sum,rplen,path1 real*8 grdmin,potnrg real*8, allocatable :: p(:) real*8, allocatable :: ge(:) real*8, allocatable :: xtmp(:) real*8, allocatable :: ytmp(:) real*8, allocatable :: ztmp(:) real*8, allocatable :: temp(:,:) logical exist character*240 string external path1 external optsave c c c initialize constants and get initial structure c call initial call getxyz c c perform dynamic allocation of some global arrays c nvar = 3 * n allocate (pc0(nvar)) allocate (pc1(nvar)) allocate (pvect(nvar)) allocate (pstep(nvar)) allocate (pzet(nvar)) allocate (gc(nvar,7)) allocate (ifit(2,n)) allocate (wfit(n)) c c perform dynamic allocation of some local arrays c allocate (xtmp(n)) allocate (ytmp(n)) allocate (ztmp(n)) c c get and store the initial structure coordinates c do i = 1, n pc0(3*i-2) = x(i) pc0(3*i-1) = y(i) pc0(3*i) = z(i) xtmp(i) = x(i) ytmp(i) = y(i) ztmp(i) = z(i) end do c c get the coordinates for the final structure c call getxyz call mechanic c c set default values for some control variables c cyclesave = .true. stpmax = 1.0d0 iwrite = 0 if (verbose) then iprint = 1 else iprint = 0 end if c c get the number of path points to be generated c npath = -1 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) npath 10 continue if (npath .le. 0) then write (iout,20) 20 format (/,' Enter Number of Path Points to Generate [9] : ',$) read (input,30) npath 30 format (i10) end if if (npath .le. 0) npath = 9 c c get the termination criterion as RMS gradient along path c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=40,end=40) grdmin 40 continue if (grdmin .le. 0.0d0) then write (iout,50) 50 format (/,' Enter RMS Gradient per Atom Criterion', & ' [0.1] : ',$) read (input,60) grdmin 60 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.1d0 c c superimpose the reactant and product structures c nfit = n do i = 1, n ifit(1,i) = i ifit(2,i) = i wfit(i) = mass(i) end do call impose (n,xtmp,ytmp,ztmp,n,x,y,z,rmsvalue) write (iout,70) rmsvalue 70 format (/,' RMS Fit for Reactant and Product :',f12.4) c c perform deallocation of some local arrays c deallocate (xtmp) deallocate (ytmp) deallocate (ztmp) c c perform dynamic allocation of some local arrays c allocate (p(nvar)) allocate (ge(nvar)) c c store the coordinates for the superimposed product c do i = 1, n pc1(3*i-2) = x(i) pc1(3*i-1) = y(i) pc1(3*i) = z(i) end do c c write out the starting potential energy values c epot0 = potnrg (pc0,ge) epot1 = potnrg (pc1,ge) write (iout,80) epot0,epot1 80 format (/,' Reactant Potential Energy :',f12.4, & /,' Product Potential Energy : ',f12.4) c c construct step vector for getting c optimization-initial coordinates c rplen = npath + 1 pnorm = 0.0d0 do i = 1, nvar pvect(i) = pc1(i) - pc0(i) pstep(i) = pvect(i) / rplen pnorm = pnorm + pvect(i)**2 end do pnorm = sqrt(pnorm) c c set the gradient of constraints array c do i = 1, n ix = 3*(i-1) + 1 iy = ix + 1 iz = iy + 1 gc(ix,1) = pvect(ix) gc(iy,1) = pvect(iy) gc(iz,1) = pvect(iz) gc(ix,2) = mass(i) gc(iy,2) = 0.0d0 gc(iz,2) = 0.0d0 gc(ix,3) = 0.0d0 gc(iy,3) = mass(i) gc(iz,3) = 0.0d0 gc(ix,4) = 0.0d0 gc(iy,4) = 0.0d0 gc(iz,4) = mass(i) gc(ix,5) = 0.0d0 gc(iy,5) = mass(i) * pc0(iz) gc(iz,5) = -mass(i) * pc0(iy) gc(ix,6) = -mass(i) * pc0(iz) gc(iy,6) = 0.0d0 gc(iz,6) = mass(i) * pc0(ix) gc(ix,7) = mass(i) * pc0(iy) gc(iy,7) = -mass(i) * pc0(ix) gc(iz,7) = 0.0d0 end do c c perform dynamic allocation of some local arrays c allocate (temp(nvar,7)) c c copy to temporary storage and orthogonalize c do i = 1, 7 do j = 1, nvar temp(j,i) = gc(j,i) end do end do call orthog (nvar,7,gc) c c set the A matrix to transform sigma into C space c do i = 1, 7 do k = 1, 7 sum = 0.0d0 do j = 1, nvar sum = sum + temp(j,i)*gc(j,k) end do acoeff(i,k) = sum end do end do c c perform deallocation of some local arrays c deallocate (temp) c c perform the matrix inversion to get A matrix c which transforms C into sigma space c call invert (7,acoeff) c c set the current path point to be the reactant c do i = 1, nvar p(i) = pc0(i) end do c c loop over structures along path to be optimized c do ipath = 1, npath write (iout,90) ipath 90 format (/,' Path Point :',i12) c c get r(zeta), set initial path point and energy c do i = 1, nvar pzet(i) = pc0(i) + ipath*pstep(i) p(i) = p(i) + pstep(i) end do epot = potnrg (p,ge) write (iout,100) epot 100 format (' Initial Point :',12x,f12.4) c c call optimizer to get constrained minimum c call lbfgs (nvar,p,etot,grdmin,path1,optsave) c call ocvm (nvar,p,etot,grdmin,path1,optsave) c c print energy and constraint value at the minimum c epot = potnrg (p,ge) write (iout,110) epot 110 format (' Optimized Point :',10x,f12.4) write (iout,120) etot-epot 120 format (' Target-Energy Difference :',d13.3) c c write coordinates of the current path point c call optsave (ipath,epot,p) c c find projection of the gradient along path direction c project = 0.0d0 do i = 1, nvar project = project + ge(i)*pvect(i)/pnorm end do write (iout,130) project 130 format (' Gradient along Path :',6x,f12.4) end do c c perform deallocation of some local arrays c deallocate (p) deallocate (ge) c c perform any final tasks before program exit c call final end c c c ################################################################# c ## ## c ## function path1 -- value and gradient of target function ## c ## ## c ################################################################# c c function path1 (p,gt) use atomid use atoms use paths implicit none integer i,j,nvar integer ix,iy,iz real*8 xx,yy,zz real*8 path1,cterm real*8 potnrg real*8 gamma(7) real*8 cnst(7) real*8 sigma(7) real*8 p(*) real*8 gt(*) real*8, allocatable :: ge(:) c c c perform dynamic allocation of some local arrays c nvar = 3 * n allocate (ge(nvar)) c c get the value of the potential energy c path1 = potnrg (p,ge) c c construct the Lagrangian multipliers c do i = 1, 7 gamma(i) = 0.0d0 do j = 1, nvar gamma(i) = gamma(i) - ge(j)*gc(j,i) end do end do c c set the path value, translation and rotation constraints c do i = 1, 7 cnst(i) = 0.0d0 end do do i = 1, n ix = 3*(i-1) + 1 iy = ix + 1 iz = iy + 1 xx = p(ix) - pzet(ix) yy = p(iy) - pzet(iy) zz = p(iz) - pzet(iz) cnst(1) = cnst(1) + xx*pvect(ix) + yy*pvect(iy) + zz*pvect(iz) cnst(2) = cnst(2) + mass(i) * (p(ix)-pc0(ix)) cnst(3) = cnst(3) + mass(i) * (p(iy)-pc0(iy)) cnst(4) = cnst(4) + mass(i) * (p(iz)-pc0(iz)) cnst(5) = cnst(5) + mass(i) * (p(iy)*pc0(iz)-p(iz)*pc0(iy)) cnst(6) = cnst(6) + mass(i) * (p(iz)*pc0(ix)-p(ix)*pc0(iz)) cnst(7) = cnst(7) + mass(i) * (p(ix)*pc0(iy)-p(iy)*pc0(ix)) end do c c construct the orthonormal "sigma" constraints c do i = 1, 7 sigma(i) = 0.0d0 do j = 1, 7 sigma(i) = sigma(i) + acoeff(i,j)*cnst(j) end do end do c c find the target function value c cterm = 0.0d0 do i = 1, 7 cterm = cterm + gamma(i)*sigma(i) end do path1 = path1 + cterm c c construct the gradient of the target function c do i = 1, nvar gt(i) = ge(i) do j = 1, 7 gt(i) = gt(i) + gamma(j)*gc(i,j) end do end do c c perform deallocation of some local arrays c deallocate (ge) return end c c c ########################################################## c ## ## c ## function potnrg -- potential energy and gradient ## c ## ## c ########################################################## c c function potnrg (xx,g) use atoms use paths implicit none integer i real*8 energy real*8 potnrg real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) c c c copy position vector into atomic coordinates c do i = 1, n x(i) = xx(3*i-2) y(i) = xx(3*i-1) z(i) = xx(3*i) end do c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute potential energy and Cartesian derivatives c call gradient (energy,derivs) c c set the energy value and gradient vector c potnrg = energy do i = 1, n g(3*i-2) = derivs(1,i) g(3*i-1) = derivs(2,i) g(3*i) = derivs(3,i) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module paths -- Elber reaction path method parameters ## c ## ## c ############################################################### c c c pnorm length of the reactant-product vector c acoeff transformation matrix 'A' from Elber algorithm c pc0 reactant Cartesian coordinates as variables c pc1 product Cartesian coordinates as variables c pvect vector connecting the reactant and product c pstep step per cycle along reactant-product vector c pzet current projection on reactant-product vector c gc gradient of the path constraints c c module paths implicit none real*8 pnorm real*8 acoeff(7,7) real*8, allocatable :: pc0(:) real*8, allocatable :: pc1(:) real*8, allocatable :: pvect(:) real*8, allocatable :: pstep(:) real*8, allocatable :: pzet(:) real*8, allocatable :: gc(:,:) save end c c c ################################################################ c ## COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ################################################################# c ## ## c ## module pbstuf -- Poisson-Boltzmann solvation parameters ## c ## ## c ################################################################# c c c APBS configuration parameters (see APBS documentation for details) c In the column on the right are possible values for each variable, c with default values given in brackets. Only a subset of the APBS c options are supported and/or are appropriate for use with AMOEBA c c pbtyp lpbe c c At some point AMOEBA with the non-linear PBE could be supported, c but this is only worked out for energies (no gradients) c c pbsoln mg-auto, [mg-manual] c c Currently there is only limited support for focusing calculations, c which is a powerful feature of APBS. At present, all energies and c forces must all be calculated using the finest solution c c bcfl boundary conditions zero, sdh, [mdh] c chgm multipole discretization spl4 c c other charge discretization methods are not appropriate for AMOEBA c c srfm surface method mol, smol, [spl4] c c spl4 is required for forces calculations, although mol is useful c for comparison with generalized Kirkwood c c dime number of grid points [65, 65, 65] c grid grid spacing (mg-manual) fxn of "dime" c cgrid coarse grid spacing fxn of "dime" c fgrid fine grid spacing cgrid / 2 c c stable results require grid spacing to be fine enough to keep c multipoles inside the dielectric boundary (2.5 * grid < PBR) c c gcent grid center (mg-manual) center of mass c cgcent coarse grid center center of mass c fgcent fine grid center center of mass c pdie solute/homogeneous dieletric [1.0] c sdie solvent dieletric [78.3] c ionn number of ion species [0] c ionc ion concentration (M) [0.0] c ionq ion charge (electrons) [1.0] c ionr ion radius (A) [2.0] c srad solvent probe radius (A) [1.4] c swin surface spline window width [0.3] c sdens density of surface points [10.0] c c additional parameter to facilitate default grid setup c c smin minimum distance between an [10.0] c atom and the grid boundary (A) c c pbe Poisson-Boltzmann permanent multipole solvation energy c apbe Poisson-Boltzmann permanent multipole energy over atoms c pbep Poisson-Boltzmann energies on permanent multipoles c pbfp Poisson-Boltzmann forces on permanent multipoles c pbtp Poisson-Boltzmann torques on permanent multipoles c pbeuind Poisson-Boltzmann field due to induced dipoles c pbeuinp Poisson-Boltzmann field due to non-local induced dipoles c c module pbstuf implicit none integer maxion parameter (maxion=10) integer ionn integer dime(3) integer ionq(maxion) real*8 pbe real*8 pdie,sdie real*8 srad,swin real*8 sdens,smin real*8 grid(3) real*8 gcent(3) real*8 cgrid(3) real*8 cgcent(3) real*8 fgrid(3) real*8 fgcent(3) real*8 ionr(maxion) real*8 ionc(maxion) real*8, allocatable :: apbe(:) real*8, allocatable :: pbep(:,:) real*8, allocatable :: pbfp(:,:) real*8, allocatable :: pbtp(:,:) real*8, allocatable :: pbeuind(:,:) real*8, allocatable :: pbeuinp(:,:) character*20 pbtyp,pbsoln character*20 bcfl,chgm,srfm save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module pdb -- Protein Data Bank structure definition ## c ## ## c ############################################################## c c c npdb number of atoms stored in Protein Data Bank format c nres number of residues stored in Protein Data Bank format c resnum number of the residue to which each atom belongs c resatm number of first and last atom in each residue c npdb12 number of atoms directly bonded to each CONECT atom c ipdb12 atom numbers of atoms connected to each CONECT atom c pdblist list of the Protein Data Bank atom number of each atom c xpdb x-coordinate of each atom stored in PDB format c ypdb y-coordinate of each atom stored in PDB format c zpdb z-coordinate of each atom stored in PDB format c altsym string with PDB alternate locations to be included c pdbres Protein Data Bank residue name assigned to each atom c pdbsym Protein Data Bank atomic symbol assigned to each atom c pdbatm Protein Data Bank atom name assigned to each atom c pdbtyp Protein Data Bank record type assigned to each atom c chnsym string with PDB chain identifiers to be included c instyp string with PDB insertion records to be included c c module pdb implicit none integer npdb,nres integer, allocatable :: resnum(:) integer, allocatable :: resatm(:,:) integer, allocatable :: npdb12(:) integer, allocatable :: ipdb12(:,:) integer, allocatable :: pdblist(:) real*8, allocatable :: xpdb(:) real*8, allocatable :: ypdb(:) real*8, allocatable :: zpdb(:) character*1 altsym character*3, allocatable :: pdbres(:) character*3, allocatable :: pdbsym(:) character*4, allocatable :: pdbatm(:) character*6, allocatable :: pdbtyp(:) character*20 chnsym character*20 instyp save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## program pdbxyz -- Protein Data Bank to XYZ coordinates ## c ## ## c ################################################################ c c c "pdbxyz" takes as input a Protein Data Bank file and then c converts to and writes out a Cartesian coordinates file and, c for biopolymers, a sequence file c c program pdbxyz use atomid use atoms use couple use files use inform use katoms use pdb use resdue use sequen use titles implicit none integer i,j,it,next integer ipdb,ixyz,iseq integer last,pdbleng integer freeunit integer, allocatable :: row(:) real*8 xi,yi,zi,rij real*8 rcut,rmax(0:25) logical biopoly logical clash character*1 letter character*3 resname character*3 reslast character*240 pdbfile character*240 xyzfile character*240 seqfile character*240 pdbtitle c c c get the Protein Data Bank file and a parameter set c call initial call getpdb call field call unitcell c c save the title line from the PDB file for later use c pdbleng = ltitle pdbtitle = title(1:ltitle) c c decide whether the system has only biopolymers and water c biopoly = .false. reslast = '***' do i = 1, npdb if (pdbtyp(i) .eq. 'ATOM ') then resname = pdbres(i) if (resname .ne. reslast) then reslast = resname do j = 1, maxamino if (resname .eq. amino(j)) then biopoly = .true. goto 10 end if end do do j = 1, maxnuc if (resname .eq. nuclz(j)) then biopoly = .true. goto 10 end if end do biopoly = .false. goto 20 10 continue end if else if (pdbtyp(i) .eq. 'HETATM') then resname = pdbres(i) if (resname .ne. reslast) then reslast = resname if (resname.eq.'HOH' .or. resname.eq.' LI' .or. & resname.eq.' NA' .or. resname.eq.' K' .or. & resname.eq.' RB' .or. resname.eq.' CS' .or. & resname.eq.' MG' .or. resname.eq.' CA' .or. & resname.eq.' SR' .or. resname.eq.' BA' .or. & resname.eq.' F' .or. resname.eq.' CL' .or. & resname.eq.' BR' .or. resname.eq.' I' .or. & resname.eq.' ZN') then pdbtyp(i) = 'HETATM' end if end if end if end do 20 continue c c open the Tinker coordinates file to be used for output c ixyz = freeunit () xyzfile = filename(1:leng)//'.xyz' call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') c c reopen the PDB file and read the first coordinate set c ipdb = freeunit () pdbfile = filename call suffix (pdbfile,'pdb','old') open (unit=ipdb,file=pdbfile,status ='old') rewind (unit=ipdb) call readpdb (ipdb) c c use special translation mechanisms for biopolymers c do while (.not. abort) if (biopoly) then n = 0 do i = 1, nchain if (chntyp(i) .eq. 'PEPTIDE') call ribosome (i) if (chntyp(i) .eq. 'NUCLEIC') call ligase (i) end do call hetatom last = n do i = last, 1, -1 if (type(i) .eq. 0) call delete (i) end do c c get general atom properties for non-biopolymer structures c else n = npdb do i = 1, n x(i) = xpdb(i) y(i) = ypdb(i) z(i) = zpdb(i) if (pdbsym(i) .ne. ' ') then name(i) = pdbsym(i) else letter = pdbatm(i)(1:1) if (letter.ge.'A' .and. letter.le.'Z') then name(i) = pdbatm(i)(1:3) else name(i) = pdbatm(i)(2:4) end if end if n12(i) = 0 next = 1 call getnumb (pdbres(i),type(i),next) end do c c add missing hydrogen atoms to satisfy empty valences c c call addhydro c c perform dynamic allocation of some local arrays c allocate (row(n)) c c set atom size classification from periodic table row c do i = 1, n it = type(i) if (it .eq. 0) then atomic(i) = 0 letter = name(i)(1:1) call upcase (letter) if (letter .eq. 'H') then row(i) = 1 atomic(i) = 1 else if (letter .eq. 'B') then row(i) = 2 atomic(i) = 5 if (name(i)(2:2) .eq. 'R') then row(i) = 5 atomic(i) = 35 end if else if (letter .eq. 'C') then row(i) = 2 atomic(i) = 6 if (name(i)(2:2) .eq. 'L') then row(i) = 3 atomic(i) = 17 end if else if (letter .eq. 'N') then row(i) = 2 atomic(i) = 7 else if (letter .eq. 'O') then row(i) = 2 atomic(i) = 8 else if (letter .eq. 'F') then row(i) = 2 atomic(i) = 9 else if (letter .eq. 'P') then row(i) = 3 atomic(i) = 15 else if (letter .eq. 'S') then row(i) = 3 atomic(i) = 16 if (name(i)(2:2) .eq. 'I') then row(i) = 3 atomic(i) = 14 end if else if (letter .eq. 'I') then row(i) = 5 atomic(i) = 53 else row(i) = 0 end if else if (ligand(it) .eq. 0) then row(i) = 0 else if (atmnum(it) .le. 2) then row(i) = 1 else if (atmnum(it) .le. 10) then row(i) = 2 else if (atmnum(it) .le. 18) then row(i) = 3 else row(i) = 5 end if end do c c set the maximum bonded distance between atom type pairs c rmax(0) = -1.0d0 rmax(1) = -1.0d0 rmax(2) = 1.3d0 rmax(3) = 1.55d0 rmax(4) = 1.75d0 rmax(5) = 1.90d0 rmax(6) = 2.0d0 rmax(9) = 2.2d0 rmax(10) = 2.4d0 rmax(15) = 2.6d0 rmax(25) = 2.8d0 c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(n,x,y,z,row,rmax,n12,i12) !$OMP DO schedule(guided) c c find and connect atom pairs within bonding distance c do i = 1, n-1 xi = x(i) yi = y(i) zi = z(i) do j = i+1, n rcut = rmax(row(i)*row(j))**2 rij = (xi-x(j))**2 + (yi-y(j))**2 + (zi-z(j))**2 if (rij .le. rcut) then n12(i) = n12(i) + 1 i12(n12(i),i) = j n12(j) = n12(j) + 1 i12(n12(j),j) = i end if 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 (row) c c assign generic atom types if currently unassigned c do i = 1, n if (it .eq. 0) type(i) = 10*atomic(i) + n12(i) end do end if c c sort the attached atom lists into ascending order c do i = 1, n call sort (n12(i),i12(1,i)) end do c c check for atom pairs with identical coordinates c clash = .false. call chkxyz (clash) c c write the coordinates file and reset the connectivities c ltitle = pdbleng title = pdbtitle(1:ltitle) call prtxyz (ixyz) do i = 1, n n12(i) = 0 end do c c read the next coordinate set from Protein Data Bank file c call readpdb (ipdb) end do c c write a sequence file for proteins and nucleic acids c if (biopoly) then iseq = freeunit () seqfile = filename(1:leng)//'.seq' call version (seqfile,'new') open (unit=iseq,file=seqfile,status='new') call prtseq (iseq) close (unit=iseq) end if c c perform any final tasks before program exit c close (unit=ixyz) call final end c c c ################################################################# c ## ## c ## subroutine ribosome -- coordinates from PDB polypeptide ## c ## ## c ################################################################# c c c "ribosome" translates a polypeptide structure in Protein Data c Bank format to a Cartesian coordinate file and sequence file c c subroutine ribosome (ichn) use atoms use fields use files use inform use iounit use pdb use resdue use sequen implicit none integer i,j,k,m integer ichn,ityp integer jres,kres integer start,stop integer cyxtyp integer ncys,ndisulf integer, allocatable :: ni(:) integer, allocatable :: cai(:) integer, allocatable :: ci(:) integer, allocatable :: oi(:) integer, allocatable :: si(:) integer, allocatable :: icys(:) integer, allocatable :: idisulf(:,:) real*8 xr,yr,zr,r real*8, allocatable :: xcys(:) real*8, allocatable :: ycys(:) real*8, allocatable :: zcys(:) logical newchn logical midchn logical endchn logical cyclic character*3 resname character*4 atmname save si c c c perform dynamic allocation of some local arrays c allocate (ni(nres)) allocate (cai(nres)) allocate (ci(nres)) allocate (oi(nres)) allocate (si(nres)) allocate (icys(nres)) allocate (idisulf(2,nres)) allocate (xcys(nres)) allocate (ycys(nres)) allocate (zcys(nres)) c c set the next atom and the residue range of the chain c n = n + 1 jres = ichain(1,ichn) kres = ichain(2,ichn) do i = jres, kres ni(i) = 0 cai(i) = 0 ci(i) = 0 oi(i) = 0 end do c c check for the presence of a cyclic polypeptide chain c cyclic = .false. start = resatm(1,jres) stop = resatm(2,jres) call findatm (' N ',start,stop,j) if (j .ne. 0) ni(jres) = j start = resatm(1,kres) stop = resatm(2,kres) call findatm (' C ',start,stop,k) if (k .ne. 0) ci(kres) = k if (jres.ne.kres .and. j.ne.0 .and. k.ne.0) then xr = xpdb(k) - xpdb(j) yr = ypdb(k) - ypdb(j) zr = zpdb(k) - zpdb(j) r = sqrt(xr*xr + yr*yr + zr*zr) if (r .le. 3.0d0) cyclic = .true. end if c c search for any potential cystine disulfide bonds c do i = 1, maxamino if (amino(i) .eq. 'CYX') cyxtyp = i end do ncys = 0 do i = 1, nres start = resatm(1,i) resname = pdbres(start) if (resname.eq.'CYS' .or. resname.eq.'CYX') then stop = resatm(2,i) call findatm (' SG ',start,stop,k) ncys = ncys + 1 icys(ncys) = i xcys(ncys) = xpdb(k) ycys(ncys) = ypdb(k) zcys(ncys) = zpdb(k) end if end do ndisulf = 0 do i = 1, ncys-1 do k = i+1, ncys xr = xcys(k) - xcys(i) yr = ycys(k) - ycys(i) zr = zcys(k) - zcys(i) r = sqrt(xr*xr + yr*yr + zr*zr) if (r .le. 3.0d0) then ndisulf = ndisulf + 1 idisulf(1,ndisulf) = min(icys(i),icys(k)) idisulf(2,ndisulf) = max(icys(i),icys(k)) end if end do end do do i = 1, ndisulf j = idisulf(1,i) k = idisulf(2,i) seqtyp(j) = cyxtyp seqtyp(k) = cyxtyp seq(j) = 'CYX' seq(k) = 'CYX' start = resatm(1,j) stop = resatm(2,j) do m = start, stop pdbres(m) = 'CYX' end do start = resatm(1,k) stop = resatm(2,k) do m = start, stop pdbres(m) = 'CYX' end do end do c c locate and assign the atoms that make up each residue c do i = jres, kres ityp = seqtyp(i) start = resatm(1,i) stop = resatm(2,i) resname = seq(i) c c check that the maximum allowed atoms is not exceeded c if (n+25 .gt. maxatm) then write (iout,10) maxatm 10 format (/,' RIBOSOME -- The Maximum of',i9,' Atoms', & ' has been Exceeded') call fatal end if c c test location of residue within the current chain c newchn = .false. midchn = .false. endchn = .false. if (i .eq. jres) newchn = .true. if (i .eq. kres) endchn = .true. if (.not.newchn .and. .not.endchn) midchn = .true. c c build the amide nitrogen of the current residue c atmname = ' N ' if (resname .eq. 'COH') atmname = ' OH ' call findatm (atmname,start,stop,k) if (k .ne. 0) ni(i) = n if (midchn) then j = ntyp(ityp) call oldatm (k,j,ci(i-1),i) else if (newchn) then if (cyclic) then j = ntyp(ityp) else j = nntyp(ityp) end if call oldatm (k,j,0,i) else if (endchn) then if (cyclic) then j = ntyp(ityp) else j = nctyp(ityp) end if call oldatm (k,j,ci(i-1),i) end if c c build the alpha carbon of the current residue c atmname = ' CA ' if (resname .eq. 'ACE') atmname = ' CH3' if (resname .eq. 'NME') atmname = ' CH3' call findatm (atmname,start,stop,k) if (k .ne. 0) cai(i) = n if (midchn .or. cyclic .or. nres.eq.1) then j = catyp(ityp) call oldatm (k,j,ni(i),i) else if (newchn) then j = cantyp(ityp) call oldatm (k,j,ni(i),i) else if (endchn) then j = cactyp(ityp) call oldatm (k,j,ni(i),i) end if c c build the carbonyl carbon of the current residue c call findatm (' C ',start,stop,k) if (k .ne. 0) ci(i) = n if (midchn .or. cyclic) then j = ctyp(ityp) call oldatm (k,j,cai(i),i) else if (newchn) then j = cntyp(ityp) call oldatm (k,j,cai(i),i) else if (endchn) then j = cctyp(ityp) if (resname .eq. 'COH') then type(ci(i-1)) = biotyp(j) else call oldatm (k,j,cai(i),i) end if end if c c build the carbonyl oxygen of the current residue c call findatm (' O ',start,stop,k) if (k .ne. 0) oi(i) = n if (midchn .or. cyclic) then j = otyp(ityp) call oldatm (k,j,ci(i),i) else if (newchn) then j = ontyp(ityp) call oldatm (k,j,ci(i),i) else if (endchn) then j = octyp(ityp) if (resname .eq. 'COH') then type(oi(i-1)) = biotyp(j) else call oldatm (k,j,ci(i),i) end if end if c c build the amide hydrogens of the current residue c if (midchn .or. (endchn.and.cyclic)) then j = hntyp(ityp) call findatm (' H ',start,stop,k) call newatm (k,j,ni(i),1.01d0,ci(i-1),119.0d0, & cai(i),119.0d0,1) else if (newchn .and. cyclic) then j = hntyp(ityp) call findatm (' H ',start,stop,k) call newatm (k,j,ni(i),1.01d0,ci(kres),119.0d0, & cai(i),119.0d0,1) else if (newchn) then j = hnntyp(ityp) if (resname .eq. 'PRO') then call findatm (' H2 ',start,stop,k) call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0, & ci(i),0.0d0,0) call findatm (' H3 ',start,stop,k) call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0, & ci(i),-120.0d0,0) else if (resname .eq. 'PCA') then call findatm (' H ',start,stop,k) call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0, & ci(i),-60.0d0,0) else call findatm (' H1 ',start,stop,k) if (k .eq. 0) call findatm (' H ',start,stop,k) call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0, & ci(i),180.0d0,0) call findatm (' H2 ',start,stop,k) call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0, & ci(i),60.0d0,0) call findatm (' H3 ',start,stop,k) call newatm (k,j,ni(i),1.01d0,cai(i),109.5d0, & ci(i),-60.0d0,0) end if else if (endchn) then j = hnctyp(ityp) if (resname .eq. 'COH') then call findatm (' HO ',start,stop,k) call newatm (k,j,ni(i),0.98d0,ci(i-1),108.7d0, & cai(i-1),180.0d0,0) else if (resname .eq. 'NH2') then call findatm (' H1 ',start,stop,k) if (k .eq. 0) call findatm (' H ',start,stop,k) call newatm (k,j,ni(i),1.01d0,ci(i-1),120.9d0, & cai(i-1),0.0d0,0) call findatm (' H2 ',start,stop,k) call newatm (k,j,ni(i),1.01d0,ci(i-1),120.3d0, & cai(i-1),180.0d0,0) else if (resname .eq. 'NME') then call findatm (' H ',start,stop,k) call newatm (k,j,ni(i),1.01d0,ci(i-1),119.0d0, & cai(i),119.0d0,1) else call findatm (' H ',start,stop,k) call newatm (k,j,ni(i),1.01d0,ci(i-1),119.0d0, & cai(i),119.0d0,1) end if end if c c build the alpha hydrogen of the current residue c if (resname .eq. 'GLY') then call findatm (' HA2',start,stop,k) else call findatm (' HA ',start,stop,k) end if if (midchn .or. cyclic) then j = hatyp(ityp) call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0, & ci(i),109.5d0,-1) else if (newchn) then j = hantyp(ityp) if (resname .eq. 'FOR') then call findatm (' H ',start,stop,k) call newatm (k,j,ci(i),1.12d0,oi(i),0.0d0,0,0.0d0,0) else if (resname .eq. 'ACE') then call findatm (' H1 ',start,stop,k) if (k .eq. 0) call findatm (' H ',start,stop,k) call newatm (k,j,cai(i),1.10d0,ci(i),109.5d0, & oi(i),180.0d0,0) call findatm (' H2 ',start,stop,k) call newatm (k,j,cai(i),1.10d0,ci(i),109.5d0, & oi(i),60.0d0,0) call findatm (' H3 ',start,stop,k) call newatm (k,j,cai(i),1.10d0,ci(i),109.5d0, & oi(i),-60.0d0,0) else call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0, & ci(i),109.5d0,-1) end if else if (endchn) then j = hactyp(ityp) if (resname .eq. 'NME') then call findatm (' H1 ',start,stop,k) if (k .eq. 0) call findatm (' H ',start,stop,k) call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0, & ci(i-1),180.0d0,0) call findatm (' H2 ',start,stop,k) call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0, & ci(i-1),60.0d0,0) call findatm (' H3 ',start,stop,k) call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0, & ci(i-1),-60.0d0,0) else call newatm (k,j,cai(i),1.10d0,ni(i),109.5d0, & ci(i),109.5d0,-1) end if end if c c build the side chain atoms of the current residue c call addside (resname,i,newchn,endchn,start,stop, & cai(i),ni(i),ci(i),si(i)) c c build the terminal oxygen at the end of a peptide chain c if (endchn .and. .not.cyclic .and. resname.ne.'COH') then call findatm (' OXT',start,stop,k) if (k .eq. 0) call findatm (' OT2',start,stop,k) j = octyp(ityp) call newatm (k,j,ci(i),1.25d0,cai(i),117.0d0, & oi(i),126.0d0,1) end if end do c c connect the terminal residues if the chain is cyclic c if (cyclic) then call addbond (ni(jres),ci(kres)) if (verbose) then write (iout,20) jres,kres 20 format (/,' Peptide Cyclization between Residues : ',2i5) end if end if c c connect the sulfur atoms involved in disulfide bonds c do i = 1, ndisulf j = idisulf(1,i) k = idisulf(2,i) if (k.ge.ichain(1,ichn) .and. k.le.ichain(2,ichn)) then call addbond (si(j),si(k)) if (verbose) then write (iout,30) j,k 30 format (/,' Disulfide Bond between Residues : ',2i5) end if end if end do c c total number of atoms is one less than the current atom c n = n - 1 c c perform deallocation of some local arrays c deallocate (ni) deallocate (cai) deallocate (ci) deallocate (oi) deallocate (si) deallocate (icys) deallocate (idisulf) deallocate (xcys) deallocate (ycys) deallocate (zcys) return end c c c ################################################################ c ## ## c ## subroutine addside -- build the amino acid side chains ## c ## ## c ################################################################ c c c "addside" builds the Cartesian coordinates for a single amino c acid side chain; coordinates are read from the Protein Data c Bank file or found from internal coordinates, then atom types c are assigned and connectivity data generated c c note biotypes of CD and HD atoms for N-terminal proline are c set as absolute values, not relative to the CB atom; this may c need updating if the list of biotypes changes in the future c c subroutine addside (resname,ires,newchn,endchn, & start,stop,cai,ni,ci,si) use atoms use resdue use sequen implicit none integer i,k,ires integer start,stop integer cai,ni,ci,si logical newchn,endchn character*3 resname c c c zero out disulfide and set CB atom as reference site c si = 0 k = cbtyp(seqtyp(ires)) c c glycine residue (GLY) c if (resname .eq. 'GLY') then call findatm (' HA3',start,stop,i) k = hatyp(seqtyp(ires)) if (newchn) k = hantyp(seqtyp(ires)) if (endchn) k = hactyp(seqtyp(ires)) call newatm (i,k,cai,1.10d0,ni,109.5d0,ci,109.5d0,1) c c alanine residue (ALA) c else if (resname .eq. 'ALA') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' HB1',start,stop,i) call newatm (i,k+1,n-1,1.10d0,cai,110.2d0,ni,180.0d0,0) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-2,1.10d0,cai,110.2d0,ni,60.0d0,0) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-3,1.10d0,cai,110.2d0,ni,-60.0d0,0) c c valine residue (VAL) c else if (resname .eq. 'VAL') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG1',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CG2',start,stop,i) call oldatm (i,k+4,n-2,ires) call findatm (' HB ',start,stop,i) call newatm (i,k+1,n-3,1.10d0,cai,107.0d0,n-2,108.2d0,1) call findatm ('HG11',start,stop,i) call newatm (i,k+3,n-3,1.10d0,n-4,111.6d0,cai,180.0d0,0) call findatm ('HG12',start,stop,i) call newatm (i,k+3,n-4,1.10d0,n-5,111.6d0,cai,60.0d0,0) call findatm ('HG13',start,stop,i) call newatm (i,k+3,n-5,1.10d0,n-6,111.6d0,cai,-60.0d0,0) call findatm ('HG21',start,stop,i) call newatm (i,k+5,n-5,1.10d0,n-7,111.6d0,cai,180.0d0,0) call findatm ('HG22',start,stop,i) call newatm (i,k+5,n-6,1.10d0,n-8,111.6d0,cai,60.0d0,0) call findatm ('HG23',start,stop,i) call newatm (i,k+5,n-7,1.10d0,n-9,111.6d0,cai,-60.0d0,0) c c leucine residue (LEU) c else if (resname .eq. 'LEU') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD1',start,stop,i) call oldatm (i,k+4,n-1,ires) call findatm (' CD2',start,stop,i) call oldatm (i,k+6,n-2,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1) call findatm (' HG ',start,stop,i) call newatm (i,k+3,n-5,1.10d0,n-6,107.0d0,n-4,108.2d0,1) call findatm ('HD11',start,stop,i) call newatm (i,k+5,n-5,1.10d0,n-6,111.6d0,n-7,180.0d0,0) call findatm ('HD12',start,stop,i) call newatm (i,k+5,n-6,1.10d0,n-7,111.6d0,n-8,60.0d0,0) call findatm ('HD13',start,stop,i) call newatm (i,k+5,n-7,1.10d0,n-8,111.6d0,n-9,-60.0d0,0) call findatm ('HD21',start,stop,i) call newatm (i,k+7,n-7,1.10d0,n-9,111.6d0,n-10,180.0d0,0) call findatm ('HD22',start,stop,i) call newatm (i,k+7,n-8,1.10d0,n-10,111.6d0,n-11,60.0d0,0) call findatm ('HD23',start,stop,i) call newatm (i,k+7,n-9,1.10d0,n-11,111.6d0,n-12,-60.0d0,0) c c isoleucine residue (ILE) c else if (resname .eq. 'ILE') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG1',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CG2',start,stop,i) call oldatm (i,k+4,n-2,ires) call findatm (' CD1',start,stop,i) if (i .eq. 0) call findatm (' CD ',start,stop,i) call oldatm (i,k+6,n-2,ires) call findatm (' HB ',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,107.0d0,n-3,108.2d0,-1) call findatm ('HG12',start,stop,i) call newatm (i,k+3,n-4,1.10d0,n-5,109.5d0,n-2,109.5d0,1) call findatm ('HG13',start,stop,i) call newatm (i,k+3,n-5,1.10d0,n-6,109.5d0,n-3,109.5d0,-1) call findatm ('HG21',start,stop,i) call newatm (i,k+5,n-5,1.10d0,n-7,111.6d0,cai,180.0d0,0) call findatm ('HG22',start,stop,i) call newatm (i,k+5,n-6,1.10d0,n-8,111.6d0,cai,60.0d0,0) call findatm ('HG23',start,stop,i) call newatm (i,k+5,n-7,1.10d0,n-9,111.6d0,cai,-60.0d0,0) call findatm ('HD11',start,stop,i) call newatm (i,k+7,n-7,1.10d0,n-9,111.6d0,n-10,180.0d0,0) call findatm ('HD12',start,stop,i) call newatm (i,k+7,n-8,1.10d0,n-10,111.6d0,n-11,60.0d0,0) call findatm ('HD13',start,stop,i) call newatm (i,k+7,n-9,1.10d0,n-11,111.6d0,n-12,-60.0d0,0) c c serine residue (SER) c else if (resname .eq. 'SER') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' OG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-2,1.10d0,cai,109.2d0,n-1,109.5d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-3,1.10d0,cai,109.2d0,n-2,109.5d0,-1) call findatm (' HG ',start,stop,i) call newatm (i,k+3,n-3,0.94d0,n-4,106.9d0,cai,180.0d0,0) c c threonine residue (THR) c else if (resname .eq. 'THR') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' OG1',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CG2',start,stop,i) call oldatm (i,k+4,n-2,ires) call findatm (' HB ',start,stop,i) call newatm (i,k+1,n-3,1.10d0,cai,107.0d0,n-2,108.2d0,-1) call findatm (' HG1',start,stop,i) call newatm (i,k+3,n-3,0.94d0,n-4,106.9d0,cai,180.0d0,0) call findatm ('HG21',start,stop,i) call newatm (i,k+5,n-3,1.10d0,n-5,111.6d0,cai,180.0d0,0) call findatm ('HG22',start,stop,i) call newatm (i,k+5,n-4,1.10d0,n-6,111.6d0,cai,60.0d0,0) call findatm ('HG23',start,stop,i) call newatm (i,k+5,n-5,1.10d0,n-7,111.6d0,cai,-60.0d0,0) c c cysteine residue (CYS) c else if (resname .eq. 'CYS') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' SG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-2,1.10d0,cai,109.5d0,n-1,107.5d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-3,1.10d0,cai,109.5d0,n-2,107.5d0,-1) call findatm (' HG ',start,stop,i) call newatm (i,k+3,n-3,1.34d0,n-4,96.0d0,cai,180.0d0,0) c c cystine residue (CYX) c else if (resname .eq. 'CYX') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' SG ',start,stop,i) si = n call oldatm (i,k+2,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-2,1.10d0,cai,109.5d0,n-1,107.5d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-3,1.10d0,cai,109.5d0,n-2,107.5d0,-1) c c deprotonated cysteine residue (CYD) c else if (resname .eq. 'CYD') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' SG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-2,1.10d0,cai,109.5d0,n-1,107.5d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-3,1.10d0,cai,109.5d0,n-2,107.5d0,-1) c c proline residue (PRO) c else if (resname .eq. 'PRO') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD ',start,stop,i) if (newchn) then call oldatm (i,469,n-1,ires) else call oldatm (i,k+4,n-1,ires) end if call addbond (n-1,ni) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-3,1.10d0,cai,111.2d0,n-2,111.2d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,111.2d0,n-3,111.2d0,-1) call findatm (' HG2',start,stop,i) call newatm (i,k+3,n-4,1.10d0,n-5,111.2d0,n-3,111.2d0,1) call findatm (' HG3',start,stop,i) call newatm (i,k+3,n-5,1.10d0,n-6,111.2d0,n-4,111.2d0,-1) if (newchn) then call findatm (' HD2',start,stop,i) call newatm (i,470,n-5,1.10d0,n-6,111.2d0,ni,111.2d0,1) call findatm (' HD3',start,stop,i) call newatm (i,470,n-6,1.10d0,n-7,111.2d0,ni,111.2d0,-1) else call findatm (' HD2',start,stop,i) call newatm (i,k+5,n-5,1.10d0,n-6,111.2d0,ni,111.2d0,1) call findatm (' HD3',start,stop,i) call newatm (i,k+5,n-6,1.10d0,n-7,111.2d0,ni,111.2d0,-1) end if c c phenylalanine residue (PHE) c else if (resname .eq. 'PHE') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD1',start,stop,i) call oldatm (i,k+3,n-1,ires) call findatm (' CD2',start,stop,i) call oldatm (i,k+3,n-2,ires) call findatm (' CE1',start,stop,i) call oldatm (i,k+5,n-2,ires) call findatm (' CE2',start,stop,i) call oldatm (i,k+5,n-2,ires) call findatm (' CZ ',start,stop,i) call oldatm (i,k+7,n-1,ires) call addbond (n-1,n-3) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,-1) call findatm (' HD1',start,stop,i) call newatm (i,k+4,n-7,1.09d0,n-8,120.0d0,n-9,0.0d0,0) call findatm (' HD2',start,stop,i) call newatm (i,k+4,n-7,1.09d0,n-9,120.0d0,n-10,0.0d0,0) call findatm (' HE1',start,stop,i) call newatm (i,k+6,n-7,1.09d0,n-9,120.0d0,n-10,180.0d0,0) call findatm (' HE2',start,stop,i) call newatm (i,k+6,n-7,1.09d0,n-9,120.0d0,n-11,180.0d0,0) call findatm (' HZ ',start,stop,i) call newatm (i,k+8,n-7,1.09d0,n-8,120.0d0,n-10,180.0d0,0) c c tyrosine residue (TYR) c else if (resname .eq. 'TYR') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD1',start,stop,i) call oldatm (i,k+3,n-1,ires) call findatm (' CD2',start,stop,i) call oldatm (i,k+3,n-2,ires) call findatm (' CE1',start,stop,i) call oldatm (i,k+5,n-2,ires) call findatm (' CE2',start,stop,i) call oldatm (i,k+5,n-2,ires) call findatm (' CZ ',start,stop,i) call oldatm (i,k+7,n-1,ires) call addbond (n-1,n-3) call findatm (' OH ',start,stop,i) call oldatm (i,k+8,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-9,1.10d0,cai,107.9d0,n-8,110.0d0,-1) call findatm (' HD1',start,stop,i) call newatm (i,k+4,n-8,1.09d0,n-9,120.0d0,n-10,0.0d0,0) call findatm (' HD2',start,stop,i) call newatm (i,k+4,n-8,1.09d0,n-10,120.0d0,n-11,0.0d0,0) call findatm (' HE1',start,stop,i) call newatm (i,k+6,n-8,1.09d0,n-10,120.0d0,n-11,180.0d0,0) call findatm (' HE2',start,stop,i) call newatm (i,k+6,n-8,1.09d0,n-10,120.0d0,n-12,180.0d0,0) call findatm (' HH ',start,stop,i) call newatm (i,k+9,n-7,0.97d0,n-8,108.0d0,n-9,0.0d0,0) c c deprotonated tyrosine residue (TYD) c else if (resname .eq. 'TYD') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD1',start,stop,i) call oldatm (i,k+3,n-1,ires) call findatm (' CD2',start,stop,i) call oldatm (i,k+3,n-2,ires) call findatm (' CE1',start,stop,i) call oldatm (i,k+5,n-2,ires) call findatm (' CE2',start,stop,i) call oldatm (i,k+5,n-2,ires) call findatm (' CZ ',start,stop,i) call oldatm (i,k+7,n-1,ires) call addbond (n-1,n-3) call findatm (' OH ',start,stop,i) call oldatm (i,k+8,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-9,1.10d0,cai,107.9d0,n-8,110.0d0,-1) call findatm (' HD1',start,stop,i) call newatm (i,k+4,n-8,1.09d0,n-9,120.0d0,n-10,0.0d0,0) call findatm (' HD2',start,stop,i) call newatm (i,k+4,n-8,1.09d0,n-10,120.0d0,n-11,0.0d0,0) call findatm (' HE1',start,stop,i) call newatm (i,k+6,n-8,1.09d0,n-10,120.0d0,n-11,180.0d0,0) call findatm (' HE2',start,stop,i) call newatm (i,k+6,n-8,1.09d0,n-10,120.0d0,n-12,180.0d0,0) c c tryptophan residue (TRP) c else if (resname .eq. 'TRP') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD1',start,stop,i) call oldatm (i,k+3,n-1,ires) call findatm (' CD2',start,stop,i) call oldatm (i,k+5,n-2,ires) call findatm (' NE1',start,stop,i) call oldatm (i,k+6,n-2,ires) call findatm (' CE2',start,stop,i) call oldatm (i,k+8,n-1,ires) call addbond (n-1,n-3) call findatm (' CE3',start,stop,i) call oldatm (i,k+9,n-3,ires) call findatm (' CZ2',start,stop,i) call oldatm (i,k+11,n-2,ires) call findatm (' CZ3',start,stop,i) call oldatm (i,k+13,n-2,ires) call findatm (' CH2',start,stop,i) call oldatm (i,k+15,n-1,ires) call addbond (n-1,n-3) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-10,1.10d0,cai,107.9d0,n-9,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-11,1.10d0,cai,107.9d0,n-10,110.0d0,-1) call findatm (' HD1',start,stop,i) call newatm (i,k+4,n-10,1.09d0,n-11,126.0d0,n-12,0.0d0,0) call findatm (' HE1',start,stop,i) call newatm (i,k+7,n-9,1.01d0,n-11,126.3d0,n-12,180.0d0,0) call findatm (' HE3',start,stop,i) call newatm (i,k+10,n-8,1.09d0,n-6,120.0d0,n-5,180.0d0,0) call findatm (' HZ2',start,stop,i) call newatm (i,k+12,n-8,1.09d0,n-6,120.0d0,n-7,180.0d0,0) call findatm (' HZ3',start,stop,i) call newatm (i,k+14,n-8,1.09d0,n-7,120.0d0,n-9,180.0d0,0) call findatm (' HH2',start,stop,i) call newatm (i,k+16,n-8,1.09d0,n-9,120.0d0,n-11,180.0d0,0) c c histidine (HD and HE) residue (HIS) c else if (resname .eq. 'HIS') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' ND1',start,stop,i) call oldatm (i,k+3,n-1,ires) call findatm (' CD2',start,stop,i) call oldatm (i,k+5,n-2,ires) call findatm (' CE1',start,stop,i) call oldatm (i,k+7,n-2,ires) call findatm (' NE2',start,stop,i) call oldatm (i,k+9,n-1,ires) call addbond (n-1,n-3) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,-1) call findatm (' HD1',start,stop,i) call newatm (i,k+4,n-6,1.02d0,n-4,126.0d0,n-3,180.0d0,0) call findatm (' HD2',start,stop,i) call newatm (i,k+6,n-6,1.09d0,n-4,126.0d0,n-5,180.0d0,0) call findatm (' HE1',start,stop,i) call newatm (i,k+8,n-6,1.09d0,n-5,126.0d0,n-7,180.0d0,0) call findatm (' HE2',start,stop,i) call newatm (i,k+10,n-6,1.02d0,n-7,126.0d0,n-9,180.0d0,0) c c histidine (HD only) residue (HID) c else if (resname .eq. 'HID') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' ND1',start,stop,i) call oldatm (i,k+3,n-1,ires) call findatm (' CD2',start,stop,i) call oldatm (i,k+5,n-2,ires) call findatm (' CE1',start,stop,i) call oldatm (i,k+7,n-2,ires) call findatm (' NE2',start,stop,i) call oldatm (i,k+9,n-1,ires) call addbond (n-1,n-3) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,-1) call findatm (' HD1',start,stop,i) call newatm (i,k+4,n-6,1.02d0,n-4,126.0d0,n-3,180.0d0,0) call findatm (' HD2',start,stop,i) call newatm (i,k+6,n-6,1.09d0,n-4,126.0d0,n-5,180.0d0,0) call findatm (' HE1',start,stop,i) call newatm (i,k+8,n-6,1.09d0,n-5,126.0d0,n-7,180.0d0,0) c c histidine (HE only) residue (HIE) c else if (resname .eq. 'HIE') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' ND1',start,stop,i) call oldatm (i,k+3,n-1,ires) call findatm (' CD2',start,stop,i) call oldatm (i,k+4,n-2,ires) call findatm (' CE1',start,stop,i) call oldatm (i,k+6,n-2,ires) call findatm (' NE2',start,stop,i) call oldatm (i,k+8,n-1,ires) call addbond (n-1,n-3) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,-1) call findatm (' HD2',start,stop,i) call newatm (i,k+5,n-5,1.09d0,n-3,126.0d0,n-4,180.0d0,0) call findatm (' HE1',start,stop,i) call newatm (i,k+7,n-5,1.09d0,n-4,126.0d0,n-6,180.0d0,0) call findatm (' HE2',start,stop,i) call newatm (i,k+9,n-5,1.02d0,n-6,126.0d0,n-8,180.0d0,0) c c aspartic acid residue (ASP) c else if (resname .eq. 'ASP') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' OD1',start,stop,i) call oldatm (i,k+3,n-1,ires) call findatm (' OD2',start,stop,i) call oldatm (i,k+3,n-2,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1) c c protonated aspartic acid residue (ASH) c else if (resname .eq. 'ASH') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' OD1',start,stop,i) call oldatm (i,k+3,n-1,ires) call findatm (' OD2',start,stop,i) call oldatm (i,k+4,n-2,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1) call findatm (' HD2',start,stop,i) call newatm (i,k+5,n-3,0.98d0,n-5,108.7d0,n-4,0.0d0,0) c c asparagine residue (ASN) c else if (resname .eq. 'ASN') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' OD1',start,stop,i) call oldatm (i,k+3,n-1,ires) call findatm (' ND2',start,stop,i) call oldatm (i,k+4,n-2,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1) call findatm ('HD21',start,stop,i) call newatm (i,k+5,n-3,1.01d0,n-5,120.9d0,n-6,0.0d0,0) call findatm ('HD22',start,stop,i) call newatm (i,k+5,n-4,1.01d0,n-6,120.3d0,n-7,180.0d0,0) c c glutamic acid residue (GLU) c else if (resname .eq. 'GLU') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD ',start,stop,i) call oldatm (i,k+4,n-1,ires) call findatm (' OE1',start,stop,i) call oldatm (i,k+5,n-1,ires) call findatm (' OE2',start,stop,i) call oldatm (i,k+5,n-2,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1) call findatm (' HG2',start,stop,i) call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1) call findatm (' HG3',start,stop,i) call newatm (i,k+3,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1) c c protonated glutamic acid residue (GLH) c else if (resname .eq. 'GLH') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD ',start,stop,i) call oldatm (i,k+4,n-1,ires) call findatm (' OE1',start,stop,i) call oldatm (i,k+5,n-1,ires) call findatm (' OE2',start,stop,i) call oldatm (i,k+6,n-2,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1) call findatm (' HG2',start,stop,i) call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1) call findatm (' HG3',start,stop,i) call newatm (i,k+3,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1) call findatm (' HE2',start,stop,i) call newatm (i,k+7,n-5,0.98d0,n-7,108.7d0,n-6,0.0d0,0) c c glutamine residue (GLN) c else if (resname .eq. 'GLN') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD ',start,stop,i) call oldatm (i,k+4,n-1,ires) call findatm (' OE1',start,stop,i) call oldatm (i,k+5,n-1,ires) call findatm (' NE2',start,stop,i) call oldatm (i,k+6,n-2,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1) call findatm (' HG2',start,stop,i) call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1) call findatm (' HG3',start,stop,i) call newatm (i,k+3,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1) call findatm ('HE21',start,stop,i) call newatm (i,k+7,n-5,1.01d0,n-7,120.9d0,n-8,0.0d0,0) call findatm ('HE22',start,stop,i) call newatm (i,k+7,n-6,1.01d0,n-8,120.3d0,n-9,180.0d0,0) c c methionine residue (MET) c else if (resname .eq. 'MET') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' SD ',start,stop,i) call oldatm (i,k+4,n-1,ires) call findatm (' CE ',start,stop,i) call oldatm (i,k+5,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1) call findatm (' HG2',start,stop,i) call newatm (i,k+3,n-5,1.10d0,n-6,109.5d0,n-4,109.5d0,1) call findatm (' HG3',start,stop,i) call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,-1) call findatm (' HE1',start,stop,i) call newatm (i,k+6,n-5,1.10d0,n-6,110.2d0,n-7,180.0d0,0) call findatm (' HE2',start,stop,i) call newatm (i,k+6,n-6,1.10d0,n-7,110.2d0,n-8,60.0d0,0) call findatm (' HE3',start,stop,i) call newatm (i,k+6,n-7,1.10d0,n-8,110.2d0,n-9,-60.0d0,0) c c lysine residue (LYS) c else if (resname .eq. 'LYS') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD ',start,stop,i) call oldatm (i,k+4,n-1,ires) call findatm (' CE ',start,stop,i) call oldatm (i,k+6,n-1,ires) call findatm (' NZ ',start,stop,i) call oldatm (i,k+8,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1) call findatm (' HG2',start,stop,i) call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1) call findatm (' HG3',start,stop,i) call newatm (i,k+3,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1) call findatm (' HD2',start,stop,i) call newatm (i,k+5,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,1) call findatm (' HD3',start,stop,i) call newatm (i,k+5,n-8,1.10d0,n-9,109.5d0,n-7,109.5d0,-1) call findatm (' HE2',start,stop,i) call newatm (i,k+7,n-8,1.10d0,n-9,110.9d0,n-7,107.3d0,1) call findatm (' HE3',start,stop,i) call newatm (i,k+7,n-9,1.10d0,n-10,110.9d0,n-8,107.3d0,-1) call findatm (' HZ1',start,stop,i) call newatm (i,k+9,n-9,1.04d0,n-10,110.5d0,n-11,180.0d0,0) call findatm (' HZ2',start,stop,i) call newatm (i,k+9,n-10,1.04d0,n-11,110.5d0,n-12,60.0d0,0) call findatm (' HZ3',start,stop,i) call newatm (i,k+9,n-11,1.04d0,n-12,110.5d0,n-13,-60.0d0,0) c c deprotonated lysine residue (LYD) c else if (resname .eq. 'LYD') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD ',start,stop,i) call oldatm (i,k+4,n-1,ires) call findatm (' CE ',start,stop,i) call oldatm (i,k+6,n-1,ires) call findatm (' NZ ',start,stop,i) call oldatm (i,k+8,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-6,1.10d0,cai,107.9d0,n-5,110.0d0,-1) call findatm (' HG2',start,stop,i) call newatm (i,k+3,n-6,1.10d0,n-7,109.5d0,n-5,109.5d0,1) call findatm (' HG3',start,stop,i) call newatm (i,k+3,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,-1) call findatm (' HD2',start,stop,i) call newatm (i,k+5,n-7,1.10d0,n-8,109.5d0,n-6,109.5d0,1) call findatm (' HD3',start,stop,i) call newatm (i,k+5,n-8,1.10d0,n-9,109.5d0,n-7,109.5d0,-1) call findatm (' HE2',start,stop,i) call newatm (i,k+7,n-8,1.10d0,n-9,110.9d0,n-7,107.3d0,1) call findatm (' HE3',start,stop,i) call newatm (i,k+7,n-9,1.10d0,n-10,110.9d0,n-8,107.3d0,-1) call findatm (' HZ1',start,stop,i) call newatm (i,k+9,n-9,1.04d0,n-10,110.5d0,n-11,180.0d0,0) call findatm (' HZ2',start,stop,i) call newatm (i,k+9,n-10,1.04d0,n-11,110.5d0,n-12,60.0d0,0) c c arginine residue (ARG) c else if (resname .eq. 'ARG') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD ',start,stop,i) call oldatm (i,k+4,n-1,ires) call findatm (' NE ',start,stop,i) call oldatm (i,k+6,n-1,ires) call findatm (' CZ ',start,stop,i) call oldatm (i,k+8,n-1,ires) call findatm (' NH1',start,stop,i) call oldatm (i,k+9,n-1,ires) call findatm (' NH2',start,stop,i) call oldatm (i,k+9,n-2,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-7,1.10d0,cai,107.9d0,n-6,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-8,1.10d0,cai,107.9d0,n-7,110.0d0,-1) call findatm (' HG2',start,stop,i) call newatm (i,k+3,n-8,1.10d0,n-9,109.5d0,n-7,109.5d0,1) call findatm (' HG3',start,stop,i) call newatm (i,k+3,n-9,1.10d0,n-10,109.5d0,n-8,109.5d0,-1) call findatm (' HD2',start,stop,i) call newatm (i,k+5,n-9,1.10d0,n-10,109.5d0,n-8,109.5d0,1) call findatm (' HD3',start,stop,i) call newatm (i,k+5,n-10,1.10d0,n-11,109.5d0,n-9,109.5d0,-1) call findatm (' HE ',start,stop,i) call newatm (i,k+7,n-10,1.01d0,n-11,118.5d0,n-9,120.0d0,1) call findatm ('HH11',start,stop,i) call newatm (i,k+10,n-9,1.01d0,n-10,122.5d0,n-11,0.0d0,0) call findatm ('HH12',start,stop,i) call newatm (i,k+10,n-10,1.01d0,n-11,118.8d0,n-12,180.0d0,0) call findatm ('HH21',start,stop,i) call newatm (i,k+10,n-10,1.01d0,n-12,122.5d0,n-13,0.0d0,0) call findatm ('HH22',start,stop,i) call newatm (i,k+10,n-11,1.01d0,n-13,118.8d0,n-14,180.0d0,0) c c ornithine residue (ORN) c else if (resname .eq. 'ORN') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD ',start,stop,i) call oldatm (i,k+4,n-1,ires) call findatm (' NE ',start,stop,i) call oldatm (i,k+6,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,107.9d0,n-3,110.0d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,107.9d0,n-4,110.0d0,-1) call findatm (' HG2',start,stop,i) call newatm (i,k+3,n-5,1.10d0,n-7,109.5d0,n-4,109.5d0,1) call findatm (' HG3',start,stop,i) call newatm (i,k+3,n-6,1.10d0,n-8,109.5d0,n-5,109.5d0,-1) call findatm (' HD2',start,stop,i) call newatm (i,k+5,n-6,1.10d0,n-8,109.5d0,n-5,109.5d0,1) call findatm (' HD3',start,stop,i) call newatm (i,k+5,n-7,1.10d0,n-9,109.5d0,n-6,109.5d0,-1) call findatm (' HE1',start,stop,i) call newatm (i,k+7,n-7,1.04d0,n-8,110.5d0,n-9,180.0d0,0) call findatm (' HE2',start,stop,i) call newatm (i,k+7,n-8,1.04d0,n-9,110.5d0,n-10,60.0d0,0) call findatm (' HE3',start,stop,i) call newatm (i,k+7,n-9,1.04d0,n-10,110.5d0,n-11,-60.0d0,0) c c methylalanine residue (AIB) c else if (resname .eq. 'AIB') then call findatm (' CB1',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CB2',start,stop,i) call oldatm (i,k,cai,ires) call findatm ('HB11',start,stop,i) call newatm (i,k+1,n-2,1.10d0,cai,110.2d0,ni,180.0d0,0) call findatm ('HB12',start,stop,i) call newatm (i,k+1,n-3,1.10d0,cai,110.2d0,ni,60.0d0,0) call findatm ('HB13',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,110.2d0,ni,-60.0d0,0) call findatm ('HB21',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,110.2d0,ni,180.0d0,0) call findatm ('HB22',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,110.2d0,ni,60.0d0,0) call findatm ('HB23',start,stop,i) call newatm (i,k+1,n-6,1.10d0,cai,110.2d0,ni,-60.0d0,0) c c pyroglutamic acid residue (PCA) c else if (resname .eq. 'PCA') then call findatm (' CB ',start,stop,i) call oldatm (i,k,cai,ires) call findatm (' CG ',start,stop,i) call oldatm (i,k+2,n-1,ires) call findatm (' CD ',start,stop,i) call oldatm (i,k+4,n-1,ires) call addbond (n-1,ni) call findatm (' OE ',start,stop,i) call oldatm (i,k+5,n-1,ires) call findatm (' HB2',start,stop,i) call newatm (i,k+1,n-4,1.10d0,cai,111.2d0,n-3,111.2d0,1) call findatm (' HB3',start,stop,i) call newatm (i,k+1,n-5,1.10d0,cai,111.2d0,n-4,111.2d0,-1) call findatm (' HG2',start,stop,i) call newatm (i,k+3,n-5,1.10d0,n-6,111.2d0,n-4,111.2d0,1) call findatm (' HG3',start,stop,i) call newatm (i,k+3,n-6,1.10d0,n-7,111.2d0,n-5,111.2d0,-1) c c unknown residue (UNK) c else if (resname .eq. 'UNK') then k = hatyp(seqtyp(ires)) if (newchn) k = hantyp(seqtyp(ires)) if (endchn) k = hactyp(seqtyp(ires)) call newatm (i,k,cai,1.10d0,ni,109.5d0,ci,109.5d0,1) end if return end c c c ################################################################ c ## ## c ## subroutine ligase -- coordinates from PDB nucleic acid ## c ## ## c ################################################################ c c c "ligase" translates a nucleic acid structure in Protein Data c Bank format to a Cartesian coordinate file and sequence file c c subroutine ligase (ichn) use atoms use files use iounit use pdb use resdue use sequen implicit none integer i,j,k integer ichn,ityp integer jres,kres integer start,stop integer poi,o5i,c5i integer c4i,o4i,c1i integer c3i,c2i,o3i,o2i logical newchn,endchn logical, allocatable :: deoxy(:) character*3 resname c c c set the next atom and the residue range of the chain c n = n + 1 jres = ichain(1,ichn) kres = ichain(2,ichn) c c perform dynamic allocation of some local arrays c allocate (deoxy(nres)) c c check for deoxyribose and change residue name if necessary c do i = jres, kres deoxy(i) = .false. start = resatm(1,i) stop = resatm(2,i) resname = pdbres(start) call findatm (' O2''',start,stop,k) if (k .eq. 0) then deoxy(i) = .true. do j = start, stop if (resname .eq. ' A') pdbres(j) = ' DA' if (resname .eq. ' G') pdbres(j) = ' DG' if (resname .eq. ' C') pdbres(j) = ' DC' if (resname .eq. ' U') pdbres(j) = ' DU' if (resname .eq. ' T') pdbres(j) = ' DT' end do end if end do c c locate and assign the atoms that make up each residue c do i = jres, kres ityp = seqtyp(i) start = resatm(1,i) stop = resatm(2,i) resname = pdbres(start) c c check that the maximum allowed atoms is not exceeded c if (n+25 .gt. maxatm) then write (iout,10) maxatm 10 format (/,' LIGASE -- The Maximum of',i9,' Atoms', & ' has been Exceeded') call fatal end if c c test for initial or final residue of a nucleotide chain c newchn = .false. endchn = .false. do j = 1, nchain if (i .eq. ichain(1,j)) then newchn = .true. poi = 0 o3i = 0 end if if (i .eq. ichain(2,j)) endchn = .true. end do c c build the phosphate atoms of the current residue c if (resname .eq. ' TP') then else if (resname .eq. ' DP') then else if (resname .eq. ' MP') then else if (.not. newchn) then call findatm (' P ',start,stop,k) if (k .ne. 0) poi = n j = ptyp(ityp) call oldatm (k,j,o3i,i) call findatm (' OP1',start,stop,k) j = optyp(ityp) call oldatm (k,j,n-1,i) call findatm (' OP2',start,stop,k) j = optyp(ityp) call oldatm (k,j,n-2,i) end if c c build the ribose sugar atoms of the current residue c call findatm (' O5''',start,stop,k) if (k .ne. 0) o5i = n j = o5typ(ityp) if (newchn) then if (deoxy(i)) then j = 1244 else j = 1232 end if end if call oldatm (k,j,poi,i) call findatm (' C5''',start,stop,k) if (k .ne. 0) c5i = n j = c5typ(ityp) call oldatm (k,j,n-1,i) call findatm (' C4''',start,stop,k) if (k .ne. 0) c4i = n j = c4typ(ityp) call oldatm (k,j,n-1,i) call findatm (' O4''',start,stop,k) if (k .ne. 0) o4i = n j = o4typ(ityp) call oldatm (k,j,n-1,i) call findatm (' C1''',start,stop,k) if (k .ne. 0) c1i = n j = c1typ(ityp) call oldatm (k,j,n-1,i) call findatm (' C3''',start,stop,k) if (k .ne. 0) c3i = n j = c3typ(ityp) call oldatm (k,j,n-3,i) call findatm (' C2''',start,stop,k) if (k .ne. 0) c2i = n j = c2typ(ityp) call oldatm (k,j,n-1,i) call addbond (n-1,n-3) call findatm (' O3''',start,stop,k) if (k .ne. 0) o3i = n j = o3typ(ityp) if (endchn) then if (deoxy(i)) then j = 1249 else j = 1237 end if end if call oldatm (k,j,n-2,i) if (.not. deoxy(i)) then call findatm (' O2''',start,stop,k) if (k .ne. 0) o2i = n j = o2typ(ityp) call oldatm (k,j,n-2,i) end if c c build the hydrogen atoms of the current residue c if (newchn) then call findatm ('HO5''',start,stop,k) j = h5ttyp(ityp) call newatm (k,j,o5i,1.00d0,c5i,109.5d0,c4i,180.0d0,0) end if call findatm (' H5''',start,stop,k) j = h51typ(ityp) call newatm (k,j,c5i,1.09d0,o5i,109.5d0,c4i,109.5d0,1) call findatm ('H5''''',start,stop,k) j = h52typ(ityp) call newatm (k,j,c5i,1.09d0,o5i,109.5d0,c4i,109.5d0,-1) call findatm (' H4''',start,stop,k) j = h4typ(ityp) call newatm (k,j,c4i,1.09d0,c5i,109.5d0,c3i,109.5d0,-1) call findatm (' H3''',start,stop,k) j = h3typ(ityp) call newatm (k,j,c3i,1.09d0,c4i,109.5d0,c2i,109.5d0,-1) if (deoxy(i)) then call findatm (' H2''',start,stop,k) j = h21typ(ityp) call newatm (k,j,c2i,1.09d0,c3i,109.5d0,c1i,109.5d0,-1) call findatm ('H2''''',start,stop,k) j = h22typ(ityp) call newatm (k,j,c2i,1.09d0,c3i,109.5d0,c1i,109.5d0,1) else call findatm (' H2''',start,stop,k) j = h21typ(ityp) call newatm (k,j,c2i,1.09d0,c3i,109.5d0,c1i,109.5d0,-1) call findatm ('HO2''',start,stop,k) j = h22typ(ityp) call newatm (k,j,o2i,1.00d0,c2i,109.5d0,c3i,180.0d0,0) end if call findatm (' H1''',start,stop,k) j = h1typ(ityp) call newatm (k,j,c1i,1.09d0,o4i,109.5d0,c2i,109.5d0,-1) if (endchn) then call findatm ('HO3''',start,stop,k) j = h3ttyp(ityp) call newatm (k,j,o3i,1.00d0,c3i,109.5d0,c4i,180.0d0,0) end if c c build the standard base atoms of the current residue c call addbase (resname,i,start,stop,c1i) end do c c total number of atoms is one less than the current atom c n = n - 1 c c perform deallocation of some local arrays c deallocate (deoxy) return end c c c ################################################################ c ## ## c ## subroutine addbase -- build a single nucleic acid base ## c ## ## c ################################################################ c c c "addbase" builds the Cartesian coordinates for a single nucleic c acid base; coordinates are read from the Protein Data Bank file c or found from internal coordinates, then atom types are assigned c and connectivity data generated c c subroutine addbase (resname,ires,start,stop,c1i) use atoms implicit none integer i,ires integer start,stop integer c1i character*3 resname c c c adenine in adenosine residue (A) c if (resname .eq. ' A') then call findatm (' N9 ',start,stop,i) call oldatm (i,1017,c1i,ires) call findatm (' C8 ',start,stop,i) call oldatm (i,1021,n-1,ires) call findatm (' N7 ',start,stop,i) call oldatm (i,1020,n-1,ires) call findatm (' C5 ',start,stop,i) call oldatm (i,1019,n-1,ires) call findatm (' C6 ',start,stop,i) call oldatm (i,1025,n-1,ires) call findatm (' N6 ',start,stop,i) call oldatm (i,1027,n-1,ires) call findatm (' N1 ',start,stop,i) call oldatm (i,1024,n-2,ires) call findatm (' C2 ',start,stop,i) call oldatm (i,1023,n-1,ires) call findatm (' N3 ',start,stop,i) call oldatm (i,1022,n-1,ires) call findatm (' C4 ',start,stop,i) call oldatm (i,1018,n-1,ires) call addbond (n-1,n-7) call addbond (n-1,n-10) call findatm (' H8 ',start,stop,i) call newatm (i,1030,n-9,1.08d0,n-8,123.1d0,n-7,180.0d0,0) call findatm (' H61',start,stop,i) call newatm (i,1028,n-6,1.00d0,n-7,120.0d0,n-8,180.0d0,0) call findatm (' H62',start,stop,i) call newatm (i,1029,n-7,1.00d0,n-8,120.0d0,n-9,0.0d0,0) call findatm (' H2 ',start,stop,i) call newatm (i,1026,n-6,1.08d0,n-5,115.4d0,n-4,180.0d0,0) c c guanine in guanosine residue (G) c else if (resname .eq. ' G') then call findatm (' N9 ',start,stop,i) call oldatm (i,1047,c1i,ires) call findatm (' C8 ',start,stop,i) call oldatm (i,1051,n-1,ires) call findatm (' N7 ',start,stop,i) call oldatm (i,1050,n-1,ires) call findatm (' C5 ',start,stop,i) call oldatm (i,1049,n-1,ires) call findatm (' C6 ',start,stop,i) call oldatm (i,1055,n-1,ires) call findatm (' O6 ',start,stop,i) call oldatm (i,1060,n-1,ires) call findatm (' N1 ',start,stop,i) call oldatm (i,1054,n-2,ires) call findatm (' C2 ',start,stop,i) call oldatm (i,1053,n-1,ires) call findatm (' N2 ',start,stop,i) call oldatm (i,1057,n-1,ires) call findatm (' N3 ',start,stop,i) call oldatm (i,1052,n-2,ires) call findatm (' C4 ',start,stop,i) call oldatm (i,1048,n-1,ires) call addbond (n-1,n-8) call addbond (n-1,n-11) call findatm (' H8 ',start,stop,i) call newatm (i,1061,n-10,1.08d0,n-9,123.0d0,n-8,180.0d0,0) call findatm (' H1 ',start,stop,i) call newatm (i,1056,n-6,1.00d0,n-8,117.4d0,n-9,180.0d0,0) call findatm (' H21',start,stop,i) call newatm (i,1058,n-5,1.00d0,n-6,120.0d0,n-7,0.0d0,0) call findatm (' H22',start,stop,i) call newatm (i,1059,n-6,1.00d0,n-7,120.0d0,n-8,180.0d0,0) c c cytosine in cytidine residue (C) c else if (resname .eq. ' C') then call findatm (' N1 ',start,stop,i) call oldatm (i,1078,c1i,ires) call findatm (' C2 ',start,stop,i) call oldatm (i,1079,n-1,ires) call findatm (' O2 ',start,stop,i) call oldatm (i,1084,n-1,ires) call findatm (' N3 ',start,stop,i) call oldatm (i,1080,n-2,ires) call findatm (' C4 ',start,stop,i) call oldatm (i,1081,n-1,ires) call findatm (' N4 ',start,stop,i) call oldatm (i,1085,n-1,ires) call findatm (' C5 ',start,stop,i) call oldatm (i,1082,n-2,ires) call findatm (' C6 ',start,stop,i) call oldatm (i,1083,n-1,ires) call addbond (n-1,n-8) call findatm (' H41',start,stop,i) call newatm (i,1086,n-3,1.00d0,n-4,120.0d0,n-5,0.0d0,0) call findatm (' H42',start,stop,i) call newatm (i,1087,n-4,1.00d0,n-5,120.0d0,n-6,180.0d0,0) call findatm (' H5 ',start,stop,i) call newatm (i,1088,n-4,1.08d0,n-6,121.6d0,n-7,180.0d0,0) call findatm (' H6 ',start,stop,i) call newatm (i,1089,n-4,1.08d0,n-5,119.4d0,n-7,180.0d0,0) c c uracil in uridine residue (U) c else if (resname .eq. ' U') then call findatm (' N1 ',start,stop,i) call oldatm (i,1106,c1i,ires) call findatm (' C2 ',start,stop,i) call oldatm (i,1107,n-1,ires) call findatm (' O2 ',start,stop,i) call oldatm (i,1112,n-1,ires) call findatm (' N3 ',start,stop,i) call oldatm (i,1108,n-2,ires) call findatm (' C4 ',start,stop,i) call oldatm (i,1109,n-1,ires) call findatm (' O4 ',start,stop,i) call oldatm (i,1114,n-1,ires) call findatm (' C5 ',start,stop,i) call oldatm (i,1110,n-2,ires) call findatm (' C6 ',start,stop,i) call oldatm (i,1111,n-1,ires) call addbond (n-1,n-8) call findatm (' H3 ',start,stop,i) call newatm (i,1113,n-5,1.00d0,n-7,116.5d0,n-8,180.0d0,0) call findatm (' H5 ',start,stop,i) call newatm (i,1115,n-3,1.08d0,n-5,120.4d0,n-6,180.0d0,0) call findatm (' H6 ',start,stop,i) call newatm (i,1116,n-3,1.08d0,n-4,118.6d0,n-6,180.0d0,0) c c adenine in deoxyadenosine residue (DA) c else if (resname .eq. ' DA') then call findatm (' N9 ',start,stop,i) call oldatm (i,1132,c1i,ires) call findatm (' C8 ',start,stop,i) call oldatm (i,1136,n-1,ires) call findatm (' N7 ',start,stop,i) call oldatm (i,1135,n-1,ires) call findatm (' C5 ',start,stop,i) call oldatm (i,1134,n-1,ires) call findatm (' C6 ',start,stop,i) call oldatm (i,1140,n-1,ires) call findatm (' N6 ',start,stop,i) call oldatm (i,1142,n-1,ires) call findatm (' N1 ',start,stop,i) call oldatm (i,1139,n-2,ires) call findatm (' C2 ',start,stop,i) call oldatm (i,1138,n-1,ires) call findatm (' N3 ',start,stop,i) call oldatm (i,1137,n-1,ires) call findatm (' C4 ',start,stop,i) call oldatm (i,1133,n-1,ires) call addbond (n-1,n-7) call addbond (n-1,n-10) call findatm (' H8 ',start,stop,i) call newatm (i,1145,n-9,1.08d0,n-8,123.1d0,n-7,180.0d0,0) call findatm (' H61',start,stop,i) call newatm (i,1143,n-6,1.00d0,n-7,120.0d0,n-8,180.0d0,0) call findatm (' H62',start,stop,i) call newatm (i,1144,n-7,1.00d0,n-8,120.0d0,n-9,0.0d0,0) call findatm (' H2 ',start,stop,i) call newatm (i,1141,n-6,1.08d0,n-5,115.4d0,n-4,180.0d0,0) c c guanine in deoxyguanosine residue (DG) c else if (resname .eq. ' DG') then call findatm (' N9 ',start,stop,i) call oldatm (i,1161,c1i,ires) call findatm (' C8 ',start,stop,i) call oldatm (i,1165,n-1,ires) call findatm (' N7 ',start,stop,i) call oldatm (i,1164,n-1,ires) call findatm (' C5 ',start,stop,i) call oldatm (i,1163,n-1,ires) call findatm (' C6 ',start,stop,i) call oldatm (i,1169,n-1,ires) call findatm (' O6 ',start,stop,i) call oldatm (i,1174,n-1,ires) call findatm (' N1 ',start,stop,i) call oldatm (i,1168,n-2,ires) call findatm (' C2 ',start,stop,i) call oldatm (i,1167,n-1,ires) call findatm (' N2 ',start,stop,i) call oldatm (i,1171,n-1,ires) call findatm (' N3 ',start,stop,i) call oldatm (i,1166,n-2,ires) call findatm (' C4 ',start,stop,i) call oldatm (i,1162,n-1,ires) call addbond (n-1,n-8) call addbond (n-1,n-11) call findatm (' H8 ',start,stop,i) call newatm (i,1175,n-10,1.08d0,n-9,123.0d0,n-8,180.0d0,0) call findatm (' H1 ',start,stop,i) call newatm (i,1170,n-6,1.00d0,n-8,117.4d0,n-9,180.0d0,0) call findatm (' H21',start,stop,i) call newatm (i,1172,n-5,1.00d0,n-6,120.0d0,n-7,0.0d0,0) call findatm (' H22',start,stop,i) call newatm (i,1173,n-6,1.00d0,n-7,120.0d0,n-8,180.0d0,0) c c cytosine in deoxycytidine residue (DC) c else if (resname .eq. ' DC') then call findatm (' N1 ',start,stop,i) call oldatm (i,1191,c1i,ires) call findatm (' C2 ',start,stop,i) call oldatm (i,1192,n-1,ires) call findatm (' O2 ',start,stop,i) call oldatm (i,1197,n-1,ires) call findatm (' N3 ',start,stop,i) call oldatm (i,1193,n-2,ires) call findatm (' C4 ',start,stop,i) call oldatm (i,1194,n-1,ires) call findatm (' N4 ',start,stop,i) call oldatm (i,1198,n-1,ires) call findatm (' C5 ',start,stop,i) call oldatm (i,1195,n-2,ires) call findatm (' C6 ',start,stop,i) call oldatm (i,1196,n-1,ires) call addbond (n-1,n-8) call findatm (' H41',start,stop,i) call newatm (i,1199,n-3,1.00d0,n-4,120.0d0,n-5,0.0d0,0) call findatm (' H42',start,stop,i) call newatm (i,1200,n-4,1.00d0,n-5,120.0d0,n-6,180.0d0,0) call findatm (' H5 ',start,stop,i) call newatm (i,1201,n-4,1.08d0,n-6,121.6d0,n-7,180.0d0,0) call findatm (' H6 ',start,stop,i) call newatm (i,1202,n-4,1.08d0,n-5,119.4d0,n-7,180.0d0,0) c c thymine in deoxythymidine residue (DT) c else if (resname .eq. ' DT') then call findatm (' N1 ',start,stop,i) call oldatm (i,1218,c1i,ires) call findatm (' C2 ',start,stop,i) call oldatm (i,1219,n-1,ires) call findatm (' O2 ',start,stop,i) call oldatm (i,1224,n-1,ires) call findatm (' N3 ',start,stop,i) call oldatm (i,1220,n-2,ires) call findatm (' C4 ',start,stop,i) call oldatm (i,1221,n-1,ires) call findatm (' O4 ',start,stop,i) call oldatm (i,1226,n-1,ires) call findatm (' C5 ',start,stop,i) call oldatm (i,1222,n-2,ires) call findatm (' C7 ',start,stop,i) call oldatm (i,1227,n-1,ires) call findatm (' C6 ',start,stop,i) call oldatm (i,1223,n-2,ires) call addbond (n-1,n-9) call findatm (' H3 ',start,stop,i) call newatm (i,1225,n-6,1.00d0,n-8,116.8d0,n-9,180.0d0,0) call findatm (' H71',start,stop,i) call newatm (i,1228,n-3,1.09d0,n-4,109.5d0,n-6,0.0d0,0) call findatm (' H72',start,stop,i) call newatm (i,1228,n-4,1.09d0,n-5,109.5d0,n-1,109.5d0,1) call findatm (' H73',start,stop,i) call newatm (i,1228,n-5,1.09d0,n-6,109.5d0,n-2,109.5d0,-1) call findatm (' H6 ',start,stop,i) call newatm (i,1229,n-5,1.08d0,n-7,119.4d0,n-9,180.0d0,0) end if return end c c c ################################################################# c ## ## c ## subroutine hetatom -- coordinates of PDB water and ions ## c ## ## c ################################################################# c c c "hetatom" translates water molecules and ions in Protein Data c Bank format to a Cartesian coordinate file and sequence file c c subroutine hetatom use atoms use pdb implicit none integer i c c c find water molecules and ions in PDB HETATM records c n = n + 1 i = 0 do while (i .lt. npdb) i = i + 1 if (pdbtyp(i) .eq. 'HETATM') then if (pdbres(i) .eq. 'HOH') then if (pdbatm(i) .eq. ' O ') then call oldatm (i,2001,0,0) if (pdbatm(i+1).eq.' H ' .and. & pdbatm(i+2).eq.' H ') then call oldatm (i+1,2002,n-1,0) call oldatm (i+2,2002,n-2,0) i = i + 2 else call newatm (0,2002,n-1,0.96d0,n-2,109.5d0, & n-3,120.0d0,0) call newatm (0,2002,n-2,0.96d0,n-1,109.5d0, & n-3,120.0d0,0) end if end if else if (pdbres(i) .eq. ' LI') then call oldatm (i,2003,0,0) else if (pdbres(i) .eq. ' NA') then call oldatm (i,2004,0,0) else if (pdbres(i) .eq. ' K') then call oldatm (i,2005,0,0) else if (pdbres(i) .eq. ' RB') then call oldatm (i,2006,0,0) else if (pdbres(i) .eq. ' CS') then call oldatm (i,2007,0,0) else if (pdbres(i) .eq. ' MG') then call oldatm (i,2008,0,0) else if (pdbres(i) .eq. ' CA') then call oldatm (i,2009,0,0) else if (pdbres(i) .eq. ' SR') then call oldatm (i,2010,0,0) else if (pdbres(i) .eq. ' BA') then call oldatm (i,2011,0,0) else if (pdbres(i) .eq. ' F') then call oldatm (i,2012,0,0) else if (pdbres(i) .eq. ' CL') then call oldatm (i,2013,0,0) else if (pdbres(i) .eq. ' BR') then call oldatm (i,2014,0,0) else if (pdbres(i) .eq. ' I') then call oldatm (i,2015,0,0) else if (pdbres(i) .eq. ' ZN') then call oldatm (i,2016,0,0) end if end if end do n = n - 1 return end c c c ############################################################ c ## ## c ## subroutine oldatm -- transfer coordinates from PDB ## c ## ## c ############################################################ c c c "oldatm" get the Cartesian coordinates for an atom from c the Protein Data Bank file, then assigns the atom type c and atomic connectivities c c subroutine oldatm (i,bionum,i1,ires) use atomid use atoms use fields use iounit use katoms use sequen use pdb implicit none integer i,bionum integer i1,ires c c c get coordinates, assign atom type, and update connectivities c if (bionum .ne. 0) then if (i .ne. 0) then type(n) = biotyp(bionum) if (type(n) .gt. 0) then name(n) = symbol(type(n)) else type(n) = 0 name(n) = ' ' end if x(n) = xpdb(i) y(n) = ypdb(i) z(n) = zpdb(i) if (i1 .ne. 0) call addbond (n,i1) n = n + 1 else write (iout,10) bionum,ires,seq(ires) 10 format (/,' OLDATM -- A PDB Atom of Biotype',i5, & ' is Missing in Residue',i5,'-',a3) call fatal end if end if return end c c c ########################################################### c ## ## c ## subroutine newatm -- create and define a new atom ## c ## ## c ########################################################### c c c "newatm" creates and defines an atom needed for the c Cartesian coordinates file, but which may not present c in the original Protein Data Bank file c c subroutine newatm (i,bionum,ia,bond,ib,angle1,ic,angle2,chiral) use atomid use atoms use fields use katoms use pdb implicit none integer i,bionum integer ia,ib,ic integer chiral real*8 bond real*8 angle1 real*8 angle2 c c c set the atom type, compute coordinates, assign c connectivities and increment the atom counter c if (bionum .ne. 0) then type(n) = biotyp(bionum) if (type(n) .gt. 0) then name(n) = symbol(type(n)) else type(n) = 0 name(n) = ' ' end if if (i .eq. 0) then call xyzatm (n,ia,bond,ib,angle1,ic,angle2,chiral) else x(n) = xpdb(i) y(n) = ypdb(i) z(n) = zpdb(i) end if call addbond (n,ia) n = n + 1 end if return end c c c ############################################################ c ## ## c ## subroutine addbond -- add a bond between two atoms ## c ## ## c ############################################################ c c c "addbond" adds entries to the attached atoms list in c order to generate a direct connection between two atoms c c subroutine addbond (i,j) use couple implicit none integer i,j c c c add connectivity between the two atoms c if (i.ne.0 .and. j.ne.0) then n12(i) = n12(i) + 1 i12(n12(i),i) = j n12(j) = n12(j) + 1 i12(n12(j),j) = i end if return end c c c ############################################################ c ## ## c ## subroutine findatm -- locate PDB atom in a residue ## c ## ## c ############################################################ c c c "findatm" locates a specific PDB atom name type within a c range of atoms from the PDB file, returns zero if the name c type was not found c c subroutine findatm (name,start,stop,ipdb) use pdb implicit none integer i,ipdb integer start,stop character*4 name c c c search for the specified atom within the residue c ipdb = 0 do i = start, stop if (pdbatm(i) .eq. name) then ipdb = i goto 10 end if end do 10 continue return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module phipsi -- phi-psi-omega-chi angles for protein ## c ## ## c ############################################################### c c c chiral chirality of each amino acid residue (1=L, -1=D) c disulf residue joined to each residue via a disulfide link c phi value of the phi angle for each amino acid residue c psi value of the psi angle for each amino acid residue c omg value of the omega angle for each amino acid residue c chi values of the chi angles for each amino acid residue c c module phipsi use sizes implicit none integer chiral(maxres) integer disulf(maxres) real*8 phi(maxres) real*8 psi(maxres) real*8 omg(maxres) real*8 chi(4,maxres) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine picalc -- Pariser-Parr-Pople MO calculation ## c ## ## c ################################################################ c c c "picalc" performs a modified Pariser-Parr-Pople molecular c orbital calculation for each conjugated pisystem c c subroutine picalc use bndstr use couple use inform use iounit use piorbs use tors implicit none integer i,j,k,m,ib,ic integer ii,jj,kk integer iorb,jorb integer ncalls data ncalls / 0 / save ncalls c c c only needs to be done if pisystem is present c if (norbit .eq. 0) return c c increment the number of calls to this routine c ncalls = ncalls + 1 if (reorbit.eq.0 .or. ncalls.lt.reorbit) return ncalls = 0 c c loop over all pisystems computing separate MOs for each c do i = 1, nconj norbit = 0 do j = iconj(1,i), iconj(2,i) norbit = norbit + 1 iorbit(norbit) = kconj(j) end do c c find and store the pisystem bonds for this pisystem c nbpi = 0 kk = iconj(2,i) - iconj(1,i) + 1 do ii = 1, norbit-1 iorb = iorbit(ii) do jj = ii+1, norbit jorb = iorbit(jj) do k = 1, n12(iorb) if (i12(k,iorb) .eq. jorb) then nbpi = nbpi + 1 do m = 1, nbond if (iorb.eq.ibnd(1,m) .and. & jorb.eq.ibnd(2,m)) then ibpi(1,nbpi) = m ibpi(2,nbpi) = ii ibpi(3,nbpi) = jj goto 10 end if end do 10 continue end if end do end do end do c c find and store the pisystem torsions for this pisystem c ntpi = 0 do ii = 1, ntors ib = itors(2,ii) ic = itors(3,ii) if (listpi(ib) .and. listpi(ic)) then do jj = 1, nbpi k = ibpi(1,jj) if (ib.eq.ibnd(1,k).and.ic.eq.ibnd(2,k) .or. & ib.eq.ibnd(2,k).and.ic.eq.ibnd(1,k)) then ntpi = ntpi + 1 itpi(1,ntpi) = ii itpi(2,ntpi) = jj goto 20 end if end do 20 continue end if end do c c print a header for the molecular orbital calculation c if (debug) then if (nconj .eq. 1) then write (iout,30) 30 format (/,' Modified Pariser-Parr-Pople Molecular', & ' Orbitals :') else write (iout,40) i 40 format (/,' Modified Pariser-Parr-Pople MOs for', & ' Pi-System',i4,' :') end if end if c c get SCF-MOs, then scale bond and torsional parameters c call piscf call pialter end do return end c c c ############################################################### c ## ## c ## subroutine piscf -- SCF molecular orbital calculation ## c ## ## c ############################################################### c c c "piscf" performs an SCF molecular orbital calculation for a c pisystem to determine bond orders used in parameter scaling c c subroutine piscf use atomid use atoms use bndstr use couple use inform use iounit use orbits use piorbs use pistuf use units implicit none integer i,j,k,m integer iter,maxiter integer iatn,jatn integer iorb,jorb,nfill real*8 delta,converge real*8 xij,yij,zij,p real*8 hcii,gii,gij real*8 g11,g11sq,g12,g14 real*8 rij,erij,brij real*8 ovlap,covlap real*8 cionize real*8 iionize,jionize real*8 rijsq,hcij,qi real*8 total,totold real*8 ebeta,aeth,abnz real*8 ebe,ebb,ble,blb real*8 eebond,bebond real*8 s1,s2,gjk real*8 vij,vik,vmj,vmk real*8 xi,xj,xk,xg real*8, allocatable :: povlap(:) real*8, allocatable :: en(:) real*8, allocatable :: ip(:) real*8, allocatable :: fock(:,:) real*8, allocatable :: hc(:,:) real*8, allocatable :: v(:,:) real*8, allocatable :: gamma(:,:) real*8, allocatable :: ed(:,:) character*6 mode c c c initialize some constants and parameters c c mode planar or nonplanar pi-calculation c maxiter maximum number of SCF iterations c converge criterion for SCF convergence c ebeta value of resonance integral for ethylene c cionize ionization potential of carbon (Hartree) c mode = 'PLANAR' maxiter = 50 converge = 0.00000001d0 ebeta = -0.0757d0 cionize = -11.16d0 / evolt c c set the bond energies, alpha values and ideal bond length c parameter for carbon-carbon pibond type parameters c c ebe equilibrium bond energy in ethylene c ebb equilibrium bond energy in benzene c aeth the P-P-P constant "a" in ethylene c abnz the P-P-P constant "a" in benzene c ble equilibrium bond length in ethylene c blb equilibrium bond length in benzene c ebe = 129.37d0 ebb = 117.58d0 aeth = 2.309d0 abnz = 2.142d0 ble = 1.338d0 blb = 1.397d0 c c perform dynamic allocation of some local arrays c allocate (povlap(nbpi)) allocate (en(norbit)) allocate (ip(norbit)) allocate (fock(norbit,norbit)) allocate (hc(norbit,norbit)) allocate (v(norbit,norbit)) allocate (gamma(norbit,norbit)) allocate (ed(norbit,norbit)) c c assign empirical one-center Coulomb integrals, and c first or second ionization potential depending on c whether the orbital contributes one or two electrons c nfill = 0 do i = 1, norbit iorb = iorbit(i) gamma(i,i) = emorb(iorb) ip(i) = worb(iorb) + (1.0d0-qorb(iorb))*emorb(iorb) nfill = nfill + nint(qorb(iorb)) end do nfill = nfill / 2 c c calculate two-center repulsion integrals c according to Ohno's semi-empirical formula c do i = 1, norbit-1 iorb = iorbit(i) gii = gamma(i,i) do j = i+1, norbit jorb = iorbit(j) g11 = 0.5d0 * (gii+gamma(j,j)) g11sq = 1.0d0 / g11**2 xij = x(iorb) - x(jorb) yij = y(iorb) - y(jorb) zij = z(iorb) - z(jorb) rijsq = (xij**2 + yij**2 + zij**2) / bohr**2 g12 = 1.0d0 / sqrt(rijsq+g11sq) gamma(i,j) = g12 gamma(j,i) = g12 end do end do c c zero out the resonance integral values c do i = 1, norbit do j = 1, norbit hc(j,i) = 0.0d0 end do end do c c the first term in the sum to find alpha is the first c or second ionization potential, then the two-center c repulsion integrals are added c do i = 1, norbit hcii = ip(i) do j = 1, norbit if (i .ne. j) then jorb = iorbit(j) hcii = hcii - qorb(jorb)*gamma(i,j) end if end do hc(i,i) = hcii end do c c get two-center repulsion integrals via Ohno's formula c do k = 1, nbpi i = ibpi(2,k) j = ibpi(3,k) iorb = iorbit(i) jorb = iorbit(j) iatn = atomic(iorb) jatn = atomic(jorb) xij = x(iorb) - x(jorb) yij = y(iorb) - y(jorb) zij = z(iorb) - z(jorb) rij = sqrt(xij**2 + yij**2 + zij**2) rijsq = rij**2 / bohr**2 g11 = 0.5d0 * (gamma(i,i)+gamma(j,j)) g11sq = 1.0d0 / g11**2 g12 = gamma(i,j) c c compute the bond energy using a Morse potential c erij = aeth * (ble-rij) brij = abnz * (blb-rij) eebond = (2.0d0*exp(erij)-exp(2.0d0*erij)) * ebe / hartree bebond = (2.0d0*exp(brij)-exp(2.0d0*brij)) * ebb / hartree c c compute the carbon-carbon resonance integral using c the Whitehead and Lo formula c g14 = 1.0d0 / sqrt(4.0d0*rijsq+g11sq) hcij = 1.5d0*(bebond-eebond) - 0.375d0*g11 & + (5.0d0/12.0d0)*g12 - g14/24.0d0 c c if either atom is non-carbon, then factor the resonance c integral by overlap ratio and ionization potential ratio c if (iatn.ne.6 .or. jatn.ne.6) then call overlap (iatn,jatn,rij,ovlap) call overlap (6,6,rij,covlap) hcij = hcij * (ovlap/covlap) iionize = ip(i) if (qorb(iorb) .ne. 1.0d0) then if (iatn .eq. 7) iionize = 0.595d0 * iionize if (iatn .eq. 8) iionize = 0.525d0 * iionize if (iatn .eq. 16) iionize = 0.89d0 * iionize end if jionize = ip(j) if (qorb(jorb) .ne. 1.0d0) then if (jatn .eq. 7) jionize = 0.595d0 * jionize if (jatn .eq. 8) jionize = 0.525d0 * jionize if (jatn .eq. 16) jionize = 0.89d0 * jionize end if hcij = hcij * (iionize+jionize)/(2.0d0*cionize) end if c c set symmetric elements to the same value c hc(i,j) = hcij hc(j,i) = hcij end do c c construct an initial guess to the Fock matrix c do i = 1, norbit do j = 1, norbit fock(j,i) = hc(j,i) end do end do do i = 1, norbit fock(i,i) = 0.5d0 * ip(i) end do c c make the SCF-MO computation; do it twice, for a planar analog c of the actual system and for the actual (nonplanar) system c do while (mode.eq.'PLANAR' .or. mode.eq.'NONPLN') if (mode .eq. 'NONPLN') then call pitilt (povlap) do k = 1, nbpi i = ibpi(2,k) j = ibpi(3,k) hc(i,j) = hc(i,j) * povlap(k) hc(j,i) = hc(i,j) end do end if c c perform SCF iterations until convergence is reached; diagonalize c the Fock matrix "f" to get the MOs, then use MOs to form the c next "f" matrix assuming zero differential overlap except for c one-center exchange repulsions c iter = 0 delta = 2.0d0 * converge do while (delta.gt.converge .and. iter.lt.maxiter) iter = iter + 1 call jacobi (norbit,fock,en,v) do i = 1, norbit do j = i, norbit s1 = 0.0d0 s2 = 0.0d0 gij = gamma(i,j) do k = 1, nfill s2 = s2 - v(i,k)*v(j,k)*gij if (i .eq. j) then do m = 1, norbit s1 = s1 + 2.0d0*gamma(i,m)*v(m,k)**2 end do end if end do fock(i,j) = s1 + s2 + hc(i,j) fock(j,i) = fock(i,j) end do end do c c calculate the ground state energy, where "xi" sums the c molecular core integrals, "xj" sums the molecular coulomb c repulsion integrals, "xk" sums the molecular exchange c repulsion integrals, and "xg" sums the nuclear repulsion c xi = 0.0d0 xj = 0.0d0 xk = 0.0d0 xg = 0.0d0 do i = 1, nfill do j = 1, norbit vij = v(j,i) do k = 1, norbit vik = v(k,i) gjk = gamma(j,k) xi = xi + 2.0d0*vij*vik*hc(j,k) do m = 1, nfill vmj = v(j,m) vmk = v(k,m) xj = xj + 2.0d0*vij*vij*vmk*vmk*gjk xk = xk - vij*vmj*vik*vmk*gjk end do end do end do end do do i = 1, norbit-1 iorb = iorbit(i) qi = qorb(iorb) do j = i+1, norbit jorb = iorbit(j) xg = xg + qi*qorb(jorb)*gamma(i,j) end do end do total = xi + xj + xk + xg if (iter .ne. 1) delta = abs(total-totold) totold = total end do c c print warning if SCF-MO iteration did not converge c if (delta .gt. converge) then write (iout,10) 10 format (' PISCF -- The SCF Molecular Orbitals have', & ' Failed to Converge') end if c c calculate electron densities from filled MO's c do i = 1, norbit do j = 1, norbit ed(i,j) = 0.0d0 do k = 1, nfill ed(i,j) = ed(i,j) + 2.0d0*v(i,k)*v(j,k) end do end do end do c c print out results for the SCF computation c if (debug) then if (mode .eq. 'PLANAR') then write (iout,20) 20 format (/,' SCF-MO Calculation for Planar System :') else write (iout,30) 30 format (/,' SCF-MO Calculation for Non-Planar', & ' System :') end if write (iout,40) total,norbit,delta,iter 40 format (/,' Total Energy',11x,f12.4, & /,' Number of Orbitals',5x,i12, & /,' Convergence',12x,d12.4, & /,' Iterations',13x,i12) write (iout,50) xi,xj,xk,xg 50 format (/,' Core Integrals',9x,f12.4, & /,' Coulomb Repulsion',6x,f12.4, & /,' Exchange Repulsion',5x,f12.4, & /,' Nuclear Repulsion',6x,f12.4) write (iout,60) 60 format (/,' Orbital Energies') write (iout,70) (en(i),i=1,norbit) 70 format (8f9.4) write (iout,80) 80 format (/,' Molecular Orbitals') do i = 1, norbit write (iout,90) (v(i,j),j=1,norbit) 90 format (8f9.4) end do write (iout,100) 100 format (/,' Fock Matrix') do i = 1, norbit write (iout,110) (fock(i,j),j=1,norbit) 110 format (8f9.4) end do write (iout,120) 120 format (/,' Density Matrix') do i = 1, norbit write (iout,130) (ed(i,j),j=1,norbit) 130 format (8f9.4) end do write (iout,140) 140 format (/,' H-Core Matrix') do i = 1, norbit write (iout,150) (hc(i,j),j=1,norbit) 150 format (8f9.4) end do write (iout,160) 160 format (/,' Gamma Matrix') do i = 1, norbit write (iout,170) (gamma(i,j),j=1,norbit) 170 format (8f9.4) end do end if c c now, get the bond orders (compute p and p*b) c if (debug) then write (iout,180) 180 format (/,' Pisystem Bond Orders') end if do k = 1, nbpi i = ibpi(2,k) j = ibpi(3,k) p = 0.0d0 do m = 1, nfill p = p + 2.0d0*v(i,m)*v(j,m) end do if (mode .eq. 'PLANAR') then pbpl(k) = p * hc(i,j)/ebeta else if (mode .eq. 'NONPLN') then pnpl(k) = p end if if (debug) then i = ibnd(1,ibpi(1,k)) j = ibnd(2,ibpi(1,k)) write (iout,190) i,j,p 190 format (3x,2i6,2x,f10.4) end if end do c c if we have done planar calculation, do the nonplanar; c when both are complete, alter the pisystem constants c if (mode .eq. 'PLANAR') then mode = 'NONPLN' else if (mode .eq. 'NONPLN') then mode = ' ' end if end do c c perform deallocation of some local arrays c deallocate (povlap) deallocate (en) deallocate (ip) deallocate (fock) deallocate (hc) deallocate (v) deallocate (gamma) deallocate (ed) return end c c c ############################################################# c ## ## c ## subroutine pitilt -- direction cosines for pisystem ## c ## ## c ############################################################# c c c "pitilt" calculates for each pibond the ratio of the c actual p-orbital overlap integral to the ideal overlap c if the same orbitals were perfectly parallel c c subroutine pitilt (povlap) use atomid use atoms use couple use piorbs implicit none integer i,j,k,m integer iorb,jorb integer list(8) real*8 ideal,cosine,rnorm real*8 xij,yij,zij,rij real*8 a1,b1,c1,a2,b2,c2 real*8 x2,y2,z2,x3,y3,z3 real*8 xr(8),yr(8),zr(8) real*8 povlap(*) c c c planes defining each p-orbital are in "piperp"; transform c coordinates of "iorb", "jorb" and their associated planes c to put "iorb" at origin and "jorb" along the x-axis c do k = 1, nbpi i = ibpi(2,k) j = ibpi(3,k) iorb = iorbit(i) jorb = iorbit(j) list(1) = iorb list(2) = jorb do m = 1, 3 list(m+2) = piperp(m,iorb) list(m+5) = piperp(m,jorb) end do call pimove (list,xr,yr,zr) c c check for sp-hybridized carbon in current bond; c assume perfect overlap for any such pibond c if ((atomic(iorb).eq.6 .and. n12(iorb).eq.2) .or. & (atomic(jorb).eq.6 .and. n12(jorb).eq.2)) then povlap(k) = 1.0d0 c c find and normalize a vector parallel to first p-orbital c else x2 = xr(4) - xr(3) y2 = yr(4) - yr(3) z2 = zr(4) - zr(3) x3 = xr(5) - xr(3) y3 = yr(5) - yr(3) z3 = zr(5) - zr(3) a1 = y2*z3 - y3*z2 b1 = x3*z2 - x2*z3 c1 = x2*y3 - x3*y2 rnorm = sqrt(a1*a1+b1*b1+c1*c1) a1 = a1 / rnorm b1 = b1 / rnorm c1 = c1 / rnorm c c now find vector parallel to the second p-orbital, c "a2" changes sign to correspond to internuclear axis c x2 = xr(7) - xr(6) y2 = yr(7) - yr(6) z2 = zr(7) - zr(6) x3 = xr(8) - xr(6) y3 = yr(8) - yr(6) z3 = zr(8) - zr(6) a2 = y2*z3 - y3*z2 b2 = x3*z2 - x2*z3 c2 = x2*y3 - x3*y2 rnorm = sqrt(a2*a2+b2*b2+c2*c2) a2 = -a2 / rnorm b2 = b2 / rnorm c2 = c2 / rnorm c c compute the cosine of the angle between p-orbitals; c if more than 90 degrees, reverse one of the vectors c cosine = a1*a2 + b1*b2 + c1*c2 if (cosine .lt. 0.0d0) then a2 = -a2 b2 = -b2 c2 = -c2 end if c c find overlap if the orbitals were perfectly parallel c xij = x(iorb) - x(jorb) yij = y(iorb) - y(jorb) zij = z(iorb) - z(jorb) rij = sqrt(xij**2 + yij**2 + zij**2) call overlap (atomic(iorb),atomic(jorb),rij,ideal) c c set ratio of actual to ideal overlap for current pibond c povlap(k) = ideal*a1*a2 + b1*b2 + c1*c2 end if end do return end c c c ############################################################## c ## ## c ## subroutine pimove -- transform pisystem bond vectors ## c ## ## c ############################################################## c c c "pimove" rotates the vector between atoms "list(1)" and c "list(2)" so that atom 1 is at the origin and atom 2 along c the x-axis; the atoms defining the respective planes are c also moved and their bond lengths normalized c c subroutine pimove (list,xr,yr,zr) use atoms implicit none integer i,j,list(8) real*8 xt,yt,zt real*8 denom,xold real*8 sine,cosine real*8 xr(8),yr(8),zr(8) c c c translate "list" atoms to place atom 1 at origin c j = list(1) xt = x(j) yt = y(j) zt = z(j) do i = 1, 8 j = list(i) xr(i) = x(j) - xt yr(i) = y(j) - yt zr(i) = z(j) - zt end do c c rotate "list" atoms to place atom 2 on the x-axis c denom = sqrt(xr(2)**2 + yr(2)**2) if (denom .ne. 0.0d0) then sine = yr(2) / denom cosine = xr(2) / denom do i = 1, 8 xold = xr(i) xr(i) = xr(i)*cosine + yr(i)*sine yr(i) = yr(i)*cosine - xold*sine end do end if denom = sqrt(xr(2)**2 + zr(2)**2) if (denom .ne. 0.0d0) then sine = zr(2) / denom cosine = xr(2) / denom do i = 1, 8 xold = xr(i) xr(i) = xr(i)*cosine + zr(i)*sine zr(i) = zr(i)*cosine - xold*sine end do end if c c normalize the coordinates of atoms defining the plane for atom 1 c (ie, make all these atoms have unit length to atom 1) so that the c orbital makes equal angles with the atoms rather than simply being c perpendicular to the common plane of the atoms c do i = 3, 5 if (list(i) .ne. list(1)) then denom = sqrt(xr(i)**2+yr(i)**2+zr(i)**2) xr(i) = xr(i) / denom yr(i) = yr(i) / denom zr(i) = zr(i) / denom end if end do c c normalization of plane defining atoms for atom 2; for the c x-coordinate we translate back to the origin, normalize c and then retranslate back along the x-axis c do i = 6, 8 if (list(i) .ne. list(2)) then denom = sqrt((xr(i)-xr(2))**2+yr(i)**2+zr(i)**2) xr(i) = (xr(i)-xr(2))/denom + xr(2) yr(i) = yr(i) / denom zr(i) = zr(i) / denom end if end do return end c c c ############################################################## c ## ## c ## subroutine pialter -- modify parameters for pisystem ## c ## ## c ############################################################## c c c "pialter" modifies bond lengths and force constants according c to the "planar" P-P-P bond order values; also alters 2-fold c torsional parameters based on the "nonplanar" bond orders c c subroutine pialter use atomid use bndstr use inform use iounit use piorbs use pistuf use tors implicit none integer i,j,k integer ia,ib,ic,id c c c modify the stretching constants and natural bond lengths c if (debug .and. nbpi.ne.0) then write (iout,10) 10 format (/,' Altered Bond Stretching Parameters', & ' for Pi-System :', & //,' Type',14x,'Atom Names',17x,'Initial', & 16x,'Final',/) end if do i = 1, nbpi j = ibpi(1,i) ia = ibnd(1,j) ib = ibnd(2,j) bk(j) = bkpi(j) - kslope(j) * (1.0d0-pnpl(i)) bl(j) = blpi(j) + lslope(j) * (1.0d0-pnpl(i)) if (debug) then write (iout,20) ia,name(ia),ib,name(ib),bkpi(j), & blpi(j),bk(j),bl(j) 20 format (' Bond',6x,2(i7,'-',a3),6x, & f9.3,f8.4,2x,'-->',f9.3,f8.4) end if end do c c modify the 2-fold torsional constants across pibonds c if (debug .and. ntpi.ne.0) then write (iout,30) 30 format (/,' Altered 2-Fold Torsional Parameters', & ' for Pi-System :', & //,' Type',25x,'Atom Names',18x,'Initial', & 8x,'Final',/) end if do i = 1, ntpi j = itpi(1,i) k = itpi(2,i) ia = itors(1,j) ib = itors(2,j) ic = itors(3,j) id = itors(4,j) tors2(1,j) = pbpl(k) * torsp2(j) if (debug) then write (iout,40) ia,name(ia),ib,name(ib),ic,name(ic), & id,name(id),torsp2(j),tors2(1,j) 40 format (' Torsion',3x,4(i7,'-',a3),2x,f8.3,2x,'-->',f8.3) end if 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 piorbs -- conjugated system in current structure ## c ## ## c ################################################################# c c c norbit total number of pisystem orbitals in the system c nconj total number of separate conjugated piystems c reorbit number of evaluations between orbital updates c nbpi total number of bonds affected by the pisystem c ntpi total number of torsions affected by the pisystem c iorbit numbers of the atoms containing pisystem orbitals c iconj first and last atom of each pisystem in the list c kconj contiguous list of atoms in each pisystem c piperp atoms defining a normal plane to each orbital c ibpi bond and piatom numbers for each pisystem bond c itpi torsion and pibond numbers for each pisystem torsion c pbpl pi-bond orders for bonds in "planar" pisystem c pnpl pi-bond orders for bonds in "nonplanar" pisystem c listpi atom list indicating whether each atom has an orbital c c module piorbs implicit none integer norbit integer nconj integer reorbit integer nbpi integer ntpi integer, allocatable :: iorbit(:) integer, allocatable :: iconj(:,:) integer, allocatable :: kconj(:) integer, allocatable :: piperp(:,:) integer, allocatable :: ibpi(:,:) integer, allocatable :: itpi(:,:) real*8, allocatable :: pbpl(:) real*8, allocatable :: pnpl(:) logical, allocatable :: listpi(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module pistuf -- bond order-related pisystem parameters ## c ## ## c ################################################################# c c c bkpi bond stretch force constants for pi-bond order of 1.0 c blpi ideal bond length values for a pi-bond order of 1.0 c kslope rate of force constant decrease with bond order decrease c lslope rate of bond length increase with a bond order decrease c torsp2 2-fold torsional energy barrier for pi-bond order of 1.0 c c module pistuf implicit none real*8, allocatable :: bkpi(:) real*8, allocatable :: blpi(:) real*8, allocatable :: kslope(:) real*8, allocatable :: lslope(:) real*8, allocatable :: torsp2(:) save end c c c ################################################### c ## COPYRIGHT (C) 2003 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module pitors -- pi-system torsions in current structure ## c ## ## c ################################################################## c c c npitors total number of pi-system torsional interactions c ipit numbers of the atoms in each pi-system torsion c kpit 2-fold pi-system torsional force constants c c module pitors implicit none integer npitors integer, allocatable :: ipit(:,:) real*8, allocatable :: kpit(:) save end c c c ################################################### c ## COPYRIGHT (C) 1999 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module pme -- values for particle mesh Ewald summation ## c ## ## c ################################################################ c c c nfft1 current number of PME grid points along a-axis c nfft2 current number of PME grid points along b-axis c nfft3 current number of PME grid points along c-axis c nefft1 number of grid points along electrostatic a-axis c nefft2 number of grid points along electrostatic b-axis c nefft3 number of grid points along electrostatic c-axis c ndfft1 number of grid points along dispersion a-axis c ndfft2 number of grid points along dispersion b-axis c ndfft3 number of grid points along dispersion c-axis c bsorder current order of the PME B-spline values c bseorder order of the electrostatic PME B-spline values c bsporder order of the polarization PME B-spline values c bsdorder order of the dispersion PME B-spline values c igrid initial Ewald grid values for B-spline c bsmod1 B-spline moduli along the a-axis direction c bsmod2 B-spline moduli along the b-axis direction c bsmod3 B-spline moduli along the c-axis direction c bsbuild B-spline derivative coefficient temporary storage c thetai1 B-spline coefficients along the a-axis c thetai2 B-spline coefficients along the b-axis c thetai3 B-spline coefficients along the c-axis c qgrid values on the particle mesh Ewald grid c qfac prefactors for the particle mesh Ewald grid c c module pme implicit none integer nfft1,nfft2,nfft3 integer nefft1,nefft2,nefft3 integer ndfft1,ndfft2,ndfft3 integer bsorder,bseorder integer bsporder,bsdorder integer, allocatable :: igrid(:,:) real*8, allocatable :: bsmod1(:) real*8, allocatable :: bsmod2(:) real*8, allocatable :: bsmod3(:) real*8, allocatable :: bsbuild(:,:) real*8, allocatable :: thetai1(:,:,:) real*8, allocatable :: thetai2(:,:,:) real*8, allocatable :: thetai3(:,:,:) real*8, allocatable :: qgrid(:,:,:,:) real*8, allocatable :: qfac(:,:,:) save end c c c ################################################################## c ## COPYRIGHT (C) 2010 by T. Darden, D. Gohara & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################## c c ################################################################ c ## ## c ## routines below implement various B-spline and coordinate ## c ## manipulations for particle mesh Ewald summation; spatial ## c ## grid assignment by David Gohara; modified from original ## c ## PME code by Thomas Darden, NIEHS, Research Triangle, NC ## c ## ## c ################################################################ c c ############################################################### c ## ## c ## subroutine getchunk -- find number of chunks per axis ## c ## ## c ############################################################### c c c "getchunk" determines the number of grid point "chunks" used c along each axis of the PME grid for parallelization c c subroutine getchunk use chunks use openmp use pme implicit none integer i c c c initialize total chunks and number along each axis c nchunk = 1 nchk1 = 1 nchk2 = 1 nchk3 = 1 c c evaluate use of two to six chunks along each axis c do i = 2, 6 if (nthread.gt.nchunk .and. mod(nfft1,i).eq.0) then nchk1 = i nchunk = nchk1 * nchk2 * nchk3 end if if (nthread.gt.nchunk .and. mod(nfft2,i).eq.0) then nchk2 = i nchunk = nchk1 * nchk2 * nchk3 end if if (nthread.gt.nchunk .and. mod(nfft3,i).eq.0) then nchk3 = i nchunk = nchk1 * nchk2 * nchk3 end if end do c c set number of grid points per chunk along each axis c ngrd1 = nfft1 / nchk1 ngrd2 = nfft2 / nchk2 ngrd3 = nfft3 / nchk3 c c set grid points to left and right, and B-spline offset c nlpts = (bsorder-1) / 2 nrpts = bsorder - nlpts - 1 grdoff = (bsorder+1)/2 + 1 return end c c c ########################################################### c ## ## c ## subroutine moduli -- store the inverse DFT moduli ## c ## ## c ########################################################### c c c "moduli" sets the moduli of the inverse discrete Fourier c transform of the B-splines c c subroutine moduli use pme implicit none integer i,maxfft real*8 x real*8, allocatable :: array(:) real*8, allocatable :: bsarray(:) c c c perform dynamic allocation of some local arrays c maxfft = max(nfft1,nfft2,nfft3) allocate (array(bsorder)) allocate (bsarray(max(maxfft,bsorder+1))) c c compute and load the moduli values c x = 0.0d0 call bspline (x,bsorder,array) do i = 1, maxfft bsarray(i) = 0.0d0 end do do i = 1, bsorder bsarray(i+1) = array(i) end do call dftmod (bsmod1,bsarray,nfft1,bsorder) call dftmod (bsmod2,bsarray,nfft2,bsorder) call dftmod (bsmod3,bsarray,nfft3,bsorder) c c perform deallocation of some local arrays c deallocate (array) deallocate (bsarray) return end c c c ############################################################### c ## ## c ## subroutine bspline -- determine B-spline coefficients ## c ## ## c ############################################################### c c c "bspline" calculates the coefficients for an n-th order c B-spline approximation c c subroutine bspline (x,n,c) implicit none integer i,k,n real*8 x,denom real*8 c(*) c c c initialize the B-spline as the linear case c c(1) = 1.0d0 - x c(2) = x c c compute standard B-spline recursion to n-th order c do k = 3, n denom = 1.0d0 / dble(k-1) c(k) = x * c(k-1) * denom do i = 1, k-2 c(k-i) = ((x+dble(i))*c(k-i-1) & + (dble(k-i)-x)*c(k-i)) * denom end do c(1) = (1.0d0-x) * c(1) * denom end do return end c c c ################################################################# c ## ## c ## subroutine dftmod -- discrete Fourier transform modulus ## c ## ## c ################################################################# c c c "dftmod" computes the modulus of the discrete Fourier transform c of "bsarray" and stores it in "bsmod" c c subroutine dftmod (bsmod,bsarray,nfft,order) use math implicit none integer i,j,k integer nfft,jcut integer order,order2 real*8 eps,zeta real*8 arg,factor real*8 sum1,sum2 real*8 bsmod(*) real*8 bsarray(*) c c c get the modulus of the discrete Fourier transform c factor = 2.0d0 * pi / dble(nfft) do i = 1, nfft sum1 = 0.0d0 sum2 = 0.0d0 do j = 1, nfft arg = factor * dble((i-1)*(j-1)) sum1 = sum1 + bsarray(j)*cos(arg) sum2 = sum2 + bsarray(j)*sin(arg) end do bsmod(i) = sum1**2 + sum2**2 end do c c fix for exponential Euler spline interpolation failure c eps = 1.0d-7 if (bsmod(1) .lt. eps) bsmod(1) = 0.5d0 * bsmod(2) do i = 2, nfft-1 if (bsmod(i) .lt. eps) & bsmod(i) = 0.5d0 * (bsmod(i-1)+bsmod(i+1)) end do if (bsmod(nfft) .lt. eps) bsmod(nfft) = 0.5d0 * bsmod(nfft-1) c c compute and apply the optimal zeta coefficient c jcut = 50 order2 = 2 * order do i = 1, nfft k = i - 1 if (i .gt. nfft/2) k = k - nfft if (k .eq. 0) then zeta = 1.0d0 else sum1 = 1.0d0 sum2 = 1.0d0 factor = pi * dble(k) / dble(nfft) do j = 1, jcut arg = factor / (factor+pi*dble(j)) sum1 = sum1 + arg**order sum2 = sum2 + arg**order2 end do do j = 1, jcut arg = factor / (factor-pi*dble(j)) sum1 = sum1 + arg**order sum2 = sum2 + arg**order2 end do zeta = sum2 / sum1 end if bsmod(i) = bsmod(i) * zeta**2 end do return end c c c ################################################################## c ## ## c ## subroutine bspline_fill -- get PME B-spline coefficients ## c ## ## c ################################################################## c c c "bspline_fill" finds B-spline coefficients and derivatives c for PME atomic sites along the fractional coordinate axes c c subroutine bspline_fill use atoms use boxes use pme implicit none integer i,ifr real*8 xi,yi,zi real*8 w,fr,eps c c c perform dynamic allocation of some global arrays c if (.not. allocated(igrid)) allocate (igrid(3,n)) c c offset used to shift sites off exact lattice bounds c eps = 1.0d-8 c c get the B-spline coefficients for each atomic site c do i = 1, n xi = x(i) yi = y(i) zi = z(i) w = xi*recip(1,1) + yi*recip(2,1) + zi*recip(3,1) fr = dble(nfft1) * (w-dble(anint(w))+0.5d0) ifr = int(fr-eps) w = fr - dble(ifr) igrid(1,i) = ifr - bsorder call bsplgen (w,thetai1(1,1,i)) w = xi*recip(1,2) + yi*recip(2,2) + zi*recip(3,2) fr = dble(nfft2) * (w-dble(anint(w))+0.5d0) ifr = int(fr-eps) w = fr - dble(ifr) igrid(2,i) = ifr - bsorder call bsplgen (w,thetai2(1,1,i)) w = xi*recip(1,3) + yi*recip(2,3) + zi*recip(3,3) fr = dble(nfft3) * (w-dble(anint(w))+0.5d0) ifr = int(fr-eps) w = fr - dble(ifr) igrid(3,i) = ifr - bsorder call bsplgen (w,thetai3(1,1,i)) end do return end c c c ################################################################# c ## ## c ## subroutine bsplgen -- B-spline coefficients for an atom ## c ## ## c ################################################################# c c c "bsplgen" gets B-spline coefficients and derivatives for c a single PME atomic site along a particular direction c c subroutine bsplgen (w,thetai) use pme use potent implicit none integer i,j,k integer level real*8 w,denom real*8 thetai(4,*) c c c set B-spline depth for partial charges or multipoles c level = 2 if (use_mpole .or. use_polar) level = 4 c c initialization to get to 2nd order recursion c bsbuild(2,2) = w bsbuild(2,1) = 1.0d0 - w c c perform one pass to get to 3rd order recursion c bsbuild(3,3) = 0.5d0 * w * bsbuild(2,2) bsbuild(3,2) = 0.5d0 * ((1.0d0+w)*bsbuild(2,1) & +(2.0d0-w)*bsbuild(2,2)) bsbuild(3,1) = 0.5d0 * (1.0d0-w) * bsbuild(2,1) c c compute standard B-spline recursion to desired order c do i = 4, bsorder k = i - 1 denom = 1.0d0 / dble(k) bsbuild(i,i) = denom * w * bsbuild(k,k) do j = 1, i-2 bsbuild(i,i-j) = denom * ((w+dble(j))*bsbuild(k,i-j-1) & +(dble(i-j)-w)*bsbuild(k,i-j)) end do bsbuild(i,1) = denom * (1.0d0-w) * bsbuild(k,1) end do c c get coefficients for the B-spline first derivative c k = bsorder - 1 bsbuild(k,bsorder) = bsbuild(k,bsorder-1) do i = bsorder-1, 2, -1 bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i) end do bsbuild(k,1) = -bsbuild(k,1) c c get coefficients for the B-spline second derivative c if (level .eq. 4) then k = bsorder - 2 bsbuild(k,bsorder-1) = bsbuild(k,bsorder-2) do i = bsorder-2, 2, -1 bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i) end do bsbuild(k,1) = -bsbuild(k,1) bsbuild(k,bsorder) = bsbuild(k,bsorder-1) do i = bsorder-1, 2, -1 bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i) end do bsbuild(k,1) = -bsbuild(k,1) c c get coefficients for the B-spline third derivative c k = bsorder - 3 bsbuild(k,bsorder-2) = bsbuild(k,bsorder-3) do i = bsorder-3, 2, -1 bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i) end do bsbuild(k,1) = -bsbuild(k,1) bsbuild(k,bsorder-1) = bsbuild(k,bsorder-2) do i = bsorder-2, 2, -1 bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i) end do bsbuild(k,1) = -bsbuild(k,1) bsbuild(k,bsorder) = bsbuild(k,bsorder-1) do i = bsorder-1, 2, -1 bsbuild(k,i) = bsbuild(k,i-1) - bsbuild(k,i) end do bsbuild(k,1) = -bsbuild(k,1) end if c c copy coefficients from temporary to permanent storage c do i = 1, bsorder do j = 1, level thetai(j,i) = bsbuild(bsorder-j+1,i) end do end do return end c c c ############################################################### c ## ## c ## subroutine table_fill -- spatial chunks for each site ## c ## ## c ############################################################### c c c "table_fill" constructs an array which stores the spatial c regions of the particle mesh Ewald grid with contributions c from each site c c subroutine table_fill use atoms use chunks use pme implicit none integer i,k integer cid(3) integer nearpt(3) integer abound(6) integer cbound(6) logical negx,negy,negz logical posx,posy,posz logical midx,midy,midz c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(n,nchunk,pmetable,igrid, !$OMP& nfft1,nfft2,nfft3,nchk1,nchk2,nchk3,ngrd1,ngrd2,ngrd3, !$OMP& nlpts,nrpts,grdoff) !$OMP DO schedule(guided) c c zero out the PME table marking chunks per site c do k = 1, nchunk do i = 1, n pmetable(i,k) = 0 end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP DO schedule(guided) c c loop over sites to find the spatial chunks for each c do i = 1, n nearpt(1) = igrid(1,i) + grdoff nearpt(2) = igrid(2,i) + grdoff nearpt(3) = igrid(3,i) + grdoff if (nearpt(1) .lt. 1) then nearpt(1) = mod(nearpt(1),nfft1) + nfft1 else if (nearpt(1) .gt. nfft1) then nearpt(1) = mod(nearpt(1),nfft1) end if if (nearpt(2) .lt. 1) then nearpt(2) = mod(nearpt(2),nfft2) + nfft2 else if (nearpt(2) .gt. nfft2) then nearpt(2) = mod(nearpt(2),nfft2) end if if (nearpt(3) .lt. 1) then nearpt(3) = mod(nearpt(3),nfft3) + nfft3 else if (nearpt(3) .gt. nfft3) then nearpt(3) = mod(nearpt(3),nfft3) end if abound(1) = nearpt(1) - nlpts abound(2) = nearpt(1) + nrpts abound(3) = nearpt(2) - nlpts abound(4) = nearpt(2) + nrpts abound(5) = nearpt(3) - nlpts abound(6) = nearpt(3) + nrpts cid(1) = (nearpt(1)-1)/ngrd1 + 1 cid(2) = (nearpt(2)-1)/ngrd2 + 1 cid(3) = (nearpt(3)-1)/ngrd3 + 1 cbound(1) = (cid(1)-1)*ngrd1 + 1 cbound(2) = cbound(1) + ngrd1 - 1 cbound(3) = (cid(2)-1)*ngrd2 + 1 cbound(4) = cbound(3) + ngrd2 - 1 cbound(5) = (cid(3)-1)*ngrd3 + 1 cbound(6) = cbound(5) + ngrd3 - 1 c c set and store central chunk where the site is located c k = (cid(3)-1)*nchk1*nchk2 + (cid(2)-1)*nchk1 + cid(1) pmetable(i,k) = 1 c c flags for atom bounds to left or right of central chunk c negx = (abound(1) .lt. cbound(1)) negy = (abound(3) .lt. cbound(3)) negz = (abound(5) .lt. cbound(5)) posx = (abound(2) .gt. cbound(2)) posy = (abound(4) .gt. cbound(4)) posz = (abound(6) .gt. cbound(6)) c c flags for atom bounds fully inside the central chunk c midx = (.not.negx .and. .not.posx) midy = (.not.negy .and. .not.posy) midz = (.not.negz .and. .not.posz) if (midx .and. midy .and. midz) goto 10 c c flags for atom bounds that overlap the central chunk c midx = (.not.negx .or. .not.posx) midy = (.not.negy .or. .not.posy) midz = (.not.negz .or. .not.posz) c c check for overlap with any of the neighboring chunks c if (midx .and. midy .and. negz) call setchunk (i,cid,0,0,-1) if (midx .and. midy .and. posz) call setchunk (i,cid,0,0,1) if (midx .and. negy .and. midz) call setchunk (i,cid,0,-1,0) if (midx .and. posy .and. midz) call setchunk (i,cid,0,1,0) if (negx .and. midy .and. midz) call setchunk (i,cid,-1,0,0) if (posx .and. midy .and. midz) call setchunk (i,cid,1,0,0) if (midx .and. negy .and. negz) call setchunk (i,cid,0,-1,-1) if (midx .and. negy .and. posz) call setchunk (i,cid,0,-1,1) if (midx .and. posy .and. negz) call setchunk (i,cid,0,1,-1) if (midx .and. posy .and. posz) call setchunk (i,cid,0,1,1) if (negx .and. midy .and. negz) call setchunk (i,cid,-1,0,-1) if (negx .and. midy .and. posz) call setchunk (i,cid,-1,0,1) if (posx .and. midy .and. negz) call setchunk (i,cid,1,0,-1) if (posx .and. midy .and. posz) call setchunk (i,cid,1,0,1) if (negx .and. negy .and. midz) call setchunk (i,cid,-1,-1,0) if (negx .and. posy .and. midz) call setchunk (i,cid,-1,1,0) if (posx .and. negy .and. midz) call setchunk (i,cid,1,-1,0) if (posx .and. posy .and. midz) call setchunk (i,cid,1,1,0) if (negx .and. negy .and. negz) call setchunk (i,cid,-1,-1,-1) if (negx .and. negy .and. posz) call setchunk (i,cid,-1,-1,1) if (negx .and. posy .and. negz) call setchunk (i,cid,-1,1,-1) if (posx .and. negy .and. negz) call setchunk (i,cid,1,-1,-1) if (negx .and. posy .and. posz) call setchunk (i,cid,-1,1,1) if (posx .and. negy .and. posz) call setchunk (i,cid,1,-1,1) if (posx .and. posy .and. negz) call setchunk (i,cid,1,1,-1) if (posx .and. posy .and. posz) call setchunk (i,cid,1,1,1) 10 continue end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################################ c ## ## c ## subroutine setchunk -- site overlaps neighboring chunk ## c ## ## c ################################################################ c c c "setchunk" marks a chunk in the PME spatial table which is c overlapped by the B-splines for a site c c subroutine setchunk (i,cid,off1,off2,off3) use chunks use pme implicit none integer i,k integer off1,off2,off3 integer cid(3),temp(3) c c c mark neighboring chunk overlapped by an electrostatic site c temp(1) = cid(1) + off1 if (temp(1) .lt. 1) temp(1) = nchk1 if (temp(1) .gt. nchk1) temp(1) = 1 temp(2) = cid(2) + off2 if (temp(2) .lt. 1) temp(2) = nchk2 if (temp(2) .gt. nchk2) temp(2) = 1 temp(3) = cid(3) + off3 if (temp(3) .lt. 1) temp(3) = nchk3 if (temp(3) .gt. nchk3) temp(3) = 1 k = (temp(3)-1)*nchk1*nchk2 + (temp(2)-1)*nchk1 + temp(1) pmetable(i,k) = 1 return end c c c ################################################################# c ## ## c ## subroutine grid_pchg -- put partial charges on PME grid ## c ## ## c ################################################################# c c c "grid_pchg" places the fractional atomic partial charges onto c the particle mesh Ewald grid c c note the main loop does not need to be an OpenMP reduction c since a given qgrid element is always part of the same chunk, c and the code runs faster without use of a reduction c c subroutine grid_pchg use atoms use charge use chunks use pme implicit none integer i,j,k,m integer ii,jj,kk integer ichk,isite,iatm integer offsetx,offsety integer offsetz integer cid(3) integer nearpt(3) integer abound(6) integer cbound(6) real*8 v0,u0,t0 real*8 term c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nion,iion,pchg,pmetable, !$OMP& nfft1,nfft2,nfft3,nchunk,nchk1,nchk2,nchk3,ngrd1,ngrd2, !$OMP& ngrd3,nlpts,nrpts,igrid,grdoff,thetai1,thetai2,thetai3) !$OMP& shared(qgrid) !$OMP DO schedule(guided) c c zero out the particle mesh Ewald grid c do k = 1, nfft3 do j = 1, nfft2 do i = 1, nfft1 qgrid(1,i,j,k) = 0.0d0 qgrid(2,i,j,k) = 0.0d0 end do end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP DO schedule(guided) c c put the permanent multipole moments onto the grid c do ichk = 1, nchunk cid(1) = mod(ichk-1,nchk1) cid(2) = mod(((ichk-1-cid(1))/nchk1),nchk2) cid(3) = mod((ichk-1)/(nchk1*nchk2),nchk3) cbound(1) = cid(1)*ngrd1 + 1 cbound(2) = cbound(1) + ngrd1 - 1 cbound(3) = cid(2)*ngrd2 + 1 cbound(4) = cbound(3) + ngrd2 - 1 cbound(5) = cid(3)*ngrd3 + 1 cbound(6) = cbound(5) + ngrd3 - 1 do isite = 1, nion iatm = iion(isite) if (pmetable(iatm,ichk) .eq. 1) then nearpt(1) = igrid(1,iatm) + grdoff nearpt(2) = igrid(2,iatm) + grdoff nearpt(3) = igrid(3,iatm) + grdoff abound(1) = nearpt(1) - nlpts abound(2) = nearpt(1) + nrpts abound(3) = nearpt(2) - nlpts abound(4) = nearpt(2) + nrpts abound(5) = nearpt(3) - nlpts abound(6) = nearpt(3) + nrpts call adjust (offsetx,nfft1,nchk1,abound(1), & abound(2),cbound(1),cbound(2)) call adjust (offsety,nfft2,nchk2,abound(3), & abound(4),cbound(3),cbound(4)) call adjust (offsetz,nfft3,nchk3,abound(5), & abound(6),cbound(5),cbound(6)) do kk = abound(5), abound(6) k = kk m = k + offsetz if (k .lt. 1) k = k + nfft3 v0 = thetai3(1,m,iatm) * pchg(iatm) do jj = abound(3), abound(4) j = jj m = j + offsety if (j .lt. 1) j = j + nfft2 u0 = thetai2(1,m,iatm) term = v0 * u0 do ii = abound(1), abound(2) i = ii m = i + offsetx if (i .lt. 1) i = i + nfft1 t0 = thetai1(1,m,iatm) qgrid(1,i,j,k) = qgrid(1,i,j,k) + term*t0 end do end do end do 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 ## ## c ## subroutine grid_mpole -- put multipoles on PME grid ## c ## ## c ############################################################# c c c "grid_mpole" places the fractional atomic multipoles onto c the particle mesh Ewald grid c c note the main loop does not need to be an OpenMP reduction c since a given qgrid element is always part of the same chunk, c and the code runs faster without use of a reduction c c subroutine grid_mpole (fmp) use atoms use chunks use mpole use pme implicit none integer i,j,k,m integer ii,jj,kk integer ichk,isite,iatm integer offsetx,offsety integer offsetz integer cid(3) integer nearpt(3) integer abound(6) integer cbound(6) real*8 v0,u0,t0 real*8 v1,u1,t1 real*8 v2,u2,t2 real*8 term0,term1,term2 real*8 fmp(10,*) c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(npole,ipole,fmp,pmetable, !$OMP& nfft1,nfft2,nfft3,nchunk,nchk1,nchk2,nchk3,ngrd1,ngrd2, !$OMP& ngrd3,nlpts,nrpts,igrid,grdoff,thetai1,thetai2,thetai3) !$OMP& shared(qgrid) !$OMP DO schedule(guided) c c zero out the particle mesh Ewald grid c do k = 1, nfft3 do j = 1, nfft2 do i = 1, nfft1 qgrid(1,i,j,k) = 0.0d0 qgrid(2,i,j,k) = 0.0d0 end do end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP DO schedule(guided) c c put the permanent multipole moments onto the grid c do ichk = 1, nchunk cid(1) = mod(ichk-1,nchk1) cid(2) = mod(((ichk-1-cid(1))/nchk1),nchk2) cid(3) = mod((ichk-1)/(nchk1*nchk2),nchk3) cbound(1) = cid(1)*ngrd1 + 1 cbound(2) = cbound(1) + ngrd1 - 1 cbound(3) = cid(2)*ngrd2 + 1 cbound(4) = cbound(3) + ngrd2 - 1 cbound(5) = cid(3)*ngrd3 + 1 cbound(6) = cbound(5) + ngrd3 - 1 do isite = 1, npole iatm = ipole(isite) if (pmetable(iatm,ichk) .eq. 1) then nearpt(1) = igrid(1,iatm) + grdoff nearpt(2) = igrid(2,iatm) + grdoff nearpt(3) = igrid(3,iatm) + grdoff abound(1) = nearpt(1) - nlpts abound(2) = nearpt(1) + nrpts abound(3) = nearpt(2) - nlpts abound(4) = nearpt(2) + nrpts abound(5) = nearpt(3) - nlpts abound(6) = nearpt(3) + nrpts call adjust (offsetx,nfft1,nchk1,abound(1), & abound(2),cbound(1),cbound(2)) call adjust (offsety,nfft2,nchk2,abound(3), & abound(4),cbound(3),cbound(4)) call adjust (offsetz,nfft3,nchk3,abound(5), & abound(6),cbound(5),cbound(6)) do kk = abound(5), abound(6) k = kk m = k + offsetz if (k .lt. 1) k = k + nfft3 v0 = thetai3(1,m,iatm) v1 = thetai3(2,m,iatm) v2 = thetai3(3,m,iatm) do jj = abound(3), abound(4) j = jj m = j + offsety if (j .lt. 1) j = j + nfft2 u0 = thetai2(1,m,iatm) u1 = thetai2(2,m,iatm) u2 = thetai2(3,m,iatm) term0 = fmp(1,iatm)*u0*v0 + fmp(3,iatm)*u1*v0 & + fmp(4,iatm)*u0*v1 + fmp(6,iatm)*u2*v0 & + fmp(7,iatm)*u0*v2 + fmp(10,iatm)*u1*v1 term1 = fmp(2,iatm)*u0*v0 + fmp(8,iatm)*u1*v0 & + fmp(9,iatm)*u0*v1 term2 = fmp(5,iatm) * u0 * v0 do ii = abound(1), abound(2) i = ii m = i + offsetx if (i .lt. 1) i = i + nfft1 t0 = thetai1(1,m,iatm) t1 = thetai1(2,m,iatm) t2 = thetai1(3,m,iatm) qgrid(1,i,j,k) = qgrid(1,i,j,k) + term0*t0 & + term1*t1 + term2*t2 end do end do end do 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 ## ## c ## subroutine grid_uind -- put induced dipoles on PME grid ## c ## ## c ################################################################# c c c "grid_uind" places the fractional induced dipoles onto the c particle mesh Ewald grid c c note the main loop does not need to be an OpenMP reduction c since a given qgrid element is always part of the same chunk, c and the code runs faster without use of a reduction c c subroutine grid_uind (fuind,fuinp) use atoms use chunks use mpole use pme implicit none integer i,j,k,m integer ii,jj,kk integer ichk,isite,iatm integer offsetx,offsety integer offsetz integer cid(3) integer nearpt(3) integer abound(6) integer cbound(6) real*8 v0,u0,t0 real*8 v1,u1,t1 real*8 term01,term11 real*8 term02,term12 real*8 fuind(3,*) real*8 fuinp(3,*) c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(npole,ipole,fuind,fuinp, !$OMP& pmetable,nfft1,nfft2,nfft3,nchunk,nchk1,nchk2,nchk3,ngrd1, !$OMP& ngrd2,ngrd3,nlpts,nrpts,igrid,grdoff,thetai1,thetai2,thetai3) !$OMP& shared(qgrid) !$OMP DO schedule(guided) c c zero out the particle mesh Ewald grid c do k = 1, nfft3 do j = 1, nfft2 do i = 1, nfft1 qgrid(1,i,j,k) = 0.0d0 qgrid(2,i,j,k) = 0.0d0 end do end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP DO schedule(guided) c c put the induced dipole moments onto the grid c do ichk = 1, nchunk cid(1) = mod(ichk-1,nchk1) cid(2) = mod(((ichk-1-cid(1))/nchk1),nchk2) cid(3) = mod((ichk-1)/(nchk1*nchk2),nchk3) cbound(1) = cid(1)*ngrd1 + 1 cbound(2) = cbound(1) + ngrd1 - 1 cbound(3) = cid(2)*ngrd2 + 1 cbound(4) = cbound(3) + ngrd2 - 1 cbound(5) = cid(3)*ngrd3 + 1 cbound(6) = cbound(5) + ngrd3 - 1 do isite = 1, npole iatm = ipole(isite) if (pmetable(iatm,ichk) .eq. 1) then nearpt(1) = igrid(1,iatm) + grdoff nearpt(2) = igrid(2,iatm) + grdoff nearpt(3) = igrid(3,iatm) + grdoff abound(1) = nearpt(1) - nlpts abound(2) = nearpt(1) + nrpts abound(3) = nearpt(2) - nlpts abound(4) = nearpt(2) + nrpts abound(5) = nearpt(3) - nlpts abound(6) = nearpt(3) + nrpts call adjust (offsetx,nfft1,nchk1,abound(1), & abound(2),cbound(1),cbound(2)) call adjust (offsety,nfft2,nchk2,abound(3), & abound(4),cbound(3),cbound(4)) call adjust (offsetz,nfft3,nchk3,abound(5), & abound(6),cbound(5),cbound(6)) do kk = abound(5), abound(6) k = kk m = k + offsetz if (k .lt. 1) k = k + nfft3 v0 = thetai3(1,m,iatm) v1 = thetai3(2,m,iatm) do jj = abound(3), abound(4) j = jj m = j + offsety if (j .lt. 1) j = j + nfft2 u0 = thetai2(1,m,iatm) u1 = thetai2(2,m,iatm) term01 = fuind(2,iatm)*u1*v0 & + fuind(3,iatm)*u0*v1 term11 = fuind(1,iatm)*u0*v0 term02 = fuinp(2,iatm)*u1*v0 & + fuinp(3,iatm)*u0*v1 term12 = fuinp(1,iatm)*u0*v0 do ii = abound(1), abound(2) i = ii m = i + offsetx if (i .lt. 1) i = i + nfft1 t0 = thetai1(1,m,iatm) t1 = thetai1(2,m,iatm) qgrid(1,i,j,k) = qgrid(1,i,j,k) + term01*t0 & + term11*t1 qgrid(2,i,j,k) = qgrid(2,i,j,k) + term02*t0 & + term12*t1 end do end do end do 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 ## ## c ## subroutine grid_disp -- put dispersion sites on PME grid ## c ## ## c ################################################################## c c c "grid_disp" places the damped dispersion coefficients onto c the particle mesh Ewald grid c c note the main loop does not need to be an OpenMP reduction c since a given qgrid element is always part of the same chunk, c and the code runs faster without use of a reduction c c subroutine grid_disp use atoms use disp use chunks use pme implicit none integer i,j,k,m integer ii,jj,kk integer ichk,isite,iatm integer offsetx,offsety integer offsetz integer cid(3) integer nearpt(3) integer abound(6) integer cbound(6) real*8 v0,u0,t0 real*8 term c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(ndisp,idisp,csix,pmetable, !$OMP& nfft1,nfft2,nfft3,nchunk,nchk1,nchk2,nchk3,ngrd1,ngrd2, !$OMP& ngrd3,nlpts,nrpts,igrid,grdoff,thetai1,thetai2,thetai3) !$OMP& shared(qgrid) !$OMP DO schedule(guided) c c zero out the particle mesh Ewald grid c do k = 1, nfft3 do j = 1, nfft2 do i = 1, nfft1 qgrid(1,i,j,k) = 0.0d0 qgrid(2,i,j,k) = 0.0d0 end do end do end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP DO schedule(guided) c c put the dispersion sites onto the grid c do ichk = 1, nchunk cid(1) = mod(ichk-1,nchk1) cid(2) = mod(((ichk-1-cid(1))/nchk1),nchk2) cid(3) = mod((ichk-1)/(nchk1*nchk2),nchk3) cbound(1) = cid(1)*ngrd1 + 1 cbound(2) = cbound(1) + ngrd1 - 1 cbound(3) = cid(2)*ngrd2 + 1 cbound(4) = cbound(3) + ngrd2 - 1 cbound(5) = cid(3)*ngrd3 + 1 cbound(6) = cbound(5) + ngrd3 - 1 do isite = 1, ndisp iatm = idisp(isite) if (pmetable(iatm,ichk) .eq. 1) then nearpt(1) = igrid(1,iatm) + grdoff nearpt(2) = igrid(2,iatm) + grdoff nearpt(3) = igrid(3,iatm) + grdoff abound(1) = nearpt(1) - nlpts abound(2) = nearpt(1) + nrpts abound(3) = nearpt(2) - nlpts abound(4) = nearpt(2) + nrpts abound(5) = nearpt(3) - nlpts abound(6) = nearpt(3) + nrpts call adjust (offsetx,nfft1,nchk1,abound(1), & abound(2),cbound(1),cbound(2)) call adjust (offsety,nfft2,nchk2,abound(3), & abound(4),cbound(3),cbound(4)) call adjust (offsetz,nfft3,nchk3,abound(5), & abound(6),cbound(5),cbound(6)) do kk = abound(5), abound(6) k = kk m = k + offsetz if (k .lt. 1) k = k + nfft3 v0 = thetai3(1,m,iatm) * csix(iatm) do jj = abound(3), abound(4) j = jj m = j + offsety if (j .lt. 1) j = j + nfft2 u0 = thetai2(1,m,iatm) term = v0 * u0 do ii = abound(1), abound(2) i = ii m = i + offsetx if (i .lt. 1) i = i + nfft1 t0 = thetai1(1,m,iatm) qgrid(1,i,j,k) = qgrid(1,i,j,k) + term*t0 end do end do end do 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 ## ## c ## subroutine adjust -- alter site bounds for the PME grid ## c ## ## c ################################################################# c c c "adjust" modifies site bounds on the PME grid and returns c an offset into the B-spline coefficient arrays c c subroutine adjust (offset,nfft,nchk,amin,amax,cmin,cmax) implicit none integer offset integer nfft,nchk integer amin,amax integer cmin,cmax c c c modify grid offset and bounds for site at edge of chunk c offset = 0 if (nchk .ne. 1) then if (amin.lt.cmin .or. amax.gt.cmax) then if (amin.lt.1 .or. amax.gt.nfft) then if (cmin .eq. 1) then offset = 1 - amin amin = 1 else if (cmax .eq. nfft) then amax = nfft amin = amin + nfft end if else if (cmin .gt. amin) then offset = cmin - amin amin = cmin else amax = cmax end if end if end if end if offset = offset + 1 - amin return end c c c ############################################################ c ## ## c ## subroutine fphi_pchg -- charge potential and field ## c ## ## c ############################################################ c c c "fphi_pchg" extracts the partial charge potential and field c from the particle mesh Ewald grid c c subroutine fphi_pchg (fphi) use charge use pme implicit none integer i,j,k integer isite,iatm integer i0,j0,k0 integer it1,it2,it3 integer igrd0,jgrd0,kgrd0 real*8 v0,v1 real*8 u0,u1 real*8 t0,t1,tq real*8 tu00,tu10,tu01 real*8 tuv000,tuv100 real*8 tuv010,tuv001 real*8 fphi(4,*) c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(nion,iion,igrid,bsorder, !$OMP& nfft1,nfft2,nfft3,thetai1,thetai2,thetai3,qgrid,fphi) !$OMP DO schedule(guided) c c get partial charge potential and field at each site c do isite = 1, nion iatm = iion(isite) igrd0 = igrid(1,iatm) jgrd0 = igrid(2,iatm) kgrd0 = igrid(3,iatm) tuv000 = 0.0d0 tuv001 = 0.0d0 tuv010 = 0.0d0 tuv100 = 0.0d0 k0 = kgrd0 do it3 = 1, bsorder k0 = k0 + 1 k = k0 + 1 + (nfft3-isign(nfft3,k0))/2 v0 = thetai3(1,it3,iatm) v1 = thetai3(2,it3,iatm) tu00 = 0.0d0 tu10 = 0.0d0 tu01 = 0.0d0 j0 = jgrd0 do it2 = 1, bsorder j0 = j0 + 1 j = j0 + 1 + (nfft2-isign(nfft2,j0))/2 u0 = thetai2(1,it2,iatm) u1 = thetai2(2,it2,iatm) t0 = 0.0d0 t1 = 0.0d0 i0 = igrd0 do it1 = 1, bsorder i0 = i0 + 1 i = i0 + 1 + (nfft1-isign(nfft1,i0))/2 tq = qgrid(1,i,j,k) t0 = t0 + tq*thetai1(1,it1,iatm) t1 = t1 + tq*thetai1(2,it1,iatm) end do tu00 = tu00 + t0*u0 tu10 = tu10 + t1*u0 tu01 = tu01 + t0*u1 end do tuv000 = tuv000 + tu00*v0 tuv100 = tuv100 + tu10*v0 tuv010 = tuv010 + tu01*v0 tuv001 = tuv001 + tu00*v1 end do fphi(1,iatm) = tuv000 fphi(2,iatm) = tuv100 fphi(3,iatm) = tuv010 fphi(4,iatm) = tuv001 end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ################################################################ c ## ## c ## subroutine fphi_mpole -- multipole potential and field ## c ## ## c ################################################################ c c c "fphi_mpole" extracts the permanent multipole potential and c field from the particle mesh Ewald grid c c subroutine fphi_mpole (fphi) use mpole use pme implicit none integer i,j,k integer isite,iatm integer i0,j0,k0 integer it1,it2,it3 integer igrd0,jgrd0,kgrd0 real*8 v0,v1,v2,v3 real*8 u0,u1,u2,u3 real*8 t0,t1,t2,t3,tq real*8 tu00,tu10,tu01,tu20,tu11 real*8 tu02,tu21,tu12,tu30,tu03 real*8 tuv000,tuv100,tuv010,tuv001 real*8 tuv200,tuv020,tuv002,tuv110 real*8 tuv101,tuv011,tuv300,tuv030 real*8 tuv003,tuv210,tuv201,tuv120 real*8 tuv021,tuv102,tuv012,tuv111 real*8 fphi(20,*) c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(npole,ipole,igrid,bsorder, !$OMP& nfft1,nfft2,nfft3,thetai1,thetai2,thetai3,qgrid,fphi) !$OMP DO schedule(guided) c c get permanent multipole potential and field at each site c do isite = 1, npole iatm = ipole(isite) igrd0 = igrid(1,iatm) jgrd0 = igrid(2,iatm) kgrd0 = igrid(3,iatm) tuv000 = 0.0d0 tuv001 = 0.0d0 tuv010 = 0.0d0 tuv100 = 0.0d0 tuv200 = 0.0d0 tuv020 = 0.0d0 tuv002 = 0.0d0 tuv110 = 0.0d0 tuv101 = 0.0d0 tuv011 = 0.0d0 tuv300 = 0.0d0 tuv030 = 0.0d0 tuv003 = 0.0d0 tuv210 = 0.0d0 tuv201 = 0.0d0 tuv120 = 0.0d0 tuv021 = 0.0d0 tuv102 = 0.0d0 tuv012 = 0.0d0 tuv111 = 0.0d0 k0 = kgrd0 do it3 = 1, bsorder k0 = k0 + 1 k = k0 + 1 + (nfft3-isign(nfft3,k0))/2 v0 = thetai3(1,it3,iatm) v1 = thetai3(2,it3,iatm) v2 = thetai3(3,it3,iatm) v3 = thetai3(4,it3,iatm) tu00 = 0.0d0 tu10 = 0.0d0 tu01 = 0.0d0 tu20 = 0.0d0 tu11 = 0.0d0 tu02 = 0.0d0 tu30 = 0.0d0 tu21 = 0.0d0 tu12 = 0.0d0 tu03 = 0.0d0 j0 = jgrd0 do it2 = 1, bsorder j0 = j0 + 1 j = j0 + 1 + (nfft2-isign(nfft2,j0))/2 u0 = thetai2(1,it2,iatm) u1 = thetai2(2,it2,iatm) u2 = thetai2(3,it2,iatm) u3 = thetai2(4,it2,iatm) t0 = 0.0d0 t1 = 0.0d0 t2 = 0.0d0 t3 = 0.0d0 i0 = igrd0 do it1 = 1, bsorder i0 = i0 + 1 i = i0 + 1 + (nfft1-isign(nfft1,i0))/2 tq = qgrid(1,i,j,k) t0 = t0 + tq*thetai1(1,it1,iatm) t1 = t1 + tq*thetai1(2,it1,iatm) t2 = t2 + tq*thetai1(3,it1,iatm) t3 = t3 + tq*thetai1(4,it1,iatm) end do tu00 = tu00 + t0*u0 tu10 = tu10 + t1*u0 tu01 = tu01 + t0*u1 tu20 = tu20 + t2*u0 tu11 = tu11 + t1*u1 tu02 = tu02 + t0*u2 tu30 = tu30 + t3*u0 tu21 = tu21 + t2*u1 tu12 = tu12 + t1*u2 tu03 = tu03 + t0*u3 end do tuv000 = tuv000 + tu00*v0 tuv100 = tuv100 + tu10*v0 tuv010 = tuv010 + tu01*v0 tuv001 = tuv001 + tu00*v1 tuv200 = tuv200 + tu20*v0 tuv020 = tuv020 + tu02*v0 tuv002 = tuv002 + tu00*v2 tuv110 = tuv110 + tu11*v0 tuv101 = tuv101 + tu10*v1 tuv011 = tuv011 + tu01*v1 tuv300 = tuv300 + tu30*v0 tuv030 = tuv030 + tu03*v0 tuv003 = tuv003 + tu00*v3 tuv210 = tuv210 + tu21*v0 tuv201 = tuv201 + tu20*v1 tuv120 = tuv120 + tu12*v0 tuv021 = tuv021 + tu02*v1 tuv102 = tuv102 + tu10*v2 tuv012 = tuv012 + tu01*v2 tuv111 = tuv111 + tu11*v1 end do fphi(1,iatm) = tuv000 fphi(2,iatm) = tuv100 fphi(3,iatm) = tuv010 fphi(4,iatm) = tuv001 fphi(5,iatm) = tuv200 fphi(6,iatm) = tuv020 fphi(7,iatm) = tuv002 fphi(8,iatm) = tuv110 fphi(9,iatm) = tuv101 fphi(10,iatm) = tuv011 fphi(11,iatm) = tuv300 fphi(12,iatm) = tuv030 fphi(13,iatm) = tuv003 fphi(14,iatm) = tuv210 fphi(15,iatm) = tuv201 fphi(16,iatm) = tuv120 fphi(17,iatm) = tuv021 fphi(18,iatm) = tuv102 fphi(19,iatm) = tuv012 fphi(20,iatm) = tuv111 end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ############################################################# c ## ## c ## subroutine fphi_uind -- induced potential and field ## c ## ## c ############################################################# c c c "fphi_uind" extracts the induced dipole potential and field c from the particle mesh Ewald grid c c subroutine fphi_uind (fdip_phi1,fdip_phi2,fdip_sum_phi) use mpole use pme implicit none integer i,j,k integer isite,iatm integer i0,j0,k0 integer it1,it2,it3 integer igrd0,jgrd0,kgrd0 real*8 v0,v1,v2,v3 real*8 u0,u1,u2,u3 real*8 t0,t1,t2,t3 real*8 t0_1,t0_2,t1_1,t1_2 real*8 t2_1,t2_2,tq_1,tq_2 real*8 tu00,tu10,tu01,tu20,tu11 real*8 tu02,tu30,tu21,tu12,tu03 real*8 tu00_1,tu01_1,tu10_1 real*8 tu00_2,tu01_2,tu10_2 real*8 tu20_1,tu11_1,tu02_1 real*8 tu20_2,tu11_2,tu02_2 real*8 tuv100_1,tuv010_1,tuv001_1 real*8 tuv100_2,tuv010_2,tuv001_2 real*8 tuv200_1,tuv020_1,tuv002_1 real*8 tuv110_1,tuv101_1,tuv011_1 real*8 tuv200_2,tuv020_2,tuv002_2 real*8 tuv110_2,tuv101_2,tuv011_2 real*8 tuv000,tuv100,tuv010,tuv001 real*8 tuv200,tuv020,tuv002,tuv110 real*8 tuv101,tuv011,tuv300,tuv030 real*8 tuv003,tuv210,tuv201,tuv120 real*8 tuv021,tuv102,tuv012,tuv111 real*8 fdip_phi1(10,*) real*8 fdip_phi2(10,*) real*8 fdip_sum_phi(20,*) c c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) shared(npole,ipole,igrid,bsorder, !$OMP& nfft1,nfft2,nfft3,thetai1,thetai2,thetai3,qgrid,fdip_phi1, !$OMP& fdip_phi2,fdip_sum_phi) !$OMP DO schedule(guided) c c get induced dipole potential and field at each site c do isite = 1, npole iatm = ipole(isite) igrd0 = igrid(1,iatm) jgrd0 = igrid(2,iatm) kgrd0 = igrid(3,iatm) tuv100_1 = 0.0d0 tuv010_1 = 0.0d0 tuv001_1 = 0.0d0 tuv200_1 = 0.0d0 tuv020_1 = 0.0d0 tuv002_1 = 0.0d0 tuv110_1 = 0.0d0 tuv101_1 = 0.0d0 tuv011_1 = 0.0d0 tuv100_2 = 0.0d0 tuv010_2 = 0.0d0 tuv001_2 = 0.0d0 tuv200_2 = 0.0d0 tuv020_2 = 0.0d0 tuv002_2 = 0.0d0 tuv110_2 = 0.0d0 tuv101_2 = 0.0d0 tuv011_2 = 0.0d0 tuv000 = 0.0d0 tuv001 = 0.0d0 tuv010 = 0.0d0 tuv100 = 0.0d0 tuv200 = 0.0d0 tuv020 = 0.0d0 tuv002 = 0.0d0 tuv110 = 0.0d0 tuv101 = 0.0d0 tuv011 = 0.0d0 tuv300 = 0.0d0 tuv030 = 0.0d0 tuv003 = 0.0d0 tuv210 = 0.0d0 tuv201 = 0.0d0 tuv120 = 0.0d0 tuv021 = 0.0d0 tuv102 = 0.0d0 tuv012 = 0.0d0 tuv111 = 0.0d0 k0 = kgrd0 do it3 = 1, bsorder k0 = k0 + 1 k = k0 + 1 + (nfft3-isign(nfft3,k0))/2 v0 = thetai3(1,it3,iatm) v1 = thetai3(2,it3,iatm) v2 = thetai3(3,it3,iatm) v3 = thetai3(4,it3,iatm) tu00_1 = 0.0d0 tu01_1 = 0.0d0 tu10_1 = 0.0d0 tu20_1 = 0.0d0 tu11_1 = 0.0d0 tu02_1 = 0.0d0 tu00_2 = 0.0d0 tu01_2 = 0.0d0 tu10_2 = 0.0d0 tu20_2 = 0.0d0 tu11_2 = 0.0d0 tu02_2 = 0.0d0 tu00 = 0.0d0 tu10 = 0.0d0 tu01 = 0.0d0 tu20 = 0.0d0 tu11 = 0.0d0 tu02 = 0.0d0 tu30 = 0.0d0 tu21 = 0.0d0 tu12 = 0.0d0 tu03 = 0.0d0 j0 = jgrd0 do it2 = 1, bsorder j0 = j0 + 1 j = j0 + 1 + (nfft2-isign(nfft2,j0))/2 u0 = thetai2(1,it2,iatm) u1 = thetai2(2,it2,iatm) u2 = thetai2(3,it2,iatm) u3 = thetai2(4,it2,iatm) t0_1 = 0.0d0 t1_1 = 0.0d0 t2_1 = 0.0d0 t0_2 = 0.0d0 t1_2 = 0.0d0 t2_2 = 0.0d0 t3 = 0.0d0 i0 = igrd0 do it1 = 1, bsorder i0 = i0 + 1 i = i0 + 1 + (nfft1-isign(nfft1,i0))/2 tq_1 = qgrid(1,i,j,k) tq_2 = qgrid(2,i,j,k) t0_1 = t0_1 + tq_1*thetai1(1,it1,iatm) t1_1 = t1_1 + tq_1*thetai1(2,it1,iatm) t2_1 = t2_1 + tq_1*thetai1(3,it1,iatm) t0_2 = t0_2 + tq_2*thetai1(1,it1,iatm) t1_2 = t1_2 + tq_2*thetai1(2,it1,iatm) t2_2 = t2_2 + tq_2*thetai1(3,it1,iatm) t3 = t3 + (tq_1+tq_2)*thetai1(4,it1,iatm) end do tu00_1 = tu00_1 + t0_1*u0 tu10_1 = tu10_1 + t1_1*u0 tu01_1 = tu01_1 + t0_1*u1 tu20_1 = tu20_1 + t2_1*u0 tu11_1 = tu11_1 + t1_1*u1 tu02_1 = tu02_1 + t0_1*u2 tu00_2 = tu00_2 + t0_2*u0 tu10_2 = tu10_2 + t1_2*u0 tu01_2 = tu01_2 + t0_2*u1 tu20_2 = tu20_2 + t2_2*u0 tu11_2 = tu11_2 + t1_2*u1 tu02_2 = tu02_2 + t0_2*u2 t0 = t0_1 + t0_2 t1 = t1_1 + t1_2 t2 = t2_1 + t2_2 tu00 = tu00 + t0*u0 tu10 = tu10 + t1*u0 tu01 = tu01 + t0*u1 tu20 = tu20 + t2*u0 tu11 = tu11 + t1*u1 tu02 = tu02 + t0*u2 tu30 = tu30 + t3*u0 tu21 = tu21 + t2*u1 tu12 = tu12 + t1*u2 tu03 = tu03 + t0*u3 end do tuv100_1 = tuv100_1 + tu10_1*v0 tuv010_1 = tuv010_1 + tu01_1*v0 tuv001_1 = tuv001_1 + tu00_1*v1 tuv200_1 = tuv200_1 + tu20_1*v0 tuv020_1 = tuv020_1 + tu02_1*v0 tuv002_1 = tuv002_1 + tu00_1*v2 tuv110_1 = tuv110_1 + tu11_1*v0 tuv101_1 = tuv101_1 + tu10_1*v1 tuv011_1 = tuv011_1 + tu01_1*v1 tuv100_2 = tuv100_2 + tu10_2*v0 tuv010_2 = tuv010_2 + tu01_2*v0 tuv001_2 = tuv001_2 + tu00_2*v1 tuv200_2 = tuv200_2 + tu20_2*v0 tuv020_2 = tuv020_2 + tu02_2*v0 tuv002_2 = tuv002_2 + tu00_2*v2 tuv110_2 = tuv110_2 + tu11_2*v0 tuv101_2 = tuv101_2 + tu10_2*v1 tuv011_2 = tuv011_2 + tu01_2*v1 tuv000 = tuv000 + tu00*v0 tuv100 = tuv100 + tu10*v0 tuv010 = tuv010 + tu01*v0 tuv001 = tuv001 + tu00*v1 tuv200 = tuv200 + tu20*v0 tuv020 = tuv020 + tu02*v0 tuv002 = tuv002 + tu00*v2 tuv110 = tuv110 + tu11*v0 tuv101 = tuv101 + tu10*v1 tuv011 = tuv011 + tu01*v1 tuv300 = tuv300 + tu30*v0 tuv030 = tuv030 + tu03*v0 tuv003 = tuv003 + tu00*v3 tuv210 = tuv210 + tu21*v0 tuv201 = tuv201 + tu20*v1 tuv120 = tuv120 + tu12*v0 tuv021 = tuv021 + tu02*v1 tuv102 = tuv102 + tu10*v2 tuv012 = tuv012 + tu01*v2 tuv111 = tuv111 + tu11*v1 end do fdip_phi1(1,iatm) = 0.0d0 fdip_phi1(2,iatm) = tuv100_1 fdip_phi1(3,iatm) = tuv010_1 fdip_phi1(4,iatm) = tuv001_1 fdip_phi1(5,iatm) = tuv200_1 fdip_phi1(6,iatm) = tuv020_1 fdip_phi1(7,iatm) = tuv002_1 fdip_phi1(8,iatm) = tuv110_1 fdip_phi1(9,iatm) = tuv101_1 fdip_phi1(10,iatm) = tuv011_1 fdip_phi2(1,iatm) = 0.0d0 fdip_phi2(2,iatm) = tuv100_2 fdip_phi2(3,iatm) = tuv010_2 fdip_phi2(4,iatm) = tuv001_2 fdip_phi2(5,iatm) = tuv200_2 fdip_phi2(6,iatm) = tuv020_2 fdip_phi2(7,iatm) = tuv002_2 fdip_phi2(8,iatm) = tuv110_2 fdip_phi2(9,iatm) = tuv101_2 fdip_phi2(10,iatm) = tuv011_2 fdip_sum_phi(1,iatm) = tuv000 fdip_sum_phi(2,iatm) = tuv100 fdip_sum_phi(3,iatm) = tuv010 fdip_sum_phi(4,iatm) = tuv001 fdip_sum_phi(5,iatm) = tuv200 fdip_sum_phi(6,iatm) = tuv020 fdip_sum_phi(7,iatm) = tuv002 fdip_sum_phi(8,iatm) = tuv110 fdip_sum_phi(9,iatm) = tuv101 fdip_sum_phi(10,iatm) = tuv011 fdip_sum_phi(11,iatm) = tuv300 fdip_sum_phi(12,iatm) = tuv030 fdip_sum_phi(13,iatm) = tuv003 fdip_sum_phi(14,iatm) = tuv210 fdip_sum_phi(15,iatm) = tuv201 fdip_sum_phi(16,iatm) = tuv120 fdip_sum_phi(17,iatm) = tuv021 fdip_sum_phi(18,iatm) = tuv102 fdip_sum_phi(19,iatm) = tuv012 fdip_sum_phi(20,iatm) = tuv111 end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL return end c c c ############################################################### c ## ## c ## subroutine cmp_to_fmp -- transformation of multipoles ## c ## ## c ############################################################### c c c "cmp_to_fmp" transforms the atomic multipoles from Cartesian c to fractional coordinates c c subroutine cmp_to_fmp (cmp,fmp) use mpole implicit none integer i,j,k,ii real*8 ctf(10,10) real*8 cmp(10,*) real*8 fmp(10,*) c c c find the matrix to convert Cartesian to fractional c call cart_to_frac (ctf) c c apply the transformation to get the fractional multipoles c do ii = 1, npole i = ipole(ii) fmp(1,i) = ctf(1,1) * cmp(1,i) do j = 2, 4 fmp(j,i) = 0.0d0 do k = 2, 4 fmp(j,i) = fmp(j,i) + ctf(j,k)*cmp(k,i) end do end do do j = 5, 10 fmp(j,i) = 0.0d0 do k = 5, 10 fmp(j,i) = fmp(j,i) + ctf(j,k)*cmp(k,i) end do end do end do return end c c c ############################################################ c ## ## c ## subroutine cart_to_frac -- Cartesian to fractional ## c ## ## c ############################################################ c c c "cart_to_frac" computes a transformation matrix to convert c a multipole object in Cartesian coordinates to fractional c c note the multipole components are stored in the condensed c order (m,dx,dy,dz,qxx,qyy,qzz,qxy,qxz,qyz) c c subroutine cart_to_frac (ctf) use boxes use pme implicit none integer i,j,k,m integer i1,i2 integer qi1(6) integer qi2(6) real*8 a(3,3) real*8 ctf(10,10) data qi1 / 1, 2, 3, 1, 1, 2 / data qi2 / 1, 2, 3, 2, 3, 3 / c c c set the reciprocal vector transformation matrix c do i = 1, 3 a(1,i) = dble(nfft1) * recip(i,1) a(2,i) = dble(nfft2) * recip(i,2) a(3,i) = dble(nfft3) * recip(i,3) end do c c get the Cartesian to fractional conversion matrix c do i = 1, 10 do j = 1, 10 ctf(j,i) = 0.0d0 end do end do ctf(1,1) = 1.0d0 do i = 2, 4 do j = 2, 4 ctf(i,j) = a(i-1,j-1) end do end do do i1 = 1, 3 k = qi1(i1) do i2 = 1, 6 i = qi1(i2) j = qi2(i2) ctf(i1+4,i2+4) = a(k,i) * a(k,j) end do end do do i1 = 4, 6 k = qi1(i1) m = qi2(i1) do i2 = 1, 6 i = qi1(i2) j = qi2(i2) ctf(i1+4,i2+4) = a(k,i)*a(m,j) + a(k,j)*a(m,i) end do end do return end c c c ################################################################ c ## ## c ## subroutine fphi_to_cphi -- transformation of potential ## c ## ## c ################################################################ c c c "fphi_to_cphi" transforms the reciprocal space potential from c fractional to Cartesian coordinates c c subroutine fphi_to_cphi (fphi,cphi) use mpole implicit none integer i,j,k,ii real*8 ftc(10,10) real*8 cphi(10,*) real*8 fphi(20,*) c c c find the matrix to convert fractional to Cartesian c call frac_to_cart (ftc) c c apply the transformation to get the Cartesian potential c do ii = 1, npole i = ipole(ii) cphi(1,i) = ftc(1,1) * fphi(1,i) do j = 2, 4 cphi(j,i) = 0.0d0 do k = 2, 4 cphi(j,i) = cphi(j,i) + ftc(j,k)*fphi(k,i) end do end do do j = 5, 10 cphi(j,i) = 0.0d0 do k = 5, 10 cphi(j,i) = cphi(j,i) + ftc(j,k)*fphi(k,i) end do end do end do return end c c c ############################################################ c ## ## c ## subroutine frac_to_cart -- fractional to Cartesian ## c ## ## c ############################################################ c c c "frac_to_cart" computes a transformation matrix to convert c a multipole object in fraction coordinates to Cartesian c c note the multipole components are stored in the condensed c order (m,dx,dy,dz,qxx,qyy,qzz,qxy,qxz,qyz) c c subroutine frac_to_cart (ftc) use boxes use pme implicit none integer i,j,k,m integer i1,i2 integer qi1(6) integer qi2(6) real*8 a(3,3) real*8 ftc(10,10) data qi1 / 1, 2, 3, 1, 1, 2 / data qi2 / 1, 2, 3, 2, 3, 3 / c c c set the reciprocal vector transformation matrix c do i = 1, 3 a(i,1) = dble(nfft1) * recip(i,1) a(i,2) = dble(nfft2) * recip(i,2) a(i,3) = dble(nfft3) * recip(i,3) end do c c get the fractional to Cartesian conversion matrix c do i = 1, 10 do j = 1, 10 ftc(j,i) = 0.0d0 end do end do ftc(1,1) = 1.0d0 do i = 2, 4 do j = 2, 4 ftc(i,j) = a(i-1,j-1) end do end do do i1 = 1, 3 k = qi1(i1) do i2 = 1, 3 i = qi1(i2) ftc(i1+4,i2+4) = a(k,i) * a(k,i) end do do i2 = 4, 6 i = qi1(i2) j = qi2(i2) ftc(i1+4,i2+4) = 2.0d0 * a(k,i) * a(k,j) end do end do do i1 = 4, 6 k = qi1(i1) m = qi2(i1) do i2 = 1, 3 i = qi1(i2) ftc(i1+4,i2+4) = a(k,i) * a(m,i) end do do i2 = 4, 6 i = qi1(i2) j = qi2(i2) ftc(i1+4,i2+4) = a(k,i)*a(m,j) + a(m,i)*a(k,j) end do end do return end c c c ################################################################ c ## COPYRIGHT (C) 2006 by Michael Schnieders & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ############################################################ c ## ## c ## routines below implement dummy versions of the APBS ## c ## calls required for Tinker to interface with the APBS ## c ## Poisson-Boltzmann solver package from Nathan Baker ## c ## ## c ############################################################ c c ############################## c ## ## c ## subroutine apbsinitial ## c ## ## c ############################## c c subroutine apbsinitial (dime,grid,gcent,cgrid,cgcent,fgrid, & fgcent,pdie,sdie,srad,swin,sdens, & kelvin,ionn,ionc,ionq,ionr,pbtyp, & pbtyplen,pbsoln,pbsolnlen,bcfl, & bcfllen,chgm,chgmlen,srfm,srfmlen) use iounit implicit none integer dime(*) integer ionn integer ionq(*) integer pbtyplen integer pbsolnlen integer bcfllen integer chgmlen integer srfmlen real*8 grid(*) real*8 gcent(*) real*8 cgrid(*) real*8 cgcent(*) real*8 fgrid(*) real*8 fgcent(*) real*8 pdie real*8 sdie real*8 srad real*8 swin real*8 sdens real*8 kelvin real*8 ionc(*) real*8 ionr(*) character*(*) pbtyp character*(*) pbsoln character*(*) bcfl character*(*) chgm character*(*) srfm c c c exit with an error message if APBS calculation is attempted c write (iout,10) 10 format (/,' APBSINITIAL -- APBS Not Supported by This', & ' Tinker Version') call fatal return end c c c ############################# c ## ## c ## subroutine apbsempole ## c ## ## c ############################# c c subroutine apbsempole (n,pos,rsolv,pbpole,pbe,apbe,pbep,pbfp,pbtp) implicit none integer n real*8 pos(*) real*8 rsolv(*) real*8 pbpole(*) real*8 pbe real*8 apbe(*) real*8 pbep(*) real*8 pbfp(*) real*8 pbtp(*) return end c c c ############################# c ## ## c ## subroutine apbsinduce ## c ## ## c ############################# c c subroutine apbsinduce (indpole,pbeuind) implicit none real*8 indpole(*) real*8 pbeuind(*) return end c c c ############################### c ## ## c ## subroutine apbsnlinduce ## c ## ## c ############################### c c subroutine apbsnlinduce (inppole,pbeuinp) implicit none real*8 inppole(*) real*8 pbeuinp(*) return end c c c ################################### c ## ## c ## subroutine pbdirectpolforce ## c ## ## c ################################### c c subroutine pbdirectpolforce (indpole,inppole,directf,directt) implicit none real*8 indpole(*) real*8 inppole(*) real*8 directf(*) real*8 directt(*) return end c c c ################################### c ## ## c ## subroutine pbmutualpolforce ## c ## ## c ################################### c c subroutine pbmutualpolforce (indpole,inppole,mutualf) implicit none real*8 indpole(*) real*8 inppole(*) real*8 mutualf(*) return end c c c ############################ c ## ## c ## subroutine apbsfinal ## c ## ## c ############################ c c subroutine apbsfinal implicit none return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module polar -- polarization & induced dipole moments ## c ## ## c ############################################################### c c c npolar total number of polarizable sites in the system c ipolar number of the atom for each polarizable site c jpolar index into polarization parameter matrix for each atom c polarity dipole polarizability for each atom site (Ang**3) c thole Thole polarization damping value for each atom c tholed Thole direct polarization damping value for each atom c pdamp value of polarizability scale factor for each atom c thlval Thole damping parameter value for each atom type pair c thdval alternate Thole direct damping value for atom type pair c udir direct induced dipole components for each atom site c udirp direct induced dipoles in field used for energy terms c udirs direct GK or PB induced dipoles for each atom site c udirps direct induced dipoles in field used for GK or PB energy c uind mutual induced dipole components for each atom site c uinp mutual induced dipoles in field used for energy terms c uinds mutual GK or PB induced dipoles for each atom site c uinps mutual induced dipoles in field used for GK or PB energy c uexact exact SCF induced dipoles to full numerical precision c douind flag to allow induced dipoles at each atom site c c module polar implicit none integer npolar integer, allocatable :: ipolar(:) integer, allocatable :: jpolar(:) real*8, allocatable :: polarity(:) real*8, allocatable :: thole(:) real*8, allocatable :: tholed(:) real*8, allocatable :: pdamp(:) real*8, allocatable :: thlval(:,:) real*8, allocatable :: thdval(:,:) real*8, allocatable :: udir(:,:) real*8, allocatable :: udirp(:,:) real*8, allocatable :: udirs(:,:) real*8, allocatable :: udirps(:,:) real*8, allocatable :: uind(:,:) real*8, allocatable :: uinp(:,:) real*8, allocatable :: uinds(:,:) real*8, allocatable :: uinps(:,:) real*8, allocatable :: uexact(:,:) logical, allocatable :: douind(:) save end c c c ############################################################# c ## COPYRIGHT (C) 2001 by Pengyu Ren & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################# c c ################################################################## c ## ## c ## program polarize -- compute the molecular polarizability ## c ## ## c ################################################################## c c c "polarize" computes the molecular polarizability by applying c an external field along each axis followed by diagonalization c of the resulting polarizability tensor c c program polarize use atoms use inform use iounit use molcul use mpole use polar use polpot use potent implicit none integer i,ii real*8 addu,malpha real*8 external real*8 exfield(3) real*8 umol(3) real*8 umol0(3) real*8 dalpha(3) real*8 alpha(3,3) real*8 valpha(3,3) character*40 fstr c c c get the coordinates and required force field parameters c call initial call getxyz call attach call field call cutoffs call katom call molecule call kmpole call kpolar call kchgtrn call mutate c c sum atomic polarizabilities to get additive molecular value c if (.not. use_polar) then write (iout,10) 10 format (/,' POLARIZE -- Dipole Polarizability', & ' is Not in Use') call fatal end if addu = 0.0d0 do ii = 1, npole i = ipole(ii) addu = polarity(i) + addu end do fstr = ' Additive Total Polarizability : ' if (nmol .eq. 1) fstr = ' Additive Molecular Polarizability :' if (digits .ge. 8) then write (iout,20) fstr(1:36),addu 20 format (/,a36,f20.8) else if (digits .ge. 6) then write (iout,30) fstr(1:36),addu 30 format (/,a36,f18.6) else write (iout,40) fstr(1:36),addu 40 format (/,a36,f16.4) end if c c find induced dipoles in absence of an external field c do i = 1, 3 exfield(i) = 0.0d0 end do call moluind (exfield,umol0) c c compute each column of the polarizability tensor c external = 0.01d0 exfield(1) = external exfield(2) = 0.0d0 exfield(3) = 0.0d0 call moluind (exfield,umol) alpha(1,1) = (umol(1)-umol0(1)) / exfield(1) alpha(2,1) = (umol(2)-umol0(2)) / exfield(1) alpha(3,1) = (umol(3)-umol0(3)) / exfield(1) exfield(1) = 0.0d0 exfield(2) = external exfield(3) = 0.0d0 call moluind (exfield,umol) alpha(1,2) = (umol(1)-umol0(1)) / exfield(2) alpha(2,2) = (umol(2)-umol0(2)) / exfield(2) alpha(3,2) = (umol(3)-umol0(3)) / exfield(2) exfield(1) = 0.0d0 exfield(2) = 0.0d0 exfield(3) = external call moluind (exfield,umol) alpha(1,3) = (umol(1)-umol0(1)) / exfield(3) alpha(2,3) = (umol(2)-umol0(2)) / exfield(3) alpha(3,3) = (umol(3)-umol0(3)) / exfield(3) c c print out the full polarizability tensor c fstr = ' Total Polarizability Tensor : ' if (nmol .eq. 1) fstr = ' Molecular Polarizability Tensor :' write (iout,50) fstr(1:34) 50 format (/,a34,/) if (digits .ge. 8) then write (iout,60) alpha(1,1),alpha(1,2),alpha(1,3), & alpha(2,1),alpha(2,2),alpha(2,3), & alpha(3,1),alpha(3,2),alpha(3,3) 60 format (13x,3f17.8,/,13x,3f17.8,/,13x,3f17.8) else if (digits .ge. 6) then write (iout,70) alpha(1,1),alpha(1,2),alpha(1,3), & alpha(2,1),alpha(2,2),alpha(2,3), & alpha(3,1),alpha(3,2),alpha(3,3) 70 format (13x,3f15.6,/,13x,3f15.6,/,13x,3f15.6) else write (iout,80) alpha(1,1),alpha(1,2),alpha(1,3), & alpha(2,1),alpha(2,2),alpha(2,3), & alpha(3,1),alpha(3,2),alpha(3,3) 80 format (13x,3f13.4,/,13x,3f13.4,/,13x,3f13.4) end if c c diagonalize the tensor and get molecular polarizability c call jacobi (3,alpha,dalpha,valpha) fstr = ' Polarizability Tensor Eigenvalues :' write (iout,90) fstr(1:36) 90 format (/,a36,/) if (digits .ge. 8) then write (iout,100) dalpha(1),dalpha(2),dalpha(3) 100 format (13x,3f17.8) else if (digits .ge. 6) then write (iout,110) dalpha(1),dalpha(2),dalpha(3) 110 format (13x,3f15.6) else write (iout,120) dalpha(1),dalpha(2),dalpha(3) 120 format (13x,3f13.4) end if malpha = (dalpha(1)+dalpha(2)+dalpha(3)) / 3.0d0 fstr = ' Interactive Total Polarizability : ' if (nmol .eq. 1) fstr = ' Interactive Molecular Polarizability :' if (digits .ge. 8) then write (iout,130) fstr(1:39),malpha 130 format (/,a39,f17.8) else if (digits .ge. 6) then write (iout,140) fstr(1:39),malpha 140 format (/,a39,f15.6) else write (iout,150) fstr(1:39),malpha 150 format (/,a39,f13.4) end if c c perform any final tasks before program exit c call final end c c c ################################################################# c ## ## c ## subroutine moluind -- molecular induced dipole in field ## c ## ## c ################################################################# c c c "moluind" computes the molecular induced dipole components c in the presence of an external electric field c c subroutine moluind (exfield,umol) use atoms use inform use iounit use mpole use polar use polopt use polpcg use polpot use units implicit none integer i,j,k integer ii,iter integer maxiter real*8 eps,epsold real*8 polmin real*8 a,b,sum,term real*8 norm,exmax real*8 umol(3) real*8 exfield(3) real*8, allocatable :: poli(:) real*8, allocatable :: field(:,:) real*8, allocatable :: fieldp(:,:) real*8, allocatable :: rsd(:,:) real*8, allocatable :: zrsd(:,:) real*8, allocatable :: conj(:,:) real*8, allocatable :: vec(:,:) real*8, allocatable :: usum(:,:) logical header,done logical dodfield c c c perform dynamic allocation of some local arrays c allocate (poli(n)) allocate (field(3,n)) allocate (fieldp(3,n)) allocate (rsd(3,n)) allocate (zrsd(3,n)) allocate (conj(3,n)) allocate (vec(3,n)) c c check for chiral multipoles and rotate to global frame c call chkpole call rotpole ('MPOLE') c c zero out the value of the field at each site c do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = 0.0d0 fieldp(j,i) = 0.0d0 end do end do c c get the electrostatic field due to permanent multipoles c dodfield = .true. if (dodfield) call dfield0a (field,fieldp) c c set induced dipoles to polarizability times direct field c do ii = 1, npole i = ipole(ii) do j = 1, 3 udir(j,i) = polarity(i) * field(j,i) end do end do c c increment induced dipoles to account for external field c do ii = 1, npole i = ipole(ii) do j = 1, 3 udir(j,i) = udir(j,i) + polarity(i)*exfield(j) uind(j,i) = udir(j,i) end do end do c c get induced dipoles via the OPT extrapolation method c if (poltyp .eq. 'OPT') then do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uopt(0,j,i) = udir(j,i) end do end if end do do k = 1, optorder optlevel = k - 1 call ufield0a (field,fieldp) do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uopt(k,j,i) = polarity(i) * field(j,i) uind(j,i) = uopt(k,j,i) end do end if end do end do allocate (usum(3,n)) do ii = 1, npole i = ipole(ii) if (douind(i)) then do j = 1, 3 uind(j,i) = 0.0d0 usum(j,i) = 0.0d0 do k = 0, optorder usum(j,i) = usum(j,i) + uopt(k,j,i) uind(j,i) = uind(j,i) + copt(k)*usum(j,i) end do end do end if end do deallocate (usum) end if c c compute mutual induced dipole moments via CG algorithm c if (poltyp .eq. 'MUTUAL') then done = .false. maxiter = 500 iter = 0 polmin = 0.00000001d0 eps = 100.0d0 call ufield0a (field,fieldp) do ii = 1, npole i = ipole(ii) poli(i) = max(polmin,polarity(i)) do j = 1, 3 rsd(j,i) = field(j,i) zrsd(j,i) = rsd(j,i) * poli(i) conj(j,i) = zrsd(j,i) end do end do c c iterate the mutual induced dipoles and check convergence c do while (.not. done) iter = iter + 1 do ii = 1, npole i = ipole(ii) do j = 1, 3 vec(j,i) = uind(j,i) uind(j,i) = conj(j,i) end do end do call ufield0a (field,fieldp) do ii = 1, npole i = ipole(ii) do j = 1, 3 uind(j,i) = vec(j,i) vec(j,i) = conj(j,i)/poli(i) - field(j,i) end do end do a = 0.0d0 sum = 0.0d0 do ii = 1, npole i = ipole(ii) do j = 1, 3 a = a + conj(j,i)*vec(j,i) sum = sum + rsd(j,i)*zrsd(j,i) end do end do if (a .ne. 0.0d0) a = sum / a do ii = 1, npole i = ipole(ii) do j = 1, 3 uind(j,i) = uind(j,i) + a*conj(j,i) rsd(j,i) = rsd(j,i) - a*vec(j,i) end do end do b = 0.0d0 do ii = 1, npole i = ipole(ii) do j = 1, 3 zrsd(j,i) = rsd(j,i) * poli(i) b = b + rsd(j,i)*zrsd(j,i) end do end do if (sum .ne. 0.0d0) b = b / sum eps = 0.0d0 do ii = 1, npole i = ipole(ii) do j = 1, 3 conj(j,i) = zrsd(j,i) + b*conj(j,i) eps = eps + rsd(j,i)*rsd(j,i) end do end do eps = debye * sqrt(eps/dble(npolar)) epsold = eps if (debug) then if (iter .eq. 1) then write (iout,10) 10 format (/,' Determination of Induced Dipole', & ' Moments :', & //,4x,'Iter',8x,'RMS Change (Debye)',/) end if write (iout,20) iter,eps 20 format (i8,7x,f16.10) end if if (eps .lt. poleps) done = .true. if (eps .gt. epsold) done = .true. if (iter .ge. politer) done = .true. c c apply a "peek" iteration to the mutual induced dipoles c if (done) then do ii = 1, npole i = ipole(ii) if (douind(i)) then term = pcgpeek * poli(i) do j = 1, 3 uind(j,i) = uind(j,i) + term*rsd(j,i) end do end if end do end if end do c c print a warning if induced dipoles failed to converge c if (iter.ge.maxiter .or. eps.gt.epsold) then write (iout,30) 30 format (/,' MOLUIND -- Warning, Induced Dipoles', & ' are not Converged') call fatal end if end if c c sum up the total molecular induced dipole components c do j = 1, 3 umol(j) = 0.0d0 end do do ii = 1, npole i = ipole(ii) umol(1) = umol(1) + uind(1,i) umol(2) = umol(2) + uind(2,i) umol(3) = umol(3) + uind(3,i) end do c c print out a list of the final induced dipole moments c if (verbose) then exmax = max(exfield(1),exfield(2),exfield(3)) if (dodfield .or. exmax.ne.0.0d0) then write (iout,40) (exfield(j),j=1,3) 40 format (/,' Applied External Field :',//,13x,3f13.4) header = .true. do ii = 1, npole i = ipole(ii) if (polarity(i) .ne. 0.0d0) then if (header) then header = .false. write (iout,50) 50 format (/,' Induced Dipole Moments (Debye) :') write (iout,60) 60 format (/,4x,'Atom',15x,'X',12x,'Y',12x,'Z', & 11x,'Total',/) end if norm = sqrt(uind(1,i)**2+uind(2,i)**2+uind(3,i)**2) write (iout,70) i,(debye*uind(j,i),j=1,3), & debye*norm 70 format (i8,5x,3f13.4,1x,f13.4) end if end do end if end if c c perform deallocation of some local arrays c deallocate (poli) deallocate (field) deallocate (fieldp) deallocate (rsd) deallocate (zrsd) deallocate (conj) deallocate (vec) return end c c c ################################################################ c ## COPYRIGHT (C) 2000 by P. Bagossi, P. Ren & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ############################################################### c ## ## c ## program poledit -- manipulate atomic multipole values ## c ## ## c ############################################################### c c c "poledit" provides for the modification and manipulation c of polarizable atomic multipole electrostatic models c c program poledit use iounit use potent implicit none integer nmode,mode integer idma,ichg,imbis integer freeunit logical exist,query character*240 string c c c get the desired type of coordinate file modification c call initial nmode = 4 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 Multipole Editing Utility Can :', & //,4x,'(1) Use Multipoles from Stone GDMA Output', & /,4x,'(2) Use Multipoles from Multiwfn MBIS Output', & /,4x,'(3) Alter Local Coordinate Frame Definitions', & /,4x,'(4) Remove the Intramolecular Polarization') do while (mode.lt.1 .or. mode.gt.nmode) 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 perform the desired multipole manipulation operation c if (mode .eq. 1) then idma = freeunit () use_mpole = .true. use_polar = .true. call readgdma (idma) call field call molsetup call setframe call rotframe call setpolar call setpgrp call alterpol call avgpole call prtpole else if (mode .eq. 2) then ichg = freeunit () imbis = freeunit () use_mpole = .true. use_polar = .true. call readmbis (ichg,imbis) call field call molsetup call setframe call rotframe call setpolar call setpgrp call alterpol call avgpole call prtpole else if (mode .eq. 3) then call getxyz call attach call field call katom call kmpole call kpolar call kchgtrn call fixframe call prtpole else if (mode .eq. 4) then call getxyz call attach call field call katom call kmpole call kpolar call kchgtrn call alterpol call avgpole call prtpole end if end c c c ############################################################## c ## ## c ## subroutine molsetup -- set molecule for polarization ## c ## ## c ############################################################## c c c "molsetup" generates trial parameters needed to perform c polarizable multipole calculations on a structure read c from distributed multipole analysis output c c subroutine molsetup use atomid use atoms use couple use files use kpolr use mpole use polar use ptable implicit none integer i,j integer atn,size real*8 xi,yi,zi real*8 xr,yr,zr real*8 ri,rij,dij real*8, allocatable :: rad(:) c c c perform dynamic allocation of some local arrays c allocate (rad(n)) c c set base atomic radii from covalent radius values c do i = 1, n rad(i) = 0.76d0 atn = atomic(i) if (atn .ne. 0) rad(i) = covrad(atn) if (atn .eq. 1) then rad(i) = 1.25d0 * rad(i) else if (atn .eq. 9) then rad(i) = 1.25d0 * rad(i) else rad(i) = 1.15d0 * rad(i) end if end do c c assign atom connectivities based on interatomic distances c do i = 1, n n12(i) = 0 do j = 1, maxval i12(j,i) = 0 end do end do do i = 1, n-1 xi = x(i) yi = y(i) zi = z(i) ri = rad(i) do j = i+1, n xr = x(j) - xi yr = y(j) - yi zr = z(j) - zi rij = ri + rad(j) dij = sqrt(xr*xr + yr*yr + zr*zr) if (dij .lt. rij) then n12(i) = n12(i) + 1 i12(n12(i),i) = j n12(j) = n12(j) + 1 i12(n12(j),j) = i end if end do end do do i = 1, n call sort (n12(i),i12(1,i)) end do c c find the bonds, angles, torsions and small rings c call attach call bonds call angles call torsions call bitors call rings c c perform deallocation of some local arrays c deallocate (rad) c c assign unique atom types and set the valence values c size = min(24,leng) do i = 1, n type(i) = i class(i) = i valence(i) = n12(i) story(i) = filename(1:size) end do c c assign the standard atomic weight by atomic number c do i = 1, n mass(i) = 1.0d0 atn = atomic(i) if (atn .ne. 0) mass(i) = atmass(atn) end do c c perform dynamic allocation of some global arrays c if (.not. allocated(ipole)) allocate (ipole(n)) if (.not. allocated(polsiz)) allocate (polsiz(n)) if (.not. allocated(pollist)) allocate (pollist(n)) c c set atomic multipole sites and polarizability indices c npole = n npolar = n do i = 1, n ipole(i) = i polsiz(i) = 13 pollist(i) = i end do c c zero out polarization group membership by atom type c do i = 1, maxtyp do j = 1, maxval pgrp(j,i) = 0 end do end do return end c c c ############################################################### c ## ## c ## subroutine setframe -- define local coordinate frames ## c ## ## c ############################################################### c c c "setframe" assigns a local coordinate frame at each atomic c multipole site using high priority connected atoms along axes c c subroutine setframe use atomid use atoms use couple use iounit use mpole implicit none integer i,j,m,ii integer ia,ib,ic,id integer ka,kb,kc,ki integer mab,mac,mbc integer mad,mbd,mcd integer mabc,mabd integer macd,mbcd integer priority real*8 geometry logical exist,query logical change logical noinvert logical planar logical pyramid logical chkarom character*240 record character*240 string external chkarom c c c perform dynamic allocation of some global arrays c if (.not. allocated(zaxis)) allocate (zaxis(n)) if (.not. allocated(xaxis)) allocate (xaxis(n)) if (.not. allocated(yaxis)) allocate (yaxis(n)) if (.not. allocated(polaxe)) allocate (polaxe(n)) c c initialize the local frame type and defining atoms c do i = 1, n polaxe(i) = 'None' zaxis(i) = 0 xaxis(i) = 0 yaxis(i) = 0 end do c c set true if pyramidal trivalent nitrogen cannot invert c noinvert = .true. c c assign the local frame definition for an isolated atom c do ii = 1, npole i = ipole(ii) j = n12(i) if (j .eq. 0) then polaxe(i) = 'None' zaxis(i) = 0 xaxis(i) = 0 yaxis(i) = 0 c c assign the local frame definition for a monovalent atom c else if (j .eq. 1) then polaxe(i) = 'Z-Only' zaxis(i) = ia xaxis(i) = 0 yaxis(i) = 0 ia = i12(1,i) call frame13 (i,ia,noinvert) c c assign the local frame definition for a divalent atom c else if (j .eq. 2) then ia = i12(1,i) ib = i12(2,i) ki = atomic(i) yaxis(i) = 0 m = priority (i,ia,ib,0) if (ki .eq. 6) then polaxe(i) = 'Z-Only' zaxis(i) = m if (m .eq. 0) zaxis(i) = ia xaxis(i) = 0 else if (m .eq. ia) then polaxe(i) = 'Z-then-X' zaxis(i) = ia xaxis(i) = ib else if (m .eq. ib) then polaxe(i) = 'Z-then-X' zaxis(i) = ib xaxis(i) = ia else polaxe(i) = 'Bisector' zaxis(i) = ia xaxis(i) = ib end if c c assign the local frame definition for a trivalent atom c else if (j .eq. 3) then ia = i12(1,i) ib = i12(2,i) ic = i12(3,i) ki = atomic(i) ka = atomic(ia) kb = atomic(ib) kc = atomic(ic) mab = priority (i,ia,ib,0) mac = priority (i,ia,ic,0) mbc = priority (i,ib,ic,0) mabc = priority (i,ia,ib,ic) planar = (abs(geometry(ic,i,ia,ib)) .gt. 170.0d0) pyramid = (abs(geometry(ic,i,ia,ib)) .lt. 135.0d0) if (ki .eq. 7) then if (chkarom(i)) pyramid = .false. if (chkarom(ia)) pyramid = .false. if (chkarom(ib)) pyramid = .false. if (chkarom(ic)) pyramid = .false. end if pyramid = (pyramid .and. noinvert) if (mabc .eq. 0) then polaxe(i) = 'None' zaxis(i) = 0 xaxis(i) = 0 yaxis(i) = 0 if (ki.eq.7 .and. pyramid) then polaxe(i) = '3-Fold' zaxis(i) = ia xaxis(i) = ib yaxis(i) = ic else if (ki.eq.15 .or. ki.eq.16) then polaxe(i) = '3-Fold' zaxis(i) = ia xaxis(i) = ib yaxis(i) = ic end if else if (mab.eq.0 .and. (planar.or.kb.ge.kc)) then polaxe(i) = 'Bisector' zaxis(i) = ia xaxis(i) = ib yaxis(i) = 0 if (ki.eq.7 .and. pyramid) then polaxe(i) = 'Z-Bisect' zaxis(i) = ic xaxis(i) = ia yaxis(i) = ib else if (ki.eq.15 .or. ki.eq.16) then polaxe(i) = 'Z-Bisect' zaxis(i) = ic xaxis(i) = ia yaxis(i) = ib end if else if (mac.eq.0 .and. (planar.or.ka.ge.kb)) then polaxe(i) = 'Bisector' zaxis(i) = ia xaxis(i) = ic yaxis(i) = 0 if (ki.eq.7 .and. pyramid) then polaxe(i) = 'Z-Bisect' zaxis(i) = ib xaxis(i) = ia yaxis(i) = ic else if (ki.eq.15 .or. ki.eq.16) then polaxe(i) = 'Z-Bisect' zaxis(i) = ib xaxis(i) = ia yaxis(i) = ic end if else if (mbc.eq.0 .and. (planar.or.kc.ge.ka)) then polaxe(i) = 'Bisector' zaxis(i) = ib xaxis(i) = ic yaxis(i) = 0 if (ki.eq.7 .and. pyramid) then polaxe(i) = 'Z-Bisect' zaxis(i) = ia xaxis(i) = ib yaxis(i) = ic else if (ki.eq.15 .or. ki.eq.16) then polaxe(i) = 'Z-Bisect' zaxis(i) = ia xaxis(i) = ib yaxis(i) = ic end if else if (mabc .eq. ia) then polaxe(i) = 'Z-Only' zaxis(i) = ia xaxis(i) = 0 yaxis(i) = 0 if (ki.eq.7 .and. pyramid) then polaxe(i) = 'Z-Bisect' xaxis(i) = ib yaxis(i) = ic else if (ki.eq.15 .or. ki.eq.16) then polaxe(i) = 'Z-Bisect' xaxis(i) = ib yaxis(i) = ic else if (mbc .eq. ib) then polaxe(i) = 'Z-then-X' xaxis(i) = ib else if (mbc .eq. ic) then polaxe(i) = 'Z-then-X' xaxis(i) = ic else if (ki .eq. 6) then polaxe(i) = 'Z-then-X' xaxis(i) = ib else if (ki.eq.7 .and. .not.pyramid) then polaxe(i) = 'Z-then-X' xaxis(i) = ib else call frame13 (i,ia,noinvert) end if else if (mabc .eq. ib) then polaxe(i) = 'Z-Only' zaxis(i) = ib xaxis(i) = 0 yaxis(i) = 0 if (ki.eq.7 .and. pyramid) then polaxe(i) = 'Z-Bisect' xaxis(i) = ia yaxis(i) = ic else if (ki.eq.15 .or. ki.eq.16) then polaxe(i) = 'Z-Bisect' xaxis(i) = ia yaxis(i) = ic else if (mac .eq. ia) then polaxe(i) = 'Z-then-X' xaxis(i) = ia else if (mac .eq. ic) then polaxe(i) = 'Z-then-X' xaxis(i) = ic else if (ki .eq. 6) then polaxe(i) = 'Z-then-X' xaxis(i) = ia else if (ki.eq.7 .and. .not.pyramid) then polaxe(i) = 'Z-then-X' xaxis(i) = ia else call frame13 (i,ib,noinvert) end if else if (mabc .eq. ic) then polaxe(i) = 'Z-Only' zaxis(i) = ic xaxis(i) = 0 yaxis(i) = 0 if (ki.eq.7 .and. pyramid) then polaxe(i) = 'Z-Bisect' xaxis(i) = ia yaxis(i) = ib else if (ki.eq.15 .or. ki.eq.16) then polaxe(i) = 'Z-Bisect' xaxis(i) = ia yaxis(i) = ib else if (mab .eq. ia) then polaxe(i) = 'Z-then-X' xaxis(i) = ia else if (mab .eq. ib) then polaxe(i) = 'Z-then-X' xaxis(i) = ib else if (ki .eq. 6) then polaxe(i) = 'Z-then-X' xaxis(i) = ia else if (ki.eq.7 .and. .not.pyramid) then polaxe(i) = 'Z-then-X' xaxis(i) = ia else call frame13 (i,ic,noinvert) end if end if c c assign the local frame definition for a tetravalent atom c else if (j .eq. 4) then ia = i12(1,i) ib = i12(2,i) ic = i12(3,i) id = i12(4,i) mab = priority (i,ia,ib,0) mac = priority (i,ia,ic,0) mbc = priority (i,ib,ic,0) mad = priority (i,ia,id,0) mbd = priority (i,ib,id,0) mcd = priority (i,ic,id,0) mabc = priority (i,ia,ib,ic) mabd = priority (i,ia,ib,id) macd = priority (i,ia,ic,id) mbcd = priority (i,ib,ic,id) if (mabc.eq.0 .and. mbcd.eq.0) then polaxe(i) = 'None' zaxis(i) = 0 xaxis(i) = 0 yaxis(i) = 0 else if (mabc.eq.ia .and. mabd.eq.ia) then polaxe(i) = 'Z-then-X' zaxis(i) = ia yaxis(i) = 0 if (mbcd .ne. 0) then xaxis(i) = mbcd else call frame13 (i,ia,noinvert) end if else if (mabc.eq.ib .and. mabd.eq.ib) then polaxe(i) = 'Z-then-X' zaxis(i) = ib yaxis(i) = 0 if (macd .ne. 0) then xaxis(i) = macd else call frame13 (i,ib,noinvert) end if else if (mabc.eq.ia .and. macd.eq.ia) then polaxe(i) = 'Z-then-X' zaxis(i) = ia yaxis(i) = 0 if (mbcd .ne. 0) then xaxis(i) = mbcd else call frame13 (i,ia,noinvert) end if else if (mabc.eq.ic .and. macd.eq.ic) then polaxe(i) = 'Z-then-X' zaxis(i) = ic yaxis(i) = 0 if (mabd .ne. 0) then xaxis(i) = mabd else call frame13 (i,ic,noinvert) end if else if (mabc.eq.ib .and. mbcd.eq.ib) then polaxe(i) = 'Z-then-X' zaxis(i) = ib yaxis(i) = 0 if (macd .ne. 0) then xaxis(i) = macd else call frame13 (i,ib,noinvert) end if else if (mabc.eq.ic .and. mbcd.eq.ic) then polaxe(i) = 'Z-then-X' zaxis(i) = ic yaxis(i) = 0 if (mabd .ne. 0) then xaxis(i) = mabd else call frame13 (i,ic,noinvert) end if else if (mabd.eq.ia .and. macd.eq.ia) then polaxe(i) = 'Z-then-X' zaxis(i) = ia yaxis(i) = 0 if (mbcd .ne. 0) then xaxis(i) = mbcd else call frame13 (i,ia,noinvert) end if else if (mabd.eq.id .and. macd.eq.id) then polaxe(i) = 'Z-then-X' zaxis(i) = id yaxis(i) = 0 if (mabc .ne. 0) then xaxis(i) = mabc else call frame13 (i,id,noinvert) end if else if (mabd.eq.ib .and. mbcd.eq.ib) then polaxe(i) = 'Z-then-X' zaxis(i) = ib yaxis(i) = 0 if (macd .ne. 0) then xaxis(i) = macd else call frame13 (i,ib,noinvert) end if else if (mabd.eq.id .and. mbcd.eq.id) then polaxe(i) = 'Z-then-X' zaxis(i) = id yaxis(i) = 0 if (mabc .ne. 0) then xaxis(i) = mabc else call frame13 (i,id,noinvert) end if else if (macd.eq.ic .and. mbcd.eq.ic) then polaxe(i) = 'Z-then-X' zaxis(i) = ic yaxis(i) = 0 if (mabd .ne. 0) then xaxis(i) = mabd else call frame13 (i,ic,noinvert) end if else if (macd.eq.id .and. mbcd.eq.id) then polaxe(i) = 'Z-then-X' zaxis(i) = id yaxis(i) = 0 if (mabc .ne. 0) then xaxis(i) = mabc else call frame13 (i,id,noinvert) end if else if (mbcd .eq. 0) then polaxe(i) = 'Z-Only' zaxis(i) = ia xaxis(i) = 0 yaxis(i) = 0 call frame13 (i,ia,noinvert) else if (macd .eq. 0) then polaxe(i) = 'Z-Only' zaxis(i) = ib xaxis(i) = 0 yaxis(i) = 0 call frame13 (i,ib,noinvert) else if (mabd .eq. 0) then polaxe(i) = 'Z-Only' zaxis(i) = ic xaxis(i) = 0 yaxis(i) = 0 call frame13 (i,ic,noinvert) else if (mabc .eq. 0) then polaxe(i) = 'Z-Only' zaxis(i) = id xaxis(i) = 0 yaxis(i) = 0 call frame13 (i,id,noinvert) else if (mab.eq.0 .and. mcd.eq.0) then if (mac .eq. ia) then polaxe(i) = 'Bisector' zaxis(i) = ia xaxis(i) = ib yaxis(i) = 0 else if (mac .eq. ic) then polaxe(i) = 'Bisector' zaxis(i) = ic xaxis(i) = id yaxis(i) = 0 end if else if (mac.eq.0 .and. mbd.eq.0) then if (mab .eq. ia) then polaxe(i) = 'Bisector' zaxis(i) = ia xaxis(i) = ic yaxis(i) = 0 else if (mab .eq. ib) then polaxe(i) = 'Bisector' zaxis(i) = ib xaxis(i) = id yaxis(i) = 0 end if else if (mad.eq.0 .and. mbc.eq.0) then if (mab .eq. ia) then polaxe(i) = 'Bisector' zaxis(i) = ia xaxis(i) = id yaxis(i) = 0 else if (mab .eq. ib) then polaxe(i) = 'Bisector' zaxis(i) = ib xaxis(i) = ic yaxis(i) = 0 end if else if (mab .eq. 0) then polaxe(i) = 'Z-Bisect' zaxis(i) = mcd xaxis(i) = ia yaxis(i) = ib else if (mac .eq. 0) then polaxe(i) = 'Z-Bisect' zaxis(i) = mbd xaxis(i) = ia yaxis(i) = ic else if (mad .eq. 0) then polaxe(i) = 'Z-Bisect' zaxis(i) = mbc xaxis(i) = ia yaxis(i) = id else if (mbc .eq. 0) then polaxe(i) = 'Z-Bisect' zaxis(i) = mad xaxis(i) = ib yaxis(i) = ic else if (mbd .eq. 0) then polaxe(i) = 'Z-Bisect' zaxis(i) = mac xaxis(i) = ib yaxis(i) = id else if (mcd .eq. 0) then polaxe(i) = 'Z-Bisect' zaxis(i) = mab xaxis(i) = ic yaxis(i) = id end if end if end do c c list the local frame definition for each multipole site c write (iout,10) 10 format (/,' Local Frame Definition for Multipole Sites :') write (iout,20) 20 format (/,5x,'Atom',5x,'Name',6x,'Axis Type',5x,'Z Axis', & 2x,'X Axis',2x,'Y Axis',/) do ii = 1, npole i = ipole(ii) write (iout,30) i,name(i),polaxe(i),zaxis(i), & xaxis(i),yaxis(i) 30 format (i8,6x,a3,7x,a8,2x,3i8) end do c c allow the user to manually alter local coordinate frames c change = .false. query = .true. i = -1 call nextarg (string,exist) if (exist) then read (string,*,err=40,end=40) i if (i .eq. 0) query = .false. end if 40 continue do while (query) i = 0 ia = 0 ib = 0 ic = 0 write (iout,50) 50 format (/,' Enter Altered Local Frame Definition', & ' [=Exit] : ',$) read (input,60) record 60 format (a240) read (record,*,err=70,end=70) i,ia,ib,ic 70 continue if (i .eq. 0) then query = .false. else change = .true. if (ia .eq. 0) polaxe(i)= 'None' if (ia.ne.0 .and. ib.eq.0) polaxe(i) = 'Z-Only' if (ia.gt.0 .and. ib.gt.0) polaxe(i) = 'Z-then-X' if (ia.lt.0 .or. ib.lt.0) polaxe(i) = 'Bisector' if (ib.lt.0 .and. ic.lt.0) polaxe(i) = 'Z-Bisect' if (max(ia,ib,ic) .lt. 0) polaxe(i) = '3-Fold' zaxis(i) = abs(ia) xaxis(i) = abs(ib) yaxis(i) = abs(ic) end if end do c c repeat local frame list if definitions were altered c if (change) then write (iout,80) 80 format (/,' Local Frame Definition for Multipole Sites :') write (iout,90) 90 format (/,5x,'Atom',5x,'Name',6x,'Axis Type',5x,'Z Axis', & 2x,'X Axis',2x,'Y Axis',/) do ii = 1, npole i = ipole(ii) write (iout,100) i,name(i),polaxe(i),zaxis(i), & xaxis(i),yaxis(i) 100 format (i8,6x,a3,7x,a8,2x,3i8) end do end if return end c c c ################################################################## c ## ## c ## subroutine frame13 -- set local axis via 1-3 attachments ## c ## ## c ################################################################## c c c "frame13" finds local coordinate frame defining atoms in cases c where the use of 1-3 connected atoms is required c c subroutine frame13 (i,ia,noinvert) use atomid use couple use mpole implicit none integer i,j,ia integer ib,ic,id integer ka,m integer priority real*8 geometry logical noinvert logical monoval logical pyramid c c c initialize 1-2 and 1-3 connected atoms c ib = 0 ic = 0 id = 0 ka = atomic(ia) monoval = (n12(i) .eq. 1) c c get atoms directly adjacent to the primary connected atom c do j = 1, n12(ia) m = i12(j,ia) if (m .ne. i) then if (ib .eq. 0) then ib = m else if (ic .eq. 0) then ic = m else if (id .eq. 0) then id = m end if end if end do c c case with no atoms attached 1-3 through primary connection c if (n12(ia) .eq. 1) then polaxe(i) = 'Z-Only' zaxis(i) = ia xaxis(i) = 0 yaxis(i) = 0 c c only one atom is attached 1-3 through primary connection c else if (n12(ia) .eq. 2) then polaxe(i) = 'Z-then-X' zaxis(i) = ia xaxis(i) = ib yaxis(i) = 0 if (ka .eq. 6) then polaxe(i) = 'Z-Only' xaxis(i) = 0 end if c c two atoms are attached 1-3 through primary connection c else if (n12(ia) .eq. 3) then polaxe(i) = 'Z-Only' zaxis(i) = ia xaxis(i) = 0 yaxis(i) = 0 pyramid = (abs(geometry(i,ia,ib,ic)) .lt. 135.0d0) m = priority (ia,ib,ic,0) if (ka.eq.7 .and. pyramid .and. noinvert .and. monoval) then polaxe(i) = 'Z-Bisect' xaxis(i) = ib yaxis(i) = ic else if ((ka.eq.15.or.ka.eq.16) .and. monoval) then polaxe(i) = 'Z-Bisect' xaxis(i) = ib yaxis(i) = ic else if (m .ne. 0) then polaxe(i) = 'Z-then-X' xaxis(i) = m else if (ka .eq. 6) then polaxe(i) = 'Z-then-X' xaxis(i) = ib else if (ka.eq.7 .and. .not.pyramid) then polaxe(i) = 'Z-then-X' xaxis(i) = ib end if c c three atoms are attached 1-3 through primary connection c else if (n12(ia) .eq. 4) then polaxe(i) = 'Z-Only' zaxis(i) = ia xaxis(i) = 0 yaxis(i) = 0 m = priority (ia,ib,ic,id) if (m .ne. 0) then polaxe(i) = 'Z-then-X' xaxis(i) = m end if end if return end c c c ################################################################ c ## ## c ## function priority -- atom priority for axis assignment ## c ## ## c ################################################################ c c c "priority" decides which of a set of connected atoms should c have highest priority in construction of a local coordinate c frame and returns its atom number; if all atoms are of equal c priority then zero is returned c c function priority (i,ia,ib,ic) use atomid use couple implicit none integer i,j integer nlink integer ia,ib,ic integer ja,jb,jc integer ka,kb,kc integer ma,mb,mc integer priority c c c get info on sites to consider for priority assignment c priority = 0 nlink = 0 if (ia .gt. 0) then nlink = nlink + 1 ja = n12(ia) ka = atomic(ia) end if if (ib .gt. 0) then nlink = nlink + 1 jb = n12(ib) kb = atomic(ib) end if if (ic .gt. 0) then nlink = nlink + 1 jc = n12(ic) kc = atomic(ic) end if c c for only one linked atom, it has the highest priority c if (nlink .eq. 1) then priority = ia end if c c for two linked atoms, find the one with highest priority c if (nlink .eq. 2) then if (ka .gt. kb) then priority = ia else if (kb .gt. ka) then priority = ib else if (ja .lt. jb) then priority = ia else if (jb .lt. ja) then priority = ib else ma = 0 mb = 0 do j = 1, ja ma = ma + atomic(i12(j,ia)) mb = mb + atomic(i12(j,ib)) end do if (ma .gt. mb) then priority = ia else if (mb .gt. ma) then priority = ib else ma = 0 mb = 0 do j = 1, n13(ia) ma = ma + atomic(i13(j,ia)) end do do j = 1, n13(ib) mb = mb + atomic(i13(j,ib)) end do if (ma .gt. mb) then priority = ia else if (mb .gt. ma) then priority = ib else ma = 0 mb = 0 do j = 1, n14(ia) ma = ma + atomic(i14(j,ia)) end do do j = 1, n14(ib) mb = mb + atomic(i14(j,ib)) end do if (ma .gt. mb) then priority = ia else if (mb .gt. ma) then priority = ib else ma = 0 mb = 0 do j = 1, n15(ia) ma = ma + atomic(i15(j,ia)) end do do j = 1, n15(ib) mb = mb + atomic(i15(j,ib)) end do if (ma .gt. mb) then priority = ia else if (mb .gt. ma) then priority = ib else priority = 0 end if end if end if end if end if end if end if c c for three linked atoms, find the one with highest priority c if (nlink .eq. 3) then if (ka.gt.kb .and. ka.gt.kc) then priority = ia else if (kb.gt.ka .and. kb.gt.kc) then priority = ib else if (kc.gt.ka .and. kc.gt.kb) then priority = ic else if (ka.eq.kb .and. kc.lt.ka) then if (ja .lt. jb) then priority = ia else if (jb .lt. ja) then priority = ib else ma = 0 mb = 0 do j = 1, ja ma = ma + atomic(i12(j,ia)) mb = mb + atomic(i12(j,ib)) end do if (ma .gt. mb) then priority = ia else if (mb .gt. ma) then priority = ib else ma = 0 mb = 0 do j = 1, n13(ia) ma = ma + atomic(i13(j,ia)) end do do j = 1, n13(ib) mb = mb + atomic(i13(j,ib)) end do if (ma .gt. mb) then priority = ia else if (mb .gt. ma) then priority = ib else ma = 0 mb = 0 do j = 1, n14(ia) ma = ma + atomic(i14(j,ia)) end do do j = 1, n14(ib) mb = mb + atomic(i14(j,ib)) end do if (ma .gt. mb) then priority = ia else if (mb .gt. ma) then priority = ib else ma = 0 mb = 0 do j = 1, n15(ia) ma = ma + atomic(i15(j,ia)) end do do j = 1, n15(ib) mb = mb + atomic(i15(j,ib)) end do if (ma .gt. mb) then priority = ia else if (mb .gt. ma) then priority = ib else priority = ic end if end if end if end if end if else if (ka.eq.kc .and. kb.lt.kc) then if (ja .lt. jc) then priority = ia else if (jc .lt. ja) then priority = ic else ma = 0 mc = 0 do j = 1, ja ma = ma + atomic(i12(j,ia)) mc = mc + atomic(i12(j,ic)) end do if (ma .gt. mc) then priority = ia else if (mc .gt. ma) then priority = ic else ma = 0 mc = 0 do j = 1, n13(ia) ma = ma + atomic(i13(j,ia)) end do do j = 1, n13(ic) mc = mc + atomic(i13(j,ic)) end do if (ma .gt. mc) then priority = ia else if (mc .gt. ma) then priority = ic else ma = 0 mc = 0 do j = 1, n14(ia) ma = ma + atomic(i14(j,ia)) end do do j = 1, n14(ic) mc = mc + atomic(i14(j,ic)) end do if (ma .gt. mc) then priority = ia else if (mc .gt. ma) then priority = ic else ma = 0 mc = 0 do j = 1, n15(ia) ma = ma + atomic(i15(j,ia)) end do do j = 1, n15(ic) mc = mc + atomic(i15(j,ic)) end do if (ma .gt. mc) then priority = ia else if (mc .gt. ma) then priority = ic else priority = ib end if end if end if end if end if else if (kb.eq.kc .and. ka.lt.kb) then if (jb .lt. jc) then priority = ib else if (jc .lt. jb) then priority = ic else mb = 0 mc = 0 do j = 1, jb mb = mb + atomic(i12(j,ib)) mc = mc + atomic(i12(j,ic)) end do if (mb .gt. mc) then priority = ib else if (mc .gt. mb) then priority = ic else mb = 0 mc = 0 do j = 1, n13(ib) mb = mb + atomic(i13(j,ib)) end do do j = 1, n13(ic) mc = mc + atomic(i13(j,ic)) end do if (mb .gt. mc) then priority = ia else if (mc .gt. mb) then priority = ic else mb = 0 mc = 0 do j = 1, n14(ib) mb = mb + atomic(i14(j,ib)) end do do j = 1, n14(ic) mc = mc + atomic(i14(j,ic)) end do if (mb .gt. mc) then priority = ia else if (mc .gt. mb) then priority = ic else mb = 0 mc = 0 do j = 1, n15(ib) mb = mb + atomic(i15(j,ib)) end do do j = 1, n15(ic) mc = mc + atomic(i15(j,ic)) end do if (mb .gt. mc) then priority = ia else if (mc .gt. mb) then priority = ic else priority = ia end if end if end if end if end if else if (ja.gt.jb.and.ja.gt.jc) then priority = ia else if (jb.gt.ja .and. jb.gt.jc) then priority = ib else if (jc.gt.ja .and. jc.gt.jb) then priority = ic else if (ja.lt.jb .and. ja.lt.jc) then priority = ia else if (jb.lt.ja .and. jb.lt.jc) then priority = ib else if (jc.lt.ja .and. jc.lt.jb) then priority = ic else ma = 0 mb = 0 mc = 0 do j = 1, ja ma = ma + atomic(i12(j,ia)) mb = mb + atomic(i12(j,ib)) mc = mc + atomic(i12(j,ic)) end do if (ma.gt.mb .and. ma.gt.mc) then priority = ia else if (mb.gt.ma .and. mb.gt.mc) then priority = ib else if (mc.gt.ma .and. mc.gt.mb) then priority = ic else if (ma.lt.mb .and. ma.lt.mc) then priority = ia else if (mb.lt.ma .and. mb.lt.mc) then priority = ib else if (mc.lt.ma .and. mc.lt.mb) then priority = ic else ma = 0 mb = 0 mc = 0 do j = 1, n13(ia) ma = ma + atomic(i13(j,ia)) end do do j = 1, n13(ib) mb = mb + atomic(i13(j,ib)) end do do j = 1, n13(ic) mc = mc + atomic(i13(j,ic)) end do if (ma.gt.mb .and. ma.gt.mc) then priority = ia else if (mb.gt.ma .and. mb.gt.mc) then priority = ib else if (mc.gt.ma .and. mc.gt.mb) then priority = ic else if (ma.lt.mb .and. ma.lt.mc) then priority = ia else if (mb.lt.ma .and. mb.lt.mc) then priority = ib else if (mc.lt.ma .and. mc.lt.mb) then priority = ic else ma = 0 mb = 0 mc = 0 do j = 1, n14(ia) ma = ma + atomic(i14(j,ia)) end do do j = 1, n14(ib) mb = mb + atomic(i14(j,ib)) end do do j = 1, n14(ic) mc = mc + atomic(i14(j,ic)) end do if (ma.gt.mb .and. ma.gt.mc) then priority = ia else if (mb.gt.ma .and. mb.gt.mc) then priority = ib else if (mc.gt.ma .and. mc.gt.mb) then priority = ic else if (ma.lt.mb .and. ma.lt.mc) then priority = ia else if (mb.lt.ma .and. mb.lt.mc) then priority = ib else if (mc.lt.ma .and. mc.lt.mb) then priority = ic else ma = 0 mb = 0 mc = 0 do j = 1, n15(ia) ma = ma + atomic(i15(j,ia)) end do do j = 1, n15(ib) mb = mb + atomic(i15(j,ib)) end do do j = 1, n15(ic) mc = mc + atomic(i15(j,ic)) end do if (ma.gt.mb .and. ma.gt.mc) then priority = ia else if (mb.gt.ma .and. mb.gt.mc) then priority = ib else if (mc.gt.ma .and. mc.gt.mb) then priority = ic else if (ma.lt.mb .and. ma.lt.mc) then priority = ia else if (mb.lt.ma .and. mb.lt.mc) then priority = ib else if (mc.lt.ma .and. mc.lt.mb) then priority = ic else priority = 0 end if end if end if end if end if end if end if return end c c c ################################################################## c ## ## c ## subroutine rotframe -- convert multipoles to local frame ## c ## ## c ################################################################## c c c "rotframe" takes the global multipole moments and rotates them c into the local coordinate frame defined at each atomic site c c subroutine rotframe use atomid use atoms use inform use iounit use mpole use units implicit none integer i,j,ii integer ia,ib,ic,id integer xaxe,yaxe,zaxe real*8 xad,yad,zad real*8 xbd,ybd,zbd real*8 xcd,ycd,zcd real*8 c1,c2,c3,vol logical check c c c perform dynamic allocation of some global arrays c if (.not. allocated(pole)) allocate (pole(maxpole,n)) if (.not. allocated(rpole)) allocate (rpole(maxpole,n)) c c rotate the multipoles from global frame to local frame c call rotrpole ('MPOLE') c c check the sign of multipole components at chiral sites; c note "yaxis" sign is not flipped based on signed volume c do ii = 1, npole check = .true. i = ipole(ii) if (polaxe(i) .ne. 'Z-then-X') check = .false. if (yaxis(i) .eq. 0) check = .false. if (check) then ia = i ib = zaxis(i) ic = xaxis(i) id = yaxis(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 vol = xad*c1 + xbd*c2 + xcd*c3 if (vol .lt. 0.0d0) 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 end if end do c c convert dipole and quadrupole moments back to atomic units c do ii = 1, npole i = ipole(ii) rpole(1,i) = pole(1,i) do j = 2, 4 rpole(j,i) = pole(j,i) / bohr end do do j = 5, 13 rpole(j,i) = 3.0d0 * pole(j,i) / bohr**2 end do end do c c print the local frame Cartesian atomic multipoles c if (verbose) then write (iout,10) 10 format (/,' Local Frame Cartesian Multipole Moments :') do i = 1, n ii = pollist(i) if (ii .eq. 0) then write (iout,20) i,name(i),atomic(i) 20 format (/,' Atom:',i8,9x,'Name:',3x,a3,7x, & 'Atomic Number:',i8) write (iout,30) 30 format (/,' No Atomic Multipole Moments for this Site') else zaxe = zaxis(i) xaxe = xaxis(i) yaxe = yaxis(i) if (yaxe .lt. 0) yaxe = -yaxe write (iout,40) i,name(i),atomic(i) 40 format (/,' Atom:',i8,9x,'Name:',3x,a3, & 7x,'Atomic Number:',i8) write (iout,50) polaxe(i),zaxe,xaxe,yaxe 50 format (/,' Local Frame:',12x,a8,6x,3i8) write (iout,60) rpole(1,i) 60 format (/,' Charge:',10x,f15.5) write (iout,70) rpole(2,i),rpole(3,i),rpole(4,i) 70 format (' Dipole:',10x,3f15.5) write (iout,80) rpole(5,i) 80 format (' Quadrupole:',6x,f15.5) write (iout,90) rpole(8,i),rpole(9,i) 90 format (18x,2f15.5) write (iout,100) rpole(11,i),rpole(12,i),rpole(13,i) 100 format (18x,3f15.5) end if end do end if return end c c c ################################################################# c ## ## c ## subroutine fixframe -- alter the local frame definition ## c ## ## c ################################################################# c c c "fixframe" is a service routine that alters the local frame c definition for specified atoms c c subroutine fixframe use atomid use atoms use couple use files use keys use kpolr use iounit use mpole use polar use units implicit none integer i,j,k integer ii,kk integer ia,ib,ic integer xaxe integer yaxe integer zaxe real*8 eps,ci,ck real*8 big,sum logical query,change character*240 record c c c rotate the multipole components into the global frame c call rotpole ('MPOLE') c c list the local frame definition for each multipole site c write (iout,10) 10 format (/,' Local Frame Definition for Multipole Sites :') write (iout,20) 20 format (/,5x,'Atom',5x,'Name',6x,'Axis Type',5x,'Z Axis',2x, & 'X Axis',2x,'Y Axis',/) do i = 1, n ii = pollist(i) if (ii .eq. 0) then write (iout,30) i,name(i) 30 format (i8,6x,a3,10x,'--',11x,'--',6x,'--',6x,'--') else zaxe = zaxis(i) xaxe = xaxis(i) yaxe = yaxis(i) if (yaxe .lt. 0) yaxe = -yaxe write (iout,40) i,name(i),polaxe(i),zaxe,xaxe,yaxe 40 format (i8,6x,a3,7x,a8,2x,3i8) end if end do c c allow the user to manually alter local coordinate frames c query = .true. change = .false. do while (query) i = 0 ia = 0 ib = 0 ic = 0 write (iout,50) 50 format (/,' Enter Altered Local Frame Definition', & ' [=Exit] : ',$) read (input,60) record 60 format (a240) read (record,*,err=70,end=70) i,ia,ib,ic 70 continue if (i .eq. 0) then query = .false. else change = .true. if (ia .eq. 0) polaxe(i) = 'None' if (ia.ne.0 .and. ib.eq.0) polaxe(i) = 'Z-Only' if (ia.gt.0 .and. ib.gt.0) polaxe(i) = 'Z-then-X' if (ia.lt.0 .or. ib.lt.0) polaxe(i) = 'Bisector' if (ib.lt.0 .and. ic.lt.0) polaxe(i) = 'Z-Bisect' if (max(ia,ib,ic) .lt. 0) polaxe(i) = '3-Fold' zaxis(i) = abs(ia) xaxis(i) = abs(ib) yaxis(i) = abs(ic) end if end do c c repeat local frame list if definitions were altered c if (change) then write (iout,80) 80 format (/,' Local Frame Definition for Multipole Sites :') write (iout,90) 90 format (/,5x,'Atom',5x,'Name',6x,'Axis Type',5x,'Z Axis',2x, & 'X Axis',2x,'Y Axis',/) do ii = 1, npole i = ipole(ii) zaxe = zaxis(i) xaxe = xaxis(i) yaxe = yaxis(i) if (yaxe .lt. 0) yaxe = -yaxe write (iout,100) i,name(i),polaxe(i),zaxe,xaxe,yaxe 100 format (i8,6x,a3,7x,a8,2x,3i8) end do end if c c rotate the multipoles from global frame to local frame c call rotrpole ('MPOLE') c c check the sign of multipole components at chiral sites c call chkpole c c convert dipole and quadrupole moments back to atomic units c do ii = 1, npole i = ipole(ii) pole(1,i) = pole(1,i) do j = 2, 4 pole(j,i) = pole(j,i) / bohr end do do j = 5, 13 pole(j,i) = 3.0d0 * pole(j,i) / bohr**2 end do end do c c regularize the multipole moments to desired precision c eps = 0.00001d0 do ii = 1, npole i = ipole(ii) do j = 1, 13 pole(j,i) = dble(nint(pole(j,i)/eps)) * eps end do end do c c enforce integer net charge over atomic multipoles c j = 0 big = 0.0d0 sum = 0.0d0 do ii = 1, npole i = ipole(ii) sum = sum + pole(1,i) ci = abs(pole(1,i)) if (ci .gt. big) then do kk = 1, npole k = ipole(kk) ck = abs(pole(1,k)) if (i.ne.k .and. ci.eq.ck) goto 110 end do j = i big = ci 110 continue end if end do sum = sum - dble(nint(sum)) if (j .ne. 0) pole(1,j) = pole(1,j) - sum c c enforce traceless quadrupole at each multipole site c do ii = 1, npole i = ipole(ii) sum = pole(5,i) + pole(9,i) + pole(13,i) big = max(abs(pole(5,i)),abs(pole(9,i)),abs(pole(13,i))) k = 0 if (big .eq. abs(pole(5,i))) k = 5 if (big .eq. abs(pole(9,i))) k = 9 if (big .eq. abs(pole(13,i))) k = 13 if (pole(9,i) .eq. pole(13,i)) k = 5 if (pole(5,i) .eq. pole(13,i)) k = 9 if (pole(5,i) .eq. pole(9,i)) k = 13 if (k .ne. 0) pole(k,i) = pole(k,i) - sum end do c c print the altered local frame atomic multipole values c write (iout,120) 120 format (/,' Multipoles With Altered Local Frame Definition :') do i = 1, n ii = pollist(i) if (ii .eq. 0) then write (iout,130) i,name(i),atomic(i) 130 format (/,' Atom:',i8,9x,'Name:',3x,a3,7x, & 'Atomic Number:',i8) write (iout,140) 140 format (/,' No Atomic Multipole Moments for this Site') else zaxe = zaxis(i) xaxe = xaxis(i) yaxe = yaxis(i) if (yaxe .lt. 0) yaxe = -yaxe write (iout,150) i,name(i),atomic(i) 150 format (/,' Atom:',i8,9x,'Name:',3x,a3, & 7x,'Atomic Number:',i8) write (iout,160) polaxe(i),zaxe,xaxe,yaxe 160 format (/,' Local Frame:',12x,a8,6x,3i8) write (iout,170) pole(1,i) 170 format (/,' Charge:',10x,f15.5) write (iout,180) pole(2,i),pole(3,i),pole(4,i) 180 format (' Dipole:',10x,3f15.5) write (iout,190) pole(5,i) 190 format (' Quadrupole:',6x,f15.5) write (iout,200) pole(8,i),pole(9,i) 200 format (18x,2f15.5) write (iout,210) pole(11,i),pole(12,i),pole(13,i) 210 format (18x,3f15.5) end if end do return end c c c ############################################################## c ## ## c ## subroutine setpolar -- define the polarization model ## c ## ## c ############################################################## c c c "setpolar" assigns atomic polarizabilities, Thole damping or c charge penetration parameters, and allows user modification c c note this routine contains directly coded scale factors, and c Thole and charge penetration values for atom types that should c be updated if the default force field values are modified c c subroutine setpolar use atomid use atoms use chgpen use couple use fields use iounit use mplpot use mpole use polar use polpot implicit none integer i,j,k,m integer ii,jj integer atn,next real*8 pol,thl real*8 pel,pal real*8 sixth logical exist,query logical change logical aromatic logical chkarom character*1 answer character*240 record character*240 string external chkarom c c c allow the user to select the polarization model c forcefield = 'AMOEBA' use_thole = .true. use_tholed = .false. use_chgpen = .false. dpequal = .false. query = .true. answer = ' ' call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) answer call upcase (answer) if (answer.eq.'A' .or. answer.eq.'H') query = .false. end if 10 continue if (query) then answer = 'A' write (iout,20) 20 format (/,' Choose Either the AMOEBA or HIPPO Polarization', & ' Model [A] : ',$) read (input,30) record 30 format (a240) next = 1 call gettext (record,answer,next) call upcase (answer) end if if (answer .eq. 'H') then forcefield = 'HIPPO' use_thole = .false. use_chgpen = .true. dpequal = .true. end if c c perform dynamic allocation of some global arrays c if (.not. allocated(polarity)) allocate (polarity(n)) if (.not. allocated(thole)) allocate (thole(n)) if (.not. allocated(tholed)) allocate (tholed(n)) if (.not. allocated(pdamp)) allocate (pdamp(n)) if (.not. allocated(pcore)) allocate (pcore(n)) if (.not. allocated(pval)) allocate (pval(n)) if (.not. allocated(palpha)) allocate (palpha(n)) c c zero out the polarization and charge penetration values c do i = 1, n polarity(i) = 0.0d0 thole(i) = 0.0d0 tholed(i) = 0.0d0 pdamp(i) = 0.0d0 pcore(i) = 0.0d0 pval(i) = 0.0d0 palpha(i) = 0.0d0 end do c c set multipole and polarization scale factors for AMOEBA c if (forcefield .eq. 'AMOEBA') then m2scale = 0.0d0 m3scale = 0.0d0 m4scale = 0.4d0 m5scale = 0.8d0 p2scale = 0.0d0 p3scale = 0.0d0 p4scale = 1.0d0 p5scale = 1.0d0 p2iscale = 0.0d0 p3iscale = 0.0d0 p4iscale = 0.5d0 p5iscale = 1.0d0 d1scale = 0.0d0 d2scale = 1.0d0 d3scale = 1.0d0 d4scale = 1.0d0 u1scale = 1.0d0 u2scale = 1.0d0 u3scale = 1.0d0 u4scale = 1.0d0 end if c c set multipole and polarization scale factors for HIPPO c if (forcefield .eq. 'HIPPO') then m2scale = 0.0d0 m3scale = 0.0d0 m4scale = 0.4d0 m5scale = 0.8d0 p2scale = 0.0d0 p3scale = 0.5d0 p4scale = 1.0d0 p5scale = 1.0d0 p2iscale = 0.0d0 p3iscale = 0.0d0 p4iscale = 0.0d0 p5iscale = 0.5d0 d1scale = 0.0d0 d2scale = 1.0d0 d3scale = 1.0d0 d4scale = 1.0d0 u1scale = 1.0d0 u2scale = 1.0d0 u3scale = 1.0d0 u4scale = 1.0d0 w2scale = 0.2d0 w3scale = 1.0d0 w4scale = 1.0d0 w5scale = 1.0d0 end if c c assign default atomic polarizabilities for AMOEBA model c if (forcefield .eq. 'AMOEBA') then do i = 1, n thole(i) = 0.39d0 atn = atomic(i) if (atn .eq. 1) then polarity(i) = 0.496d0 else if (atn .eq. 5) then polarity(i) = 1.600d0 else if (atn .eq. 6) then polarity(i) = 1.334d0 else if (atn .eq. 7) then polarity(i) = 1.073d0 else if (atn .eq. 8) then polarity(i) = 0.837d0 else if (atn .eq. 9) then polarity(i) = 0.507d0 else if (atn .eq. 14) then polarity(i) = 3.640d0 else if (atn .eq. 15) then polarity(i) = 1.828d0 else if (atn .eq. 16) then polarity(i) = 3.300d0 else if (atn .eq. 17) then polarity(i) = 2.500d0 else if (atn .eq. 35) then polarity(i) = 3.595d0 else if (atn .eq. 53) then polarity(i) = 5.705d0 end if end do c c alter polarizabilities for alkene/aromatic carbon and hydrogen c do i = 1, n atn = atomic(i) if (atn .eq. 1) then j = i12(1,i) if (atomic(j).eq.6 .and. n12(j).eq.3) then polarity(i) = 0.696d0 do k = 1, n12(j) m = i12(k,j) if (atomic(m).eq.8 .and. n12(m).eq.1) then polarity(i) = 0.494d0 end if end do end if else if (atn .eq. 6) then if (n12(i) .eq. 3) then polarity(i) = 1.75d0 do j = 1, n12(i) k = i12(j,i) if (atomic(k).eq.8 .and. n12(k).eq.1) then polarity(i) = 1.334d0 end if end do end if end if end do end if c c assign default atom-based parameters for HIPPO model c if (forcefield .eq. 'HIPPO') then do i = 1, n atn = atomic(i) if (atn .eq. 1) then pcore(i) = 1.0d0 polarity(i) = 0.373d0 palpha(i) = 4.3225d0 k = atomic(i12(1,i)) if (k .eq. 6) then do j = 1, n13(i) m = atomic(i13(j,i)) if ((atomic(m).ne.6.or.n12(m).ne.4) & .and. atomic(m).ne.1) goto 40 end do do j = 1, n14(i) m = i14(j,i) if ((atomic(m).ne.6.or.n12(m).ne.4) & .and. atomic(m).ne.1) goto 40 end do polarity(i) = 0.504d0 palpha(i) = 4.9530d0 40 continue aromatic = chkarom (i) if (aromatic) then polarity(i) = 0.1106d0 palpha(i) = 4.9530d0 end if else if (k .eq. 7) then polarity(i) = 0.005d0 palpha(i) = 5.5155d0 else if (k .eq. 8) then polarity(i) = 0.3698d0 palpha(i) = 4.7441d0 else if (k .eq. 16) then polarity(i) = 0.2093d0 palpha(i) = 4.3952d0 end if else if (atn .eq. 5) then pcore(i) = 3.0d0 polarity(i) = 1.6d0 palpha(i) = 0.0d0 !! missing parameter else if (atn .eq. 6) then pcore(i) = 4.0d0 polarity(i) = 0.9354d0 palpha(i) = 4.5439d0 do j = 1, n12(i) k = i12(j,i) if ((atomic(k).ne.6.or.n12(k).ne.4) & .and. atomic(k).ne.1) goto 50 end do do j = 1, n13(i) k = atomic(i13(j,i)) if ((atomic(k).ne.6.or.n12(k).ne.4) & .and. atomic(k).ne.1) goto 50 end do polarity(i) = 0.755d0 palpha(i) = 4.2998d0 50 continue if (n12(i) .eq. 3) then do j = 1, n12(i) k = i12(j,i) if (atomic(k).eq.6 .and. n12(k).eq.3) then polarity(i) = 1.9384d0 palpha(i) = 3.5491d0 end if end do do j = 1, n12(i) k = i12(j,i) if (atomic(k).eq.8 .and. n12(k).eq.1) then polarity(i) = 0.6577d0 palpha(i) = 5.9682d0 end if end do end if if (chkarom(i)) then polarity(i) = 1.5624d0 palpha(i) = 3.8056d0 do j = 1, n12(i) k = atomic(i12(j,i)) if (k.ne.6 .and. k.ne.1) then polarity(i) = 1.2811d0 palpha(i) = 3.8066d0 end if end do end if if (n12(i) .eq. 2) then polarity(i) = 0.9354d0 !! generic value palpha(i) = 4.5439d0 !! generic value end if else if (atn .eq. 7) then pcore(i) = 5.0d0 polarity(i) = 1.4289d0 palpha(i) = 3.9882d0 if (n12(i) .eq. 3) then do j = 1, n12(i) k = i12(j,i) if (atomic(k).eq.6 .and. n12(k).eq.3) then polarity(i) = 1.4545d0 palpha(i) = 3.9413d0 end if end do end if if (chkarom(i)) then polarity(i) = 1.3037d0 palpha(i) = 3.9434d0 end if else if (atn .eq. 8) then pcore(i) = 6.0d0 polarity(i) = 0.6645d0 palpha(i) = 4.7004d0 if (n12(i) .eq. 1) then k = i12(1,i) if (atomic(k).eq.6 .and. n12(k).eq.3) then polarity(i) = 1.4266d0 palpha(i) = 4.2263d0 do j = 1, n13(i) m = i13(j,i) if (atomic(m).eq.8 .and. n12(m).eq.1) then polarity(i) = 1.8809d0 palpha(i) = 4.0355d0 end if end do end if if (atomic(k) .eq. 15) then jj = 0 do j = 1, n12(k) m = i12(j,k) if (atomic(m).eq.8 .and. n12(m).eq.1) then jj = jj + 1 end if end do if (jj .eq. 1) then polarity(i) = 1.0d0 palpha(i) = 4.3312d0 else polarity(i) = 1.0d0 palpha(i) = 4.4574d0 end if end if end if else if (atn .eq. 9) then pcore(i) = 7.0d0 polarity(i) = 0.5d0 palpha(i) = 5.5080d0 else if (atn .eq. 15) then pcore(i) = 5.0d0 polarity(i) = 1.8d0 palpha(i) = 2.8130d0 else if (atn .eq. 16) then pcore(i) = 6.0d0 polarity(i) = 3.1967d0 palpha(i) = 3.3620d0 if (n12(i) .gt. 2) then polarity(i) = 2.458d0 palpha(i) = 2.7272d0 end if else if (atn .eq. 17) then pcore(i) = 7.0d0 polarity(i) = 2.366d0 palpha(i) = 3.6316d0 else if (atn .eq. 35) then pcore(i) = 7.0d0 polarity(i) = 3.4458d0 palpha(i) = 3.2008d0 else if (atn .eq. 53) then pcore(i) = 7.0d0 polarity(i) = 5.5d0 palpha(i) = 0.0d0 !! missing parameter end if end do end if c c set valence electrons from number of core electrons c do i = 1, n pval(i) = pole(1,i) - pcore(i) end do c c compute the Thole polarizability damping values c sixth = 1.0d0 / 6.0d0 do i = 1, n if (thole(i) .eq. 0.0d0) then pdamp(i) = 0.0d0 else pdamp(i) = polarity(i)**sixth end if end do c c list the polarizability and charge penetration values c write (iout,60) 60 format (/,' Polarizability Parameters for Multipole Sites :') if (use_thole) then write (iout,70) 70 format (/,5x,'Atom',5x,'Name',7x,'Polarize',10x,'Thole',/) else if (use_chgpen) then write (iout,80) 80 format (/,5x,'Atom',5x,'Name',7x,'Polarize',11x,'Core', & 5x,'Valence',8x,'Damp',/) end if do i = 1, n ii = pollist(i) if (use_thole) then if (ii .eq. 0) then write (iout,90) i,name(i) 90 format (i8,6x,a3,12x,'--',13x,'--') else write (iout,100) i,name(i),polarity(i),thole(i) 100 format (i8,6x,a3,4x,f12.4,3x,f12.4) end if else if (use_chgpen) then if (ii .eq. 0) then write (iout,110) i,name(i) 110 format (i8,6x,a3,12x,'--',13x,'--',10x,'--',10x,'--') else write (iout,120) i,name(i),polarity(i),pcore(i), & pval(i),palpha(i) 120 format (i8,6x,a3,4x,f12.4,3x,3f12.4) end if end if end do c c allow the user to manually alter polarizability values c change = .false. query = .true. i = -1 call nextarg (string,exist) if (exist) then read (string,*,err=130,end=130) i if (i .eq. 0) query = .false. end if 130 continue do while (query) i = 0 if (use_thole) then pol = 0.0d0 thl = 0.39d0 write (iout,140) 140 format (/,' Enter Atom Number, Polarizability & Thole', & ' Value : ',$) read (input,150) record 150 format (a240) read (record,*,err=160,end=160) i,pol,thl 160 continue if (i .ne. 0) then if (pol .eq. 0.0d0) pol = polarity(i) if (thl .eq. 0.0d0) thl = thole(i) end if else if (use_chgpen) then pol = 0.0d0 pel = 0.0d0 pal = 0.0d0 write (iout,170) 170 format (/,' Enter Atom Number, Polarize, Core & Damp', & ' Value : ',$) read (input,180) record 180 format (a240) read (record,*,err=190,end=190) i,pol,pel,pal 190 continue if (i .ne. 0) then if (pol .eq. 0.0d0) pol = polarity(i) if (pel .eq. 0.0d0) pel = pcore(i) if (pal .eq. 0.0d0) pal = palpha(i) end if end if if (i .eq. 0) then query = .false. else change = .true. polarity(i) = pol if (use_thole) then thole(i) = thl pdamp(i) = polarity(i)**sixth else if (use_chgpen) then pcore(i) = pel palpha(i) = pal pval(i) = pole(1,i) - pcore(i) end if end if end do c c repeat polarizability values if parameters were altered c if (change) then write (iout,200) 200 format (/,' Atomic Polarizabilities for Multipole Sites :') if (use_thole) then write (iout,210) 210 format (/,5x,'Atom',5x,'Name',7x,'Polarize',10x,'Thole',/) else if (use_chgpen) then write (iout,220) 220 format (/,5x,'Atom',5x,'Name',7x,'Polarize',4x,'Core Chg', & 8x,'Damp',/) end if do i = 1, n ii = pollist(i) if (use_thole) then if (ii .eq. 0) then write (iout,230) i,name(i) 230 format (i8,6x,a3,12x,'--',13x,'--') else write (iout,240) i,name(i),polarity(i),thole(i) 240 format (i8,6x,a3,4x,f12.4,3x,f12.4) end if else if (use_chgpen) then if (ii .eq. 0) then write (iout,250) i,name(i) 250 format (i8,6x,a3,12x,'--',13x,'--',10x,'--') else write (iout,260) i,name(i),polarity(i),pcore(i), & palpha(i) 260 format (i8,6x,a3,4x,f12.4,3x,2f12.4) end if end if end do end if return end c c c ############################################################## c ## ## c ## subroutine setpgrp -- define the polarization groups ## c ## ## c ############################################################## c c c "setpgrp" chooses the polarization groups as defined by bonds c separating groups, and allows user modification of the groups c c subroutine setpgrp use atomid use atoms use bndstr use couple use iounit use kpolr use ring implicit none integer i,j,k,m integer mode integer ia,ib,ic integer ita,itb,itc integer ata,atb integer n12a,n12b logical exist,query logical chkarom,split logical aroma,aromb character*240 record character*240 string c c c get the desired type of coordinate file modification c mode = -1 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) mode if (mode.ge.1 .and. mode.le.2) query = .false. end if 10 continue if (query) then write (iout,20) 20 format (/,' Choose Method for Division into Polarization', & ' Groups :', & //,4x,'(1) Put All Atoms in One Polarization Group', & /,4x,'(2) Separate into Groups at Rotatable Bonds', & /,4x,'(3) Manual Entry of Bonds Separating Groups') do while (mode.lt.1 .or. mode.gt.3) mode = 0 write (iout,30) 30 format (/,' Enter the Number of the Desired Choice', & ' [1] : ',$) read (input,40,err=50,end=50) mode 40 format (i10) if (mode .le. 0) mode = 1 50 continue end do end if c c initialize by placing all atoms in one polarization group c do i = 1, n do j = 1, n12(i) pgrp(j,i) = i12(j,i) end do end do c c separate into polarization groups at rotatable bonds c if (mode .eq. 2) then call bonds do k = 1, nbond ia = ibnd(1,k) ib = ibnd(2,k) n12a = n12(ia) n12b = n12(ib) ata = atomic(ia) atb = atomic(ib) ita = 10*ata + n12a itb = 10*atb + n12b aroma = chkarom(ia) aromb = chkarom(ib) split = .true. c c remove bonds involving univalent atoms c if (min(n12a,n12b) .le. 1) split = .false. c c remove bonds internal to aromatic ring c if (aroma .and. aromb) then do i = 1, nring5 m = 0 do j = 1, 5 if (iring5(j,i) .eq. ia) m = m + 1 if (iring5(j,i) .eq. ib) m = m + 1 end do if (m .eq. 2) split = .false. end do do i = 1, nring6 m = 0 do j = 1, 6 if (iring6(j,i) .eq. ia) m = m + 1 if (iring6(j,i) .eq. ib) m = m + 1 end do if (m .eq. 2) split = .false. end do end if c c remove bonds with sp-hybridized carbon atom c if (ita.eq.62 .or. itb.eq.62) split = .false. c c remove the C=C bond of terminal alkene c if (ita.eq.63 .and. .not.aroma .and. & itb.eq.63 .and. .not.aromb) then split = .false. do i = 1, n12a ic = i12(i,ia) if (ic .ne. ib) then itc = 10*atomic(ic) + n12(ic) if (itc.eq.63 .or. itc.eq.73 .or. & itc.eq.72 .or. itc.eq.81) then split = .true. end if end if end do if (split) then split = .false. do i = 1, n12b ic = i12(i,ib) if (ic .ne. ia) then itc = 10*atomic(ic) + n12(ic) if (itc.eq.63 .or. itc.eq.72 .or. & itc.eq.73 .or. itc.eq.81) then split = .true. end if end if end do end if end if c c remove the C-O bonds of alcohol and ether c if (ita.eq.82 .and. itb.eq.64) then do i = 1, n12a ic = i12(i,ia) if (ic .ne. ib) then itc = 10*atomic(ic) + n12(ic) if (itc.eq.11 .or. itc.eq.64) split = .false. end if end do else if (itb.eq.82 .and. ita.eq.64) then do i = 1, n12b ic = i12(i,ib) if (ic .ne. ia) then itc = 10*atomic(ic) + n12(ic) if (itc.eq.11 .or. itc.eq.64) split = .false. end if end do end if c c remove the C-O bonds of carboxylic acid and ester c if (ita.eq.82 .and. itb.eq.63) then do i = 1, n12b ic = i12(i,ib) itc = 10*atomic(ic) + n12(ic) if (itc .eq. 81) split = .false. if (aromb) split = .false. end do else if (itb.eq.82 .and. ita.eq.63) then do i = 1, n12a ic = i12(i,ia) itc = 10*atomic(ic) + n12(ic) if (itc .eq. 81) split = .false. if (aroma) split = .false. end do end if c c remove the C-N bonds of alkyl amine c if (ita.eq.73 .and. itb.eq.64) then m = 0 do i = 1, n12a ic = i12(i,ia) if (ic .ne. ib) then itc = 10*atomic(ic) + n12(ic) if (itc.eq.11 .or. itc.eq.64) m = m + 1 end if end do if (m .eq. 2) split = .false. else if (itb.eq.73 .and. ita.eq.64) then m = 0 do i = 1, n12b ic = i12(i,ib) if (ic .ne. ia) then itc = 10*atomic(ic) + n12(ic) if (itc.eq.11 .or. itc.eq.64) m = m + 1 end if end do if (m .eq. 2) split = .false. end if c c remove the C-N bonds of amide, urea, amidine and guanidinium c if (ita.eq.73 .and. itb.eq.63) then do i = 1, n12b ic = i12(i,ib) if (ic .ne. ia) then itc = 10*atomic(ic) + n12(ic) if (itc .eq. 81) split = .false. if (itc .eq. 73) split = .false. end if end do else if (itb.eq.73 .and. ita.eq.63) then do i = 1, n12a ic = i12(i,ia) if (ic .ne. ib) then itc = 10*atomic(ic) + n12(ic) if (itc .eq. 81) split = .false. if (itc .eq. 73) split = .false. end if end do end if c c remove any P-X and S-X bonds with X = N or O c if (ata.eq.15 .or. ata.eq.16) then if (atb.eq.7 .or. atb.eq.8) split = .false. else if (atb.eq.15 .or. atb.eq.16) then if (ata.eq.7 .or. ata.eq.8) split = .false. end if c c modify membership to split groups at allowed bonds c if (split) then do i = 1, n12a if (pgrp(i,ia) .eq. ib) then do j = i+1, n12a pgrp(j-1,ia) = pgrp(j,ia) end do pgrp(n12a,ia) = 0 end if end do do i = 1, n12b if (pgrp(i,ib) .eq. ia) then do j = i+1, n12b pgrp(j-1,ib) = pgrp(j,ib) end do pgrp(n12b,ib) = 0 end if end do end if end do c c allow modification of polarization group one bond at a time c else if (mode .eq. 3) then write (iout,60) 60 format (/,' All atoms are placed initially into one', & ' polarization group;', & /,' This can be modified by entering a series', & ' of bonded atom pairs', & /,' that separate the molecule into distinct', & ' polarization groups') c c get the bonds that separate the polarization groups c query = .true. i = -1 call nextarg (string,exist) if (exist) then read (string,*,err=70,end=70) i if (i .eq. 0) query = .false. end if 70 continue do while (query) ia = 0 ib = 0 write (iout,80) 80 format (/,' Enter a Bond between Polarization Groups', & ' [=Exit] : ',$) read (input,90) record 90 format (a240) read (record,*,err=100,end=100) ia,ib 100 continue if (ia.eq.0 .or. ib.eq.0) then query = .false. else do i = 1, n12(ia) if (pgrp(i,ia) .eq. ib) then do j = i+1, n12(ia) pgrp(j-1,ia) = pgrp(j,ia) end do pgrp(n12(ia),ia) = 0 end if end do do i = 1, n12(ib) if (pgrp(i,ib) .eq. ia) then do j = i+1, n12(ib) pgrp(j-1,ib) = pgrp(j,ib) end do pgrp(n12(ib),ib) = 0 end if end do end if end do end if c c find the polarization groups and their connectivities c call polargrp c c list the polarization group for each multipole site c write (iout,110) 110 format (/,' Polarization Groups for Multipole Sites :') write (iout,120) 120 format (/,5x,'Atom',5x,'Name',7x,'Polarization Group', & ' Definition',/) do i = 1, n k = 0 do j = 1, maxval if (pgrp(j,i) .ne. 0) k = j end do write (iout,130) i,name(i),(pgrp(j,i),j=1,k) 130 format (i8,6x,a3,8x,20i6) end do return end c c c ############################################################# c ## ## c ## function chkarom -- check for atom in aromatic ring ## c ## ## c ############################################################# c c c "chkatom" tests for the presence of a specified atom as a c member of an aromatic ring c c function chkarom (iatom) use atomid use couple use ring implicit none integer i,j,k integer iatom logical chkarom logical member logical trigonal c c c determine membership in 5-membered aromatic ring c chkarom = .false. do i = 1, nring5 trigonal = .true. member = .false. do j = 1, 5 k = iring5(j,i) if (k .eq. iatom) member = .true. if (atomic(k).eq.6 .and. n12(k).ne.3) trigonal = .false. if (atomic(k).eq.7 .and. n12(k).eq.4) trigonal = .false. end do if (member .and. trigonal) chkarom = .true. end do c c determine membership in 6-membered aromatic ring c do i = 1, nring6 trigonal = .true. member = .false. do j = 1, 6 k = iring6(j,i) if (k .eq. iatom) member = .true. if (atomic(k).eq.6 .and. n12(k).ne.3) trigonal = .false. if (atomic(k).eq.7 .and. n12(k).eq.4) trigonal = .false. end do if (member .and. trigonal) chkarom = .true. end do return end c c c ################################################################## c ## ## c ## subroutine alterpol -- alter multipoles for polarization ## c ## ## c ################################################################## c c c "alterpol" finds an output set of atomic multipole parameters c which when used with an intergroup polarization model will c give the same electrostatic potential around the molecule as c the input set of multipole parameters with all atoms in one c polarization group c c for example, the input parameters could be from a distributed c multipole analysis of a molecular wavefunction and the output c will be the multipole moments that achieve the same potential c in the presence of intergroup (intramolecular) polarization c c subroutine alterpol use atomid use atoms use inform use iounit use mpole use polar use units implicit none integer i,j,ii integer xaxe integer yaxe integer zaxe c c c compute induced dipoles to be removed from QM multipoles c call interpol c c remove intergroup induced dipoles from atomic multipoles c do ii = 1, npole i = ipole(ii) pole(2,i) = pole(2,i) - uind(1,i) pole(3,i) = pole(3,i) - uind(2,i) pole(4,i) = pole(4,i) - uind(3,i) end do c c convert dipole and quadrupole moments back to atomic units c do ii = 1, npole i = ipole(ii) rpole(1,i) = pole(1,i) do j = 2, 4 rpole(j,i) = pole(j,i) / bohr end do do j = 5, 13 rpole(j,i) = 3.0d0 * pole(j,i) / bohr**2 end do end do c c print multipoles with intergroup polarization removed c if (verbose) then write (iout,10) 10 format (/,' Multipoles after Removal of Intergroup', & ' Polarization :') do i = 1, n ii = pollist(i) if (ii .eq. 0) then write (iout,20) i,name(i),atomic(i) 20 format (/,' Atom:',i8,9x,'Name:',3x,a3, & 7x,'Atomic Number:',i8) write (iout,30) 30 format (/,' No Atomic Multipole Moments for this Site') else zaxe = zaxis(i) xaxe = xaxis(i) yaxe = yaxis(i) if (yaxe .lt. 0) yaxe = -yaxe write (iout,40) i,name(i),atomic(i) 40 format (/,' Atom:',i8,9x,'Name:',3x,a3, & 7x,'Atomic Number:',i8) write (iout,50) polaxe(i),zaxe,xaxe,yaxe 50 format (/,' Local Frame:',12x,a8,6x,3i8) write (iout,60) rpole(1,i) 60 format (/,' Charge:',10x,f15.5) write (iout,70) rpole(2,i),rpole(3,i),rpole(4,i) 70 format (' Dipole:',10x,3f15.5) write (iout,80) rpole(5,i) 80 format (' Quadrupole:',6x,f15.5) write (iout,90) rpole(8,i),rpole(9,i) 90 format (18x,2f15.5) write (iout,100) rpole(11,i),rpole(12,i),rpole(13,i) 100 format (18x,3f15.5) end if end do end if return end c c c ############################################################### c ## ## c ## subroutine interpol -- get intergroup induced dipoles ## c ## ## c ############################################################### c c c "interpol" computes intergroup induced dipole moments for use c during removal of intergroup polarization c c note only DIRECT and MUTUAL polarization models are available; c the analytical OPT and TCG methods are treated as MUTUAL c c subroutine interpol use atoms use iounit use mplpot use mpole use polar use polpot use units implicit none integer i,j,k integer ii,iter integer maxiter integer trimtext real*8 eps,epsold real*8 polmin,norm real*8 a,b,sum,term real*8 utmp(3) real*8 rmt(3,3) real*8, allocatable :: poli(:) real*8, allocatable :: field(:,:) real*8, allocatable :: rsd(:,:) real*8, allocatable :: zrsd(:,:) real*8, allocatable :: conj(:,:) real*8, allocatable :: vec(:,:) logical done logical planar character*5 truth c c c perform dynamic allocation of some global arrays c if (.not. allocated(uind)) allocate (uind(3,n)) c c perform dynamic allocation of some local arrays c allocate (poli(n)) allocate (field(3,n)) allocate (rsd(3,n)) allocate (zrsd(3,n)) allocate (conj(3,n)) allocate (vec(3,n)) c c rotate the multipole components into the global frame c call rotpole ('MPOLE') c c compute induced dipoles as polarizability times field c call dfieldi (field) do ii = 1, npole i = ipole(ii) do j = 1, 3 uind(j,i) = polarity(i) * field(j,i) end do end do c c for direct-only models set mutual scale factors to zero c if (poltyp .eq. 'DIRECT') then u1scale = 0.0d0 u2scale = 0.0d0 u3scale = 0.0d0 u4scale = 0.0d0 end if c c print the electrostatic and polarization scale factors c write (iout,10) 10 format (/,' Electrostatic and Polarization Scale Factors :', & //,20x,'1-2',9x,'1-3',9x,'1-4',9x,'1-5',/) write (iout,20) m2scale,m3scale,m4scale,m5scale 20 format (' M-Scale:',3x,4f12.4) write (iout,30) p2scale,p3scale,p4scale,p5scale 30 format (' P-Inter:',3x,4f12.4) write (iout,40) p2iscale,p3iscale,p4iscale,p5iscale 40 format (' P-Intra:',3x,4f12.4) write (iout,50) w2scale,w3scale,w4scale,w5scale 50 format (' W-Scale:',3x,4f12.4) write (iout,60) 60 format (/,20x,'1-1',9x,'1-2',9x,'1-3',9x,'1-4',/) write (iout,70) d1scale,d2scale,d3scale,d4scale 70 format (' D-Scale:',3x,4f12.4) write (iout,80) u1scale,u2scale,u3scale,u4scale 80 format (' U-Scale:',3x,4f12.4) truth = 'False' if (use_thole) truth = 'True' write (iout,90) truth(1:trimtext(truth)) 90 format (/,' Use Thole Damping:',11x,a) truth = 'False' if (use_chgpen) truth = 'True' write (iout,100) truth(1:trimtext(truth)) 100 format (' Charge Penetration:',10x,a) truth = 'False' if (dpequal) truth = 'True' write (iout,110) truth(1:trimtext(truth)) 110 format (' Set D Equal to P:',12x,a) c c set tolerances for computation of mutual induced dipoles c done = .false. maxiter = 100 iter = 0 polmin = 0.00000001d0 eps = 100.0d0 c c compute intergroup induced dipole moments via CG algorithm c call ufieldi (field) do ii = 1, npole i = ipole(ii) poli(i) = max(polmin,polarity(i)) do j = 1, 3 rsd(j,i) = field(j,i) zrsd(j,i) = rsd(j,i) * poli(i) conj(j,i) = zrsd(j,i) end do end do c c conjugate gradient iteration of intergroup induced dipoles c do while (.not. done) iter = iter + 1 do ii = 1, npole i = ipole(ii) do j = 1, 3 vec(j,i) = uind(j,i) uind(j,i) = conj(j,i) end do end do call ufieldi (field) do ii = 1, npole i = ipole(ii) do j = 1, 3 uind(j,i) = vec(j,i) vec(j,i) = conj(j,i)/poli(i) - field(j,i) end do end do a = 0.0d0 sum = 0.0d0 do ii = 1, npole i = ipole(ii) do j = 1, 3 a = a + conj(j,i)*vec(j,i) sum = sum + rsd(j,i)*zrsd(j,i) end do end do if (a .ne. 0.0d0) a = sum / a do ii = 1, npole i = ipole(ii) do j = 1, 3 uind(j,i) = uind(j,i) + a*conj(j,i) rsd(j,i) = rsd(j,i) - a*vec(j,i) end do end do b = 0.0d0 do ii = 1, npole i = ipole(ii) do j = 1, 3 zrsd(j,i) = rsd(j,i) * poli(i) b = b + rsd(j,i)*zrsd(j,i) end do end do if (sum .ne. 0.0d0) b = b / sum eps = 0.0d0 do ii = 1, npole i = ipole(ii) do j = 1, 3 conj(j,i) = zrsd(j,i) + b*conj(j,i) eps = eps + rsd(j,i)*rsd(j,i) end do end do c c check the convergence of the intergroup induced dipoles c eps = debye * sqrt(eps/dble(npolar)) epsold = eps if (iter .eq. 1) then write (iout,120) 120 format (/,' Determination of Intergroup Induced', & ' Dipoles :', & //,4x,'Iter',8x,'RMS Change (Debye)',/) end if write (iout,130) iter,eps 130 format (i8,7x,f16.10) if (eps .lt. poleps) done = .true. if (eps .gt. epsold) done = .true. if (iter .ge. maxiter) done = .true. c c apply a "peek" iteration to the intergroup induced dipoles c if (done) then do ii = 1, npole i = ipole(ii) term = poli(i) do j = 1, 3 uind(j,i) = uind(j,i) + term*rsd(j,i) end do end do end if end do c c perform deallocation of some local arrays c deallocate (poli) deallocate (field) deallocate (rsd) deallocate (zrsd) deallocate (conj) deallocate (vec) c c terminate the calculation if dipoles failed to converge c if (eps .gt. poleps) then write (iout,140) 140 format (/,' INTERPOL -- Warning, Induced Dipoles', & ' are not Converged') call prterr call fatal end if c c rotate the induced dipoles into local coordinate frame c do ii = 1, npole i = ipole(ii) call rotmat (i,rmt,planar) call invert (3,rmt) do j = 1, 3 utmp(j) = 0.0d0 do k = 1, 3 utmp(j) = utmp(j) + uind(k,i)*rmt(j,k) end do end do do j = 1, 3 uind(j,i) = utmp(j) end do end do c c print out a list of the final induced dipole moments c write (iout,150) 150 format (/,' Local Frame Intergroup Induced Dipole Moments', & ' (Debye) :') write (iout,160) 160 format (/,4x,'Atom',14x,'X',11x,'Y',11x,'Z',9x,'Total',/) do ii = 1, npole i = ipole(ii) norm = sqrt(uind(1,i)**2+uind(2,i)**2+uind(3,i)**2) write (iout,170) i,(debye*uind(j,i),j=1,3),debye*norm 170 format (i8,5x,4f12.4) end do return end c c c ############################################################## c ## ## c ## subroutine dfieldi -- find permanent multipole field ## c ## ## c ############################################################## c c c "dfieldi" computes the electrostatic field due to permanent c multipole moments c c subroutine dfieldi (field) use atoms use chgpen use couple use mplpot use mpole use polar use polgrp use polpot implicit none integer i,j,k integer ii,kk real*8 xr,yr,zr real*8 r,r2,rr3,rr5,rr7 real*8 rr3i,rr5i,rr7i real*8 rr3k,rr5k,rr7k real*8 ci,dix,diy,diz real*8 qixx,qixy,qixz real*8 qiyy,qiyz,qizz real*8 ck,dkx,dky,dkz real*8 qkxx,qkxy,qkxz real*8 qkyy,qkyz,qkzz real*8 dir,dkr real*8 qix,qiy,qiz,qir real*8 qkx,qky,qkz,qkr real*8 corei,corek real*8 vali,valk real*8 alphai,alphak real*8 damp,expdamp real*8 scale3,scale5 real*8 scale7 real*8 pdi,pti,pgamma real*8 fid(3),fkd(3) real*8 dmpi(7),dmpk(7) real*8, allocatable :: dscale(:) real*8 field(3,*) c c c zero out the induced dipole and the field at each site c do ii = 1, npole i = ipole(ii) do j = 1, 3 uind(j,i) = 0.0d0 field(j,i) = 0.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (dscale(n)) c c set array needed to scale atom and group interactions c do i = 1, n dscale(i) = 1.0d0 end do c c find the electrostatic field due to permanent multipoles c do ii = 1, npole-1 i = ipole(ii) ci = rpole(1,i) dix = rpole(2,i) diy = rpole(3,i) diz = rpole(4,i) qixx = rpole(5,i) qixy = rpole(6,i) qixz = rpole(7,i) qiyy = rpole(9,i) qiyz = rpole(10,i) qizz = rpole(13,i) if (use_thole) then pdi = pdamp(i) pti = thole(i) else if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c if (dpequal) then do j = 1, n12(i) dscale(i12(j,i)) = p2scale do k = 1, np11(i) if (i12(j,i) .eq. ip11(k,i)) & dscale(i12(j,i)) = p2iscale end do end do do j = 1, n13(i) dscale(i13(j,i)) = p3scale do k = 1, np11(i) if (i13(j,i) .eq. ip11(k,i)) & dscale(i13(j,i)) = p3iscale end do end do do j = 1, n14(i) dscale(i14(j,i)) = p4scale do k = 1, np11(i) if (i14(j,i) .eq. ip11(k,i)) & dscale(i14(j,i)) = p4iscale end do end do do j = 1, n15(i) dscale(i15(j,i)) = p5scale do k = 1, np11(i) if (i15(j,i) .eq. ip11(k,i)) & dscale(i15(j,i)) = p5iscale end do end do else do j = 1, np11(i) dscale(ip11(j,i)) = d1scale end do do j = 1, np12(i) dscale(ip12(j,i)) = d2scale end do do j = 1, np13(i) dscale(ip13(j,i)) = d3scale end do do j = 1, np14(i) dscale(ip14(j,i)) = d4scale end do end if c c evaluate higher-numbered sites with the original site c do kk = ii+1, npole k = ipole(kk) xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) r2 = xr*xr + yr* yr + zr*zr r = sqrt(r2) ck = rpole(1,k) dkx = rpole(2,k) dky = rpole(3,k) dkz = rpole(4,k) qkxx = rpole(5,k) qkxy = rpole(6,k) qkxz = rpole(7,k) qkyy = rpole(9,k) qkyz = rpole(10,k) qkzz = rpole(13,k) c c intermediates involving moments and separation distance c dir = dix*xr + diy*yr + diz*zr qix = qixx*xr + qixy*yr + qixz*zr qiy = qixy*xr + qiyy*yr + qiyz*zr qiz = qixz*xr + qiyz*yr + qizz*zr qir = qix*xr + qiy*yr + qiz*zr dkr = dkx*xr + dky*yr + dkz*zr qkx = qkxx*xr + qkxy*yr + qkxz*zr qky = qkxy*xr + qkyy*yr + qkyz*zr qkz = qkxz*xr + qkyz*yr + qkzz*zr qkr = qkx*xr + qky*yr + qkz*zr c c find the field components for Thole polarization damping c if (use_thole) then damp = pdi * pdamp(k) scale3 = 1.0d0 scale5 = 1.0d0 scale7 = 1.0d0 if (damp .ne. 0.0d0) then pgamma = min(pti,thole(k)) damp = pgamma * (r/damp)**3 if (damp .lt. 50.0d0) then expdamp = exp(-damp) scale3 = 1.0d0 - expdamp scale5 = 1.0d0 - expdamp*(1.0d0+damp) scale7 = 1.0d0 - expdamp*(1.0d0+damp & +0.6d0*damp**2) end if end if rr3 = scale3 / (r*r2) rr5 = 3.0d0 * scale5 / (r*r2*r2) rr7 = 15.0d0 * scale7 / (r*r2*r2*r2) fid(1) = -xr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dkx + 2.0d0*rr5*qkx fid(2) = -yr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dky + 2.0d0*rr5*qky fid(3) = -zr*(rr3*ck-rr5*dkr+rr7*qkr) & - rr3*dkz + 2.0d0*rr5*qkz fkd(1) = xr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*dix - 2.0d0*rr5*qix fkd(2) = yr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*diy - 2.0d0*rr5*qiy fkd(3) = zr*(rr3*ci+rr5*dir+rr7*qir) & - rr3*diz - 2.0d0*rr5*qiz c c find the field components for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampdir (r,alphai,alphak,dmpi,dmpk) rr3 = 1.0d0 / (r*r2) rr5 = 3.0d0 * rr3 / r2 rr7 = 5.0d0 * rr5 / r2 rr3i = dmpi(3) * rr3 rr5i = dmpi(5) * rr5 rr7i = dmpi(7) * rr7 rr3k = dmpk(3) * rr3 rr5k = dmpk(5) * rr5 rr7k = dmpk(7) * rr7 fid(1) = -xr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkx + 2.0d0*rr5k*qkx fid(2) = -yr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dky + 2.0d0*rr5k*qky fid(3) = -zr*(rr3*corek + rr3k*valk & - rr5k*dkr + rr7k*qkr) & - rr3k*dkz + 2.0d0*rr5k*qkz fkd(1) = xr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*dix - 2.0d0*rr5i*qix fkd(2) = yr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diy - 2.0d0*rr5i*qiy fkd(3) = zr*(rr3*corei + rr3i*vali & + rr5i*dir + rr7i*qir) & - rr3i*diz - 2.0d0*rr5i*qiz end if do j = 1, 3 field(j,i) = field(j,i) + fid(j)*dscale(k) field(j,k) = field(j,k) + fkd(j)*dscale(k) end do end do c c reset exclusion coefficients for connected atoms c if (dpequal) then do j = 1, n12(i) dscale(i12(j,i)) = 1.0d0 end do do j = 1, n13(i) dscale(i13(j,i)) = 1.0d0 end do do j = 1, n14(i) dscale(i14(j,i)) = 1.0d0 end do do j = 1, n15(i) dscale(i15(j,i)) = 1.0d0 end do else do j = 1, np11(i) dscale(ip11(j,i)) = 1.0d0 end do do j = 1, np12(i) dscale(ip12(j,i)) = 1.0d0 end do do j = 1, np13(i) dscale(ip13(j,i)) = 1.0d0 end do do j = 1, np14(i) dscale(ip14(j,i)) = 1.0d0 end do end if end do c c perform deallocation of some local arrays c deallocate (dscale) return end c c c ############################################################# c ## ## c ## subroutine ufieldi -- find induced intergroup field ## c ## ## c ############################################################# c c c "ufieldi" computes the electrostatic field due to intergroup c induced dipole moments c c literature reference: c c P. Ren and J. W. Ponder, "Consistent Treatment of Inter- and c Intramolecular Polarization in Molecular Mechanics Calculations", c Journal of Computational Chemistry, 23, 1497-1506 (2002) c c subroutine ufieldi (field) use atoms use chgpen use couple use mplpot use mpole use polar use polgrp use polpot implicit none integer i,j,k integer ii,kk real*8 xr,yr,zr real*8 r,r2,rr3,rr5 real*8 uix,uiy,uiz real*8 ukx,uky,ukz real*8 uir,ukr real*8 corei,corek real*8 vali,valk real*8 alphai,alphak real*8 damp,expdamp real*8 scale3,scale5 real*8 pdi,pti,pgamma real*8 fiu(3),fku(3) real*8 dmpik(5) real*8, allocatable :: dscale(:) real*8, allocatable :: pscale(:) real*8, allocatable :: uscale(:) real*8, allocatable :: wscale(:) real*8, allocatable :: gscale(:) real*8 field(3,*) c c c zero out the value of the field at each site c do ii = 1, npole i = ipole(ii) do j = 1, 3 field(j,i) = 0.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (dscale(n)) allocate (pscale(n)) allocate (uscale(n)) allocate (wscale(n)) allocate (gscale(n)) c c set arrays needed to scale atom and group interactions c do i = 1, n dscale(i) = 1.0d0 pscale(i) = 1.0d0 uscale(i) = 1.0d0 wscale(i) = 1.0d0 gscale(i) = 0.0d0 end do c c find the electrostatic field due to induced dipoles c do ii = 1, npole-1 i = ipole(ii) uix = uind(1,i) uiy = uind(2,i) uiz = uind(3,i) if (use_thole) then pdi = pdamp(i) pti = thole(i) else if (use_chgpen) then corei = pcore(i) vali = pval(i) alphai = palpha(i) end if c c set exclusion coefficients for connected atoms c if (dpequal) then if (use_chgpen) then do j = 1, n12(i) gscale(i12(j,i)) = w2scale - p2scale do k = 1, np11(i) if (i12(j,i) .eq. ip11(k,i)) & gscale(i12(j,i)) = w2scale - p2iscale end do end do do j = 1, n13(i) gscale(i13(j,i)) = w3scale - p3scale do k = 1, np11(i) if (i13(j,i) .eq. ip11(k,i)) & gscale(i13(j,i)) = w3scale - p3iscale end do end do do j = 1, n14(i) gscale(i14(j,i)) = w4scale - p4scale do k = 1, np11(i) if (i14(j,i) .eq. ip11(k,i)) & gscale(i14(j,i)) = w4scale - p4iscale end do end do do j = 1, n15(i) gscale(i15(j,i)) = w5scale - p5scale do k = 1, np11(i) if (i15(j,i) .eq. ip11(k,i)) & gscale(i15(j,i)) = w5scale - p5iscale end do end do else 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)) = w4scale 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 do j = 1, np11(i) uscale(ip11(j,i)) = u1scale end do do j = 1, np12(i) uscale(ip12(j,i)) = u2scale end do do j = 1, np13(i) uscale(ip13(j,i)) = u3scale end do do j = 1, np14(i) uscale(ip14(j,i)) = u4scale end do do j = ii+1, npole k = ipole(j) gscale(k) = uscale(k) - pscale(k) end do end if else if (use_chgpen) then do j = 1, n12(i) wscale(i12(j,i)) = w2scale end do do j = 1, n13(i) wscale(i13(j,i)) = w3scale end do do j = 1, n14(i) wscale(i14(j,i)) = w4scale end do do j = 1, n15(i) wscale(i15(j,i)) = w5scale end do do j = 1, np11(i) dscale(ip11(j,i)) = d1scale end do do j = 1, np12(i) dscale(ip12(j,i)) = d2scale end do do j = 1, np13(i) dscale(ip13(j,i)) = d3scale end do do j = 1, np14(i) dscale(ip14(j,i)) = d4scale end do do j = ii+1, npole k = ipole(j) gscale(k) = wscale(k) - dscale(k) end do else do j = 1, np11(i) gscale(ip11(j,i)) = u1scale - d1scale end do do j = 1, np12(i) gscale(ip12(j,i)) = u2scale - d2scale end do do j = 1, np13(i) gscale(ip13(j,i)) = u3scale - d3scale end do do j = 1, np14(i) gscale(ip14(j,i)) = u4scale - d4scale end do end if end if c c evaluate higher-numbered sites with the original site c do kk = ii+1, npole k = ipole(kk) xr = x(k) - x(i) yr = y(k) - y(i) zr = z(k) - z(i) r2 = xr*xr + yr* yr + zr*zr r = sqrt(r2) ukx = uind(1,k) uky = uind(2,k) ukz = uind(3,k) c c intermediates involving moments and separation distance c uir = xr*uix + yr*uiy + zr*uiz ukr = xr*ukx + yr*uky + zr*ukz c c find the field components for Thole polarization damping c if (use_thole) then scale3 = 1.0d0 scale5 = 1.0d0 damp = pdi * pdamp(k) if (damp .ne. 0.0d0) then pgamma = min(pti,thole(k)) damp = pgamma * (r/damp)**3 if (damp .lt. 50.0d0) then expdamp = exp(-damp) scale3 = 1.0d0 - expdamp scale5 = 1.0d0 - expdamp*(1.0d0+damp) end if end if c c find the field components for charge penetration damping c else if (use_chgpen) then corek = pcore(k) valk = pval(k) alphak = palpha(k) call dampmut (r,alphai,alphak,dmpik) scale3 = dmpik(3) scale5 = dmpik(5) end if rr3 = -scale3 / (r*r2) rr5 = 3.0d0 * scale5 / (r*r2*r2) fiu(1) = rr3*ukx + rr5*ukr*xr fiu(2) = rr3*uky + rr5*ukr*yr fiu(3) = rr3*ukz + rr5*ukr*zr fku(1) = rr3*uix + rr5*uir*xr fku(2) = rr3*uiy + rr5*uir*yr fku(3) = rr3*uiz + rr5*uir*zr do j = 1, 3 field(j,i) = field(j,i) + fiu(j)*gscale(k) field(j,k) = field(j,k) + fku(j)*gscale(k) end do end do c c reset exclusion coefficients for connected atoms c if (dpequal) then if (use_chgpen) then do j = 1, n12(i) gscale(i12(j,i)) = 0.0d0 end do do j = 1, n13(i) gscale(i13(j,i)) = 0.0d0 end do do j = 1, n14(i) gscale(i14(j,i)) = 0.0d0 end do do j = 1, n15(i) gscale(i15(j,i)) = 0.0d0 end do else do j = 1, np11(i) uscale(ip11(j,i)) = 1.0d0 gscale(ip11(j,i)) = 0.0d0 end do do j = 1, np12(i) uscale(ip12(j,i)) = 1.0d0 gscale(ip12(j,i)) = 0.0d0 end do do j = 1, np13(i) uscale(ip13(j,i)) = 1.0d0 gscale(ip13(j,i)) = 0.0d0 end do do j = 1, np14(i) uscale(ip14(j,i)) = 1.0d0 gscale(ip14(j,i)) = 0.0d0 end do do j = 1, n12(i) pscale(i12(j,i)) = 1.0d0 gscale(i12(j,i)) = 0.0d0 end do do j = 1, n13(i) pscale(i13(j,i)) = 1.0d0 gscale(i13(j,i)) = 0.0d0 end do do j = 1, n14(i) pscale(i14(j,i)) = 1.0d0 gscale(i14(j,i)) = 0.0d0 end do do j = 1, n15(i) pscale(i15(j,i)) = 1.0d0 gscale(i15(j,i)) = 0.0d0 end do end if else if (use_chgpen) then do j = 1, np11(i) dscale(ip11(j,i)) = 1.0d0 gscale(ip11(j,i)) = 0.0d0 end do do j = 1, np12(i) dscale(ip12(j,i)) = 1.0d0 gscale(ip12(j,i)) = 0.0d0 end do do j = 1, np13(i) dscale(ip13(j,i)) = 1.0d0 gscale(ip13(j,i)) = 0.0d0 end do do j = 1, np14(i) dscale(ip14(j,i)) = 1.0d0 gscale(ip14(j,i)) = 0.0d0 end do do j = 1, n12(i) wscale(i12(j,i)) = 1.0d0 gscale(i12(j,i)) = 0.0d0 end do do j = 1, n13(i) wscale(i13(j,i)) = 1.0d0 gscale(i13(j,i)) = 0.0d0 end do do j = 1, n14(i) wscale(i14(j,i)) = 1.0d0 gscale(i14(j,i)) = 0.0d0 end do do j = 1, n15(i) wscale(i15(j,i)) = 1.0d0 gscale(i15(j,i)) = 0.0d0 end do else do j = 1, np11(i) gscale(ip11(j,i)) = 0.0d0 end do do j = 1, np12(i) gscale(ip12(j,i)) = 0.0d0 end do do j = 1, np13(i) gscale(ip13(j,i)) = 0.0d0 end do do j = 1, np14(i) gscale(ip14(j,i)) = 0.0d0 end do end if end if end do c c perform deallocation of some local arrays c deallocate (dscale) deallocate (pscale) deallocate (uscale) deallocate (wscale) deallocate (gscale) return end c c c ############################################################# c ## ## c ## subroutine avgpole -- condense multipole atom types ## c ## ## c ############################################################# c c c "avgpole" condenses the number of multipole atom types based c upon atoms equivalent through 1-6 connectivity, and allowing c user modification of sets of equivalent atoms c c subroutine avgpole use atomid use atoms use couple use iounit use kpolr use mpole use sizes implicit none integer i,j,k,m integer ii,it integer in,jn,kn integer ni,nati integer nj,natj integer k2,k4 integer size,numtyp integer nlist,nave integer tmin,tmax integer xaxe,yaxe,zaxe integer, allocatable :: ci(:) integer, allocatable :: cj(:) integer, allocatable :: list(:) integer, allocatable :: tsort(:) integer, allocatable :: pkey(:) integer, allocatable :: pgrt(:,:) real*8 pave(13) logical done,header,exist logical query,condense logical keep,match,diff logical useframe,symm logical yzero,xyzero character*1 answer character*4 pa,pb,pc,pd character*16 ptlast character*16, allocatable :: pt(:) character*240 record character*240 string c c c check for user requested reduction of equivalent types c condense = .true. answer = 'Y' query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) answer query = .false. end if 10 continue if (query) then write (iout,20) 20 format (/,' Condense Symmetric Atoms to Equivalent Types', & ' [Y] : ',$) read (input,30) answer 30 format (a1) end if call upcase (answer) if (answer .eq. 'N') condense = .false. c c perform dynamic allocation of some local arrays c if (condense) then allocate (ci(n)) allocate (cj(n)) size = 40 allocate (list(max(n,size))) c c condense groups of equivalent atoms to the same atom type c header = .true. do i = 1, n list(i) = 0 end do do i = 1, n-1 nati = n12(i) + n13(i) + n14(i) + n15(i) ni = nati m = 0 do k = 1, n12(i) in = i12(k,i) m = m + 1 ci(m) = 2000 + 10*atomic(in) + n12(in) end do do k = 1, n13(i) in = i13(k,i) m = m + 1 ci(m) = 3000 + 10*atomic(in) + n12(in) end do do k = 1, n14(i) in = i14(k,i) m = m + 1 ci(m) = 4000 + 10*atomic(in) + n12(in) end do do k = 1, n15(i) in = i15(k,i) m = m + 1 ci(m) = 5000 + 10*atomic(in) + n12(in) end do do k = 1, n15(i) kn = i15(k,i) do k2 = 1, n12(kn) in = i12(k2,kn) keep = .true. do k4 = 1, n14(i) if (in .eq. i14(k4,i)) keep = .false. end do if (keep) then ni = ni + 1 m = m + 1 ci(m) = 6000 * 10*atomic(in) + n12(in) end if end do end do call sort (ni,ci) do j = i+1, n if (atomic(i) .eq. atomic(j)) then natj = n12(j) + n13(j) + n14(j) + n15(j) if (natj .eq. nati) then nj = natj m = 0 do k = 1, n12(j) jn = i12(k,j) m = m + 1 cj(m) = 2000 + 10*atomic(jn) + n12(jn) end do do k = 1, n13(j) jn = i13(k,j) m = m + 1 cj(m) = 3000 + 10*atomic(jn) + n12(jn) end do do k = 1, n14(j) jn = i14(k,j) m = m + 1 cj(m) = 4000 + 10*atomic(jn) + n12(jn) end do do k = 1, n15(j) jn = i15(k,j) m = m + 1 cj(m) = 5000 + 10*atomic(jn) + n12(jn) end do do k = 1, n15(j) kn = i15(k,j) do k2 = 1, n12(kn) jn = i12(k2,kn) keep = .true. do k4 = 1, n14(j) if (jn .eq. i14(k4,j)) keep = .false. end do if (keep) then nj = nj + 1 m = m + 1 cj(m) = 6000 * 10*atomic(jn) + n12(jn) end if end do end do call sort (nj,cj) match = .true. do k = 1, ni if (ci(k) .ne. cj(k)) then match = .false. goto 40 end if 40 continue end do if (match) then tmin = min(type(i),type(j)) tmax = max(type(i),type(j)) do k = 1, n if (type(k) .eq. tmax) type(k) = tmin end do if (list(i).eq.0 .or. list(j).eq.0) then if (header) then header = .false. write (iout,50) 50 format (/,' Equivalent Atoms Assigned', & ' the Same Atom Type :',/) end if write (iout,60) i,j 60 format (' Atoms',i6,2x,'and',i6,2x, & 'Set to Equivalent Atom Types') list(i) = 1 list(j) = 1 end if end if end if end if end do end do c c perform deallocation of some local arrays c deallocate (ci) deallocate (cj) c c perform dynamic allocation of some local arrays c allocate (tsort(n)) allocate (pkey(n)) allocate (pt(n)) c c count the number of distinct atom types in the system c numtyp = 0 do i = 1, n numtyp = max(numtyp,type(i)) end do c c query for more atom sets to condense to a single type c done = .false. do while (.not. done) do i = 1, size list(i) = 0 end do write (iout,70) 70 format (/,' Enter Sets of Equivalent or Different', & ' Atoms [=Exit] : ',$) read (input,80) record 80 format (a240) read (record,*,err=90,end=90) (list(i),i=1,size) 90 continue c c add or remove the equivalence of specified sets of atoms c diff = .false. nlist = 1 if (list(1) .ne. 0) k = type(list(1)) do while (list(nlist) .ne. 0) if (type(list(nlist)) .ne. k) diff = .true. nlist = nlist + 1 end do nlist = nlist - 1 if (nlist .eq. 0) then done = .true. else if (diff) then tmin = n + 1 do i = 1, nlist tmin = min(tmin,type(list(i))) end do do i = 1, nlist k = type(list(i)) if (k .ne. tmin) then tmax = k do k = 1, n if (type(k) .eq. tmax) type(k) = tmin end do end if end do else do i = 1, nlist numtyp = numtyp + 1 type(list(i)) = numtyp end do end if end do c c renumber the atom types to give consecutive ordering c do i = 1, n tsort(i) = 0 end do m = 0 do i = 1, n k = type(i) if (tsort(k) .eq. 0) then tsort(k) = i m = m + 1 type(i) = m else type(i) = type(tsort(k)) end if end do c c set the atom class equal to the atom type for each atom c do i = 1, n class(i) = type(i) end do c c print the atoms, atom types and local frame definitions c write (iout,100) 100 format (/,' Atom Type and Local Frame Definition', & ' for Each Atom :', & //,5x,'Atom',4x,'Type',6x,'Local Frame',10x, & 'Frame Defining Atoms',/) do ii = 1, npole i = ipole(ii) write (iout,110) i,type(i),polaxe(i),zaxis(i), & xaxis(i),yaxis(i) 110 format (2i8,9x,a8,6x,3i8) end do c c identify atoms with the same atom type number, or find c atoms with equivalent local frame defining atom types c useframe = .false. do ii = 1, npole i = ipole(ii) it = type(i) zaxe = 0 xaxe = 0 yaxe = 0 if (useframe) then if (zaxis(i) .ne. 0) zaxe = type(zaxis(i)) if (xaxis(i) .ne. 0) xaxe = type(xaxis(i)) if (yaxis(i) .ne. 0) yaxe = type(yaxis(i)) end if size = 4 call numeral (it,pa,size) call numeral (zaxe,pb,size) call numeral (xaxe,pc,size) call numeral (yaxe,pd,size) pt(ii) = pa//pb//pc//pd end do call sort7 (npole,pt,pkey) c c average the multipole values at equivalent atom sites c nave = 1 ptlast = ' ' do ii = 1, npole i = pkey(ii) if (pt(ii) .eq. ptlast) then nave = nave + 1 do j = 1, 13 pave(j) = pave(j) + pole(j,i) end do if (ii .eq. npole) then do j = 1, 13 pave(j) = pave(j) / dble(nave) end do do k = 1, nave m = pkey(ii-k+1) do j = 1, 13 pole(j,m) = pave(j) end do end do end if else if (nave .ne. 1) then do j = 1, 13 pave(j) = pave(j) / dble(nave) end do do k = 1, nave m = pkey(ii-k) do j = 1, 13 pole(j,m) = pave(j) end do end do end if nave = 1 do j = 1, 13 pave(j) = pole(j,i) end do ptlast = pt(ii) end if end do c c perform deallocation of some local arrays c deallocate (list) deallocate (tsort) deallocate (pkey) deallocate (pt) end if c c perform dynamic allocation of some local arrays c allocate (pgrt(maxval,n)) c c set polarization groups over the condensed atom types c do i = 1, n do j = 1, maxval pgrt(j,i) = 0 end do end do do i = 1, npole it = type(ipole(i)) k = 0 do j = 1, maxval if (pgrp(j,i) .ne. 0) then k = j pgrp(j,it) = type(pgrp(j,i)) else pgrp(j,it) = 0 end if end do call sort8 (k,pgrp(1,it)) do j = 1, k do m = 1, maxval if (pgrt(m,it) .eq. 0) then pgrt(m,it) = pgrp(j,it) goto 120 end if end do 120 continue end do end do do i = 1, npole it = type(ipole(i)) do j = 1, maxval pgrp(j,it) = pgrt(j,it) if (pgrp(j,it) .ne. 0) k = j end do call sort8 (k,pgrp(1,it)) end do c c perform deallocation of some local arrays c deallocate (pgrt) c c regularize the multipole moments to standardized values c call fixpole c c check for user requested zeroing of moments by symmetry c symm = .true. answer = 'Y' query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=130,end=130) answer query = .false. end if 130 continue if (query) then write (iout,140) 140 format (/,' Remove Multipole Components Zeroed by', & ' Symmetry [Y] : ',$) read (input,150) answer 150 format (a1) end if call upcase (answer) if (answer .eq. 'N') symm = .false. c c remove multipole components that are zero by symmetry c if (symm) then do ii = 1, npole i = ipole(ii) xyzero = .false. yzero = .false. if (polaxe(i) .eq. 'Bisector') xyzero = .true. if (polaxe(i) .eq. 'Z-Bisect') yzero = .true. if (polaxe(i) .eq. 'Z-then-X') then if (yaxis(i) .eq. 0) yzero = .true. end if if (polaxe(i) .eq. 'None') then do j = 2, 13 pole(j,i) = 0.0d0 end do end if if (polaxe(i) .eq. 'Z-Only') then pole(2,i) = 0.0d0 pole(3,i) = 0.0d0 pole(5,i) = -0.5d0 * pole(13,i) pole(6,i) = 0.0d0 pole(7,i) = 0.0d0 pole(8,i) = 0.0d0 pole(9,i) = pole(5,i) pole(10,i) = 0.0d0 pole(11,i) = 0.0d0 pole(12,i) = 0.0d0 end if if (xyzero) then pole(2,i) = 0.0d0 pole(3,i) = 0.0d0 pole(6,i) = 0.0d0 pole(7,i) = 0.0d0 pole(8,i) = 0.0d0 pole(10,i) = 0.0d0 pole(11,i) = 0.0d0 pole(12,i) = 0.0d0 end if if (yzero) then pole(3,i) = 0.0d0 pole(6,i) = 0.0d0 pole(8,i) = 0.0d0 pole(10,i) = 0.0d0 pole(12,i) = 0.0d0 end if end do end if c c print the final multipole values for force field use c write (iout,160) 160 format (/,' Final Atomic Multipole Moments after', & ' Regularization :') do i = 1, n ii = pollist(i) if (ii .eq. 0) then write (iout,170) i,name(i),atomic(i) 170 format (/,' Atom:',i8,9x,'Name:',3x,a3, & 7x,'Atomic Number:',i8) write (iout,180) 180 format (/,' No Atomic Multipole Moments for this Site') else zaxe = zaxis(i) xaxe = xaxis(i) yaxe = yaxis(i) if (yaxe .lt. 0) yaxe = -yaxe write (iout,190) i,name(i),atomic(i) 190 format (/,' Atom:',i8,9x,'Name:',3x,a3, & 7x,'Atomic Number:',i8) write (iout,200) polaxe(i),zaxe,xaxe,yaxe 200 format (/,' Local Frame:',12x,a8,6x,3i8) write (iout,210) pole(1,i) 210 format (/,' Charge:',10x,f15.5) write (iout,220) pole(2,i),pole(3,i),pole(4,i) 220 format (' Dipole:',10x,3f15.5) write (iout,230) pole(5,i) 230 format (' Quadrupole:',6x,f15.5) write (iout,240) pole(8,i),pole(9,i) 240 format (18x,2f15.5) write (iout,250) pole(11,i),pole(12,i),pole(13,i) 250 format (18x,3f15.5) end if end do return end c c c ################################################################ c ## ## c ## subroutine fixpole -- regularize the multipole moments ## c ## ## c ################################################################ c c c "fixpole" performs unit conversion of the multipole components, c rounds moments to desired precision, and enforces integer net c charge and traceless quadrupoles c c subroutine fixpole use atoms use mpole use units implicit none integer i,j,k,m integer ii,it,ktype integer, allocatable :: equiv(:) real*8 eps,sum,big real*8 ival,kval c c c convert dipole and quadrupole moments to atomic units c do ii = 1, npole i = ipole(ii) pole(1,i) = pole(1,i) do j = 2, 4 pole(j,i) = pole(j,i) / bohr end do do j = 5, 13 pole(j,i) = 3.0d0 * pole(j,i) / bohr**2 end do end do c c regularize multipole moments to desired precision c eps = 0.00001d0 do ii = 1, npole i = ipole(ii) do j = 1, 13 pole(j,i) = dble(nint(pole(j,i)/eps)) * eps end do end do c c perform dynamic allocation of some local arrays c allocate (equiv(maxtyp)) c c enforce integer net charge over atomic multipoles c do i = 1, maxtyp equiv(i) = 0 end do ktype = 0 sum = 0.0d0 do ii = 1, npole i = ipole(ii) it = type(ipole(i)) equiv(it) = equiv(it) + 1 sum = sum + pole(1,i) end do sum = sum - dble(nint(sum)) k = nint(abs(sum)/eps) do j = 1, k m = k / j if (k .eq. m*j) then do ii = 1, npole i = ipole(ii) it = type(i) if (equiv(it) .eq. m) then ival = abs(pole(1,i)) if (ktype .eq. 0) then ktype = it kval = ival else if (ival .gt. kval) then ktype = it kval = ival end if end if end do end if if (ktype .ne. 0) goto 10 end do 10 continue if (ktype .ne. 0) then sum = sum / dble(m) do ii = 1, npole i = ipole(ii) it = type(i) if (it .eq. ktype) pole(1,i) = pole(1,i) - sum end do end if c c perform deallocation of some local arrays c deallocate (equiv) c c enforce traceless quadrupole at each multipole site c do ii = 1, npole i = ipole(ii) sum = pole(5,i) + pole(9,i) + pole(13,i) big = max(abs(pole(5,i)),abs(pole(9,i)),abs(pole(13,i))) k = 0 if (big .eq. abs(pole(5,i))) k = 5 if (big .eq. abs(pole(9,i))) k = 9 if (big .eq. abs(pole(13,i))) k = 13 if (k .ne. 0) pole(k,i) = pole(k,i) - sum end do return end c c c ################################################################# c ## ## c ## subroutine prtpole -- create file with final multipoles ## c ## ## c ################################################################# c c c "prtpole" creates a coordinates file, and a key file with c atomic multipoles corrected for intergroup polarization c c subroutine prtpole use atoms use atomid use chgpen use files use keys use kpolr use mplpot use mpole use polar use polpot use sizes use units implicit none integer i,j,k integer ii,it,ic integer ixyz,ikey integer size,atlast integer xaxe,yaxe,zaxe integer freeunit,trimtext integer, allocatable :: at(:) integer, allocatable :: atkey(:) integer, allocatable :: ptkey(:) character*4 pa,pb,pc,pd character*16 ptlast character*16, allocatable :: pt(:) character*240 keyfile character*240 record c c c create a file with coordinates and connectivities c ixyz = freeunit () call prtxyz (ixyz) c c output some definitions and parameters to a keyfile c ikey = freeunit () keyfile = filename(1:leng)//'.key' call version (keyfile,'new') open (unit=ikey,file=keyfile,status='new') c c copy the contents of any previously existing keyfile c do i = 1, nkey record = keyline(i) size = trimtext (record) write (ikey,10) record(1:size) 10 format (a) end do if (nkey .ne. 0) then write (ikey,20) 20 format () end if c c perform dynamic allocation of some local arrays c allocate (at(npole)) allocate (atkey(npole)) allocate (pt(npole)) allocate (ptkey(npole)) c c locate the equivalently defined atom type sites c do ii = 1, npole i = ipole(ii) at(ii) = type(i) end do call sort3 (npole,at,atkey) c c output the atom definitions to the keyfile as appropriate c atlast = 0 do ii = 1, npole i = atkey(ii) it = type(i) if (it .ne. atlast) then atlast = it write (ikey,30) type(i),class(i),name(i),story(i), & atomic(i),mass(i),valence(i) 30 format ('atom',6x,2i5,4x,a3,3x,'"',a20,'"',i10,f10.3,i5) end if end do if (npole .ne. 0) then write (ikey,40) 40 format () end if c c locate the equivalently defined multipole sites c do ii = 1, npole i = ipole(ii) it = type(i) zaxe = 0 xaxe = 0 yaxe = 0 if (zaxis(i) .ne. 0) zaxe = type(zaxis(i)) if (xaxis(i) .ne. 0) xaxe = type(xaxis(i)) if (yaxis(i) .ne. 0) yaxe = type(yaxis(i)) size = 4 call numeral (it,pa,size) call numeral (zaxe,pb,size) call numeral (xaxe,pc,size) call numeral (yaxe,pd,size) pt(ii) = pa//pb//pc//pd end do call sort7 (npole,pt,ptkey) c c output the local frame multipole values to the keyfile c ptlast = ' ' do ii = 1, npole i = ptkey(ii) it = type(ipole(i)) if (pt(ii) .ne. ptlast) then ptlast = pt(ii) zaxe = 0 xaxe = 0 yaxe = 0 if (zaxis(i) .ne. 0) zaxe = type(zaxis(i)) if (xaxis(i) .ne. 0) xaxe = type(xaxis(i)) if (yaxis(i) .ne. 0) yaxe = type(yaxis(i)) if (polaxe(i) .eq. 'None') then write (ikey,50) it,pole(1,i) 50 format ('multipole',1x,i5,21x,f11.5) else if (polaxe(i) .eq. 'Z-Only') then write (ikey,60) it,zaxe,pole(1,i) 60 format ('multipole',1x,2i5,16x,f11.5) else if (polaxe(i) .eq. 'Z-then-X') then if (yaxis(i) .eq. 0) then write (ikey,70) it,zaxe,xaxe,pole(1,i) 70 format ('multipole',1x,3i5,11x,f11.5) else write (ikey,80) it,zaxe,xaxe,yaxe,pole(1,i) 80 format ('multipole',1x,4i5,6x,f11.5) end if else if (polaxe(i) .eq. 'Bisector') then if (yaxis(i) .eq. 0) then write (ikey,90) it,-zaxe,-xaxe,pole(1,i) 90 format ('multipole',1x,3i5,11x,f11.5) else write (ikey,100) it,-zaxe,-xaxe,yaxe,pole(1,i) 100 format ('multipole',1x,4i5,6x,f11.5) end if else if (polaxe(i) .eq. 'Z-Bisect') then write (ikey,110) it,zaxe,-xaxe,-yaxe,pole(1,i) 110 format ('multipole',1x,4i5,6x,f11.5) else if (polaxe(i) .eq. '3-Fold') then write (ikey,120) it,-zaxe,-xaxe,-yaxe,pole(1,i) 120 format ('multipole',1x,4i5,6x,f11.5) end if write (ikey,130) pole(2,i),pole(3,i),pole(4,i) 130 format (36x,3f11.5) write (ikey,140) pole(5,i) 140 format (36x,f11.5) write (ikey,150) pole(8,i),pole(9,i) 150 format (36x,2f11.5) write (ikey,160) pole(11,i),pole(12,i),pole(13,i) 160 format (36x,3f11.5) end if end do c c output any charge penetration parameters to the keyfile c if (use_chgpen) then if (n .ne. 0) then write (ikey,170) 170 format () end if atlast = 0 do ii = 1, npole i = atkey(ii) it = class(i) if (it .ne. atlast) then atlast = it write (ikey,180) it,pcore(i),palpha(i) 180 format ('chgpen',9x,i5,5x,2f11.4) end if end do end if c c output the polarizability parameters to the keyfile c if (n .ne. 0) then write (ikey,190) 190 format () end if atlast = 0 do ii = 1, npole i = atkey(ii) it = type(i) if (it .ne. atlast) then atlast = it k = 0 do j = 1, maxval if (pgrp(j,it) .ne. 0) k = j end do call sort8 (k,pgrp(1,it)) if (use_thole) then write (ikey,200) it,polarity(i),thole(i), & (pgrp(j,it),j=1,k) 200 format ('polarize',7x,i5,5x,2f11.4,2x,20i5) else if (use_chgpen) then write (ikey,210) it,polarity(i),(pgrp(j,it),j=1,k) 210 format ('polarize',7x,i5,5x,f11.4,6x,20i7) end if end if end do close (unit=ikey) c c perform deallocation of some local arrays c deallocate (at) deallocate (atkey) deallocate (pt) deallocate (ptkey) return end c c c ################################################### c ## COPYRIGHT (C) 2001 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module polgrp -- polarization group connectivity lists ## c ## ## c ################################################################# c c c maxp11 maximum number of atoms in a polarization group c maxp12 maximum number of atoms in groups 1-2 to an atom c maxp13 maximum number of atoms in groups 1-3 to an atom c maxp14 maximum number of atoms in groups 1-4 to an atom c c np11 number of atoms in polarization group of each atom c np12 number of atoms in groups 1-2 to each atom c np13 number of atoms in groups 1-3 to each atom c np14 number of atoms in groups 1-4 to each atom c ip11 atom numbers of atoms in same group as each atom c ip12 atom numbers of atoms in groups 1-2 to each atom c ip13 atom numbers of atoms in groups 1-3 to each atom c ip14 atom numbers of atoms in groups 1-4 to each atom c c module polgrp implicit none integer maxp11,maxp12 integer maxp13,maxp14 parameter (maxp11=200) parameter (maxp12=200) parameter (maxp13=200) parameter (maxp14=200) integer, allocatable :: np11(:) integer, allocatable :: np12(:) integer, allocatable :: np13(:) integer, allocatable :: np14(:) integer, allocatable :: ip11(:,:) integer, allocatable :: ip12(:,:) integer, allocatable :: ip13(:,:) integer, allocatable :: ip14(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 2018 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module polopt -- induced dipoles for OPT extrapolation ## c ## ## c ################################################################ c c c maxopt maximum order for OPT induced dipole extrapolation c c optorder highest coefficient order for OPT dipole extrapolation c optlevel current OPT order for reciprocal potential and field c copt coefficients for OPT total induced dipole moments c copm coefficients for OPT incremental induced dipole moments c uopt OPT induced dipole components at each multipole site c uoptp OPT induced dipoles in field used for energy terms c uopts OPT GK or PB induced dipoles at each multipole site c uoptps OPT induced dipoles in field used for GK or PB energy c fopt OPT fractional reciprocal potentials at multipole sites c foptp OPT fractional reciprocal potentials for energy terms c c module polopt implicit none integer maxopt parameter (maxopt=6) integer optorder integer optlevel real*8, allocatable :: copt(:) real*8, allocatable :: copm(:) real*8, allocatable :: uopt(:,:,:) real*8, allocatable :: uoptp(:,:,:) real*8, allocatable :: uopts(:,:,:) real*8, allocatable :: uoptps(:,:,:) real*8, allocatable :: fopt(:,:,:) real*8, allocatable :: foptp(:,:,:) save end c c c ################################################### c ## COPYRIGHT (C) 2013 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## module polpcg -- induced dipoles via the PCG solver ## c ## ## c ############################################################# c c c mindex index into preconditioner inverse for PCG solver c pcgpeek value of acceleration factor for PCG peek step c minv preconditioner inverse for induced dipole PCG solver c pcgprec flag to allow use of preconditioner with PCG solver c pcgguess flag to use initial PCG based on direct field c c module polpcg implicit none integer, allocatable :: mindex(:) real*8 pcgpeek real*8, allocatable :: minv(:) logical pcgprec logical pcgguess save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module polpot -- polarization functional form details ## c ## ## c ############################################################### c c c politer maximum number of induced dipole SCF iterations c poleps induced dipole convergence criterion (rms Debye/atom) c p2scale scale factor for 1-2 polarization energy interactions c p3scale scale factor for 1-3 polarization energy interactions c p4scale scale factor for 1-4 polarization energy interactions c p5scale scale factor for 1-5 polarization energy interactions c p2iscale scale factor for 1-2 intragroup polarization energy c p3iscale scale factor for 1-3 intragroup polarization energy c p4iscale scale factor for 1-4 intragroup polarization energy c p5iscale scale factor for 1-5 intragroup polarization energy c d1scale scale factor for intra-group direct induction c d2scale scale factor for 1-2 group direct induction c d3scale scale factor for 1-3 group direct induction c d4scale scale factor for 1-4 group direct induction c u1scale scale factor for intra-group mutual induction c u2scale scale factor for 1-2 group mutual induction c u3scale scale factor for 1-3 group mutual induction c u4scale scale factor for 1-4 group mutual induction c w2scale scale factor for 1-2 induced dipole interactions c w3scale scale factor for 1-3 induced dipole interactions c w4scale scale factor for 1-4 induced dipole interactions c w5scale scale factor for 1-5 induced dipole interactions c uaccel acceleration factor for induced dipole SCF iterations c polprt flag to print summary of induced dipole iterations c dpequal flag to set dscale values equal to pscale values c use_thole flag to use Thole damped polarization interactions c use_tholed flag to use alternate Thole for direct polarization c use_expol flag to use damped exchange polarization correction c scrtyp type of exchange polarization (S2U, S2 or G) c poltyp type of polarization (MUTUAL, DIRECT, OPT or TCG) c c module polpot implicit none integer politer real*8 poleps real*8 p2scale,p3scale real*8 p4scale,p5scale real*8 p2iscale,p3iscale real*8 p4iscale,p5iscale real*8 d1scale,d2scale real*8 d3scale,d4scale real*8 u1scale,u2scale real*8 u3scale,u4scale real*8 w2scale,w3scale real*8 w4scale,w5scale real*8 uaccel logical polprt logical dpequal logical use_thole logical use_tholed logical use_expol character*3 scrtyp character*6 poltyp save end c c c ############################################################# c ## COPYRIGHT (C) 2018 by Zhi Wang and Jay William Ponder ## c ## All Rights Reserved ## c ############################################################# c c ############################################################# c ## ## c ## module poltcg -- induced dipoles via the TCG solver ## c ## ## c ############################################################# c c c tcgorder total number of TCG iterations to be used c tcgnab number of mutual induced dipole components c tcgpeek value of acceleration factor for TCG peek step c uad left-hand side mutual induced d-dipoles c uap left-hand side mutual induced p-dipoles c ubd right-hand side mutual induced d-dipoles c ubp right-hand side mutual induced p-dipoles c tcgguess flag to use initial TCG based on direct field c c module poltcg implicit none integer tcgorder integer tcgnab real*8 tcgpeek real*8, allocatable :: uad(:,:,:) real*8, allocatable :: uap(:,:,:) real*8, allocatable :: ubd(:,:,:) real*8, allocatable :: ubp(:,:,:) logical tcgguess save end c c c ################################################### c ## COPYRIGHT (C) 2001 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine polymer -- check for an infinite polymer ## c ## ## c ############################################################# c c c "polymer" tests for the presence of an infinite polymer c extending across periodic boundaries c c subroutine polymer use atoms use bndstr use bound use boxes use iounit use keys implicit none integer i,j,next integer ia,ib real*8 xr,yr,zr real*8 xab,yab,zab real*8 eps,delta real*8 xlimit real*8 ylimit real*8 zlimit real*8 maximage character*20 keyword character*240 record character*240 string c c c set defaults of infinite polymer usage and cutoff distance c use_polymer = .false. polycut = 5.5d0 c c get any keywords containing infinite polymer cutoff parameters c do j = 1, nkey next = 1 record = keyline(j) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:15) .eq. 'POLYMER-CUTOFF ') then string = record(next:240) read (string,*,err=10,end=10) polycut 10 continue end if end do c c see if any bond connections require a minimum image c if (use_bounds) then eps = 0.0001d0 do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) xab = x(ia) - x(ib) yab = y(ia) - y(ib) zab = z(ia) - z(ib) xr = xab yr = yab zr = zab call image (xr,yr,zr) delta = abs(xr-xab) + abs(yr-yab) + abs(zr-zab) if (delta .gt. eps) then use_polymer = .true. goto 20 end if end do 20 continue end if c c find the maximum sphere radius inscribed in periodic box c if (use_polymer) then if (orthogonal) then xlimit = xbox2 ylimit = ybox2 zlimit = zbox2 else if (monoclinic) then xlimit = xbox2 * beta_sin ylimit = ybox2 zlimit = zbox2 * beta_sin else if (triclinic) then xlimit = xbox2 * beta_sin * gamma_sin ylimit = ybox2 * gamma_sin zlimit = zbox2 * beta_sin else if (octahedron) then xlimit = (sqrt(3.0d0)/4.0d0) * xbox ylimit = xlimit zlimit = xlimit else if (dodecadron) then xlimit = xbox2 ylimit = xlimit zlimit = xlimit end if maximage = min(xlimit,ylimit,zlimit) c c check for too large or small an infinite polymer cutoff c if (polycut .gt. maximage) then write (iout,30) 30 format (/,' POLYMER -- Image Conflicts for Infinite', & ' Polymer in Small Cell') call fatal else if (polycut .lt. 5.5d0) then write (iout,40) 40 format (/,' POLYMER -- Warning, Infinite Polymer', & ' Cutoff may be Too Small') end if end if c c set square of cutoff distance for use with nonbonded terms c polycut2 = polycut * polycut return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module potent -- usage of potential energy components ## c ## ## c ############################################################### c c c use_bond logical flag governing use of bond stretch potential c use_angle logical flag governing use of angle bend potential c use_strbnd logical flag governing use of stretch-bend potential c use_urey logical flag governing use of Urey-Bradley potential c use_angang logical flag governing use of angle-angle cross term c use_opbend logical flag governing use of out-of-plane bend term c use_opdist logical flag governing use of out-of-plane distance c use_improp logical flag governing use of improper dihedral term c use_imptor logical flag governing use of improper torsion term c use_tors logical flag governing use of torsional potential c use_pitors logical flag governing use of pi-system torsion term c use_strtor logical flag governing use of stretch-torsion term c use_angtor logical flag governing use of angle-torsion term c use_tortor logical flag governing use of torsion-torsion term c use_vdw logical flag governing use of van der Waals potential c use_repel logical flag governing use of Pauli repulsion term c use_disp logical flag governing use of dispersion potential c use_charge logical flag governing use of charge-charge potential c use_chgdpl logical flag governing use of charge-dipole potential c use_dipole logical flag governing use of dipole-dipole potential c use_mpole logical flag governing use of multipole potential c use_polar logical flag governing use of polarization term c use_chgtrn logical flag governing use of charge transfer term c use_chgflx logical flag governing use of charge flux term c use_rxnfld logical flag governing use of reaction field term c use_solv logical flag governing use of continuum solvation term c use_metal logical flag governing use of ligand field term c use_geom logical flag governing use of geometric restraints c use_extra logical flag governing use of extra potential term c use_born logical flag governing use of Born radii values c use_orbit logical flag governing use of pisystem computation c use_mutate logical flag governing use of hybrid potential terms c c module potent implicit none logical use_bond,use_angle logical use_strbnd,use_urey logical use_angang,use_opbend logical use_opdist,use_improp logical use_imptor,use_tors logical use_pitors,use_strtor logical use_angtor,use_tortor logical use_vdw,use_repel logical use_disp,use_charge logical use_chgdpl,use_dipole logical use_mpole,use_polar logical use_chgtrn,use_chgflx logical use_rxnfld,use_solv logical use_metal,use_geom logical use_extra,use_born logical use_orbit,use_mutate save end c c c ############################################################## c ## COPYRIGHT (C) 2008 by C. Wu, Zhifeng Jing & Jay Ponder ## c ## All Rights Reserved ## c ############################################################## c c ############################################################## c ## ## c ## program potential -- electrostatic potential utility ## c ## ## c ############################################################## c c c "potential" calculates the electrostatic potential for a c molecule at a set of grid points; optionally compares to a c target potential or optimizes electrostatic parameters c c program potential use atoms use charge use files use inform use iounit use keys use mpole use neigh use potent use potfit use titles use units implicit none integer i,j,k integer ixyz,ipot integer igrd,icub integer next,mode integer nvar,nmodel integer nresid integer numkey integer maxpgrd integer nglist,nflist integer freeunit integer trimtext integer, allocatable :: glist(:) integer, allocatable :: flist(:) real*8 xi,yi,zi,pot real*8 x0,y0,z0 real*8 xx0,xy0,xz0 real*8 yy0,yz0,zz0 real*8 grdmin real*8, allocatable :: xx(:) real*8, allocatable :: xlo(:) real*8, allocatable :: xhi(:) real*8, allocatable :: gc(:) real*8, allocatable :: presid(:) real*8, allocatable :: pjac(:,:) logical exist,query logical dogrid,docube logical domodel,dopair logical dotarget,dofit logical dofull logical, allocatable :: tmpchg(:) logical, allocatable :: tmppol(:) logical, allocatable :: tmpcpen(:) character*1 answer,ax character*20 keyword character*240 record character*240 string character*240 xyzfile character*240 xyz2file character*240 potfile character*240 gridfile character*240 cubefile external fitrsd external potwrt c c c setup the computation and assign some default values c call initial nmodel = 1 dogrid = .false. docube = .false. domodel = .false. dopair = .false. dotarget = .false. dofit = .false. resptyp = 'ORIG' wresp = 1.0d0 c c perform dynamic allocation of some global arrays c maxpgrd = 100000 allocate (ipgrid(maxpgrd,maxref)) allocate (pgrid(3,maxpgrd,maxref)) allocate (epot(2,maxpgrd,maxref)) c c initialize target molecular dipole and quadrupole values c use_dpl = .false. use_qpl = .false. fit_mpl = .true. fit_dpl = .true. fit_qpl = .true. fit_chgpen = .true. do i = 1, maxref xdpl0(i) = 0.0d0 ydpl0(i) = 0.0d0 zdpl0(i) = 0.0d0 xxqpl0(i) = 0.0d0 xyqpl0(i) = 0.0d0 xzqpl0(i) = 0.0d0 yyqpl0(i) = 0.0d0 yzqpl0(i) = 0.0d0 zzqpl0(i) = 0.0d0 end do c c find electrostatic potential manipulation to perform c 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 Electrostatic Potential Utility Can :', & //,4x,'(1) Create Grid Points for Computing Potential', & /,4x,'(2) Get QM Potential from a Gaussian CUBE File', & /,4x,'(3) Calculate the Model Potential for a System', & /,4x,'(4) Compare Two Model Potentials for a System', & /,4x,'(5) Compare a Model Potential to a Target Grid', & /,4x,'(6) Fit Electrostatic Parameters to Target Grid') do while (mode.lt.1 .or. mode.gt.6) 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 if (mode .eq. 1) then dogrid = .true. else if (mode .eq. 2) then docube = .true. else if (mode .eq. 3) then domodel = .true. else if (mode .eq. 4) then nmodel = 2 dopair = .true. else if (mode .eq. 5) then dotarget = .true. else if (mode .eq. 6) then dotarget = .true. dofit = .true. end if c c read electrostatic potential from a Gaussian CUBE file c if (docube) then call nextarg (cubefile,exist) if (exist) then call basefile (cubefile) call suffix (cubefile,'cube','old') inquire (file=cubefile,exist=exist) end if do while (.not. exist) write (iout,60) 60 format (/,' Enter the Gaussian CUBE File Name : ',$) read (input,70) cubefile 70 format (a240) call basefile (cubefile) call suffix (cubefile,'cube','old') inquire (file=cubefile,exist=exist) end do icub = freeunit () open (unit=icub,file=cubefile,status ='old') rewind (unit=icub) read (icub,80) title 80 format (1x,a240) ltitle = trimtext (title) read (icub,90) 90 format () read (icub,100) n 100 format (i5) read (icub,110) npgrid(1) 110 format (i5) do i = 1, n+2 read (icub,120) 120 format () end do do i = 1, npgrid(1) read (icub,130) record 130 format (a240) read (record,*) xi,yi,zi,pot pgrid(1,i,1) = xi pgrid(2,i,1) = yi pgrid(3,i,1) = zi epot(1,i,1) = hartree * pot end do close (unit=icub) c c write the electrostatic potential to a Tinker POT file c potfile = filename(1:leng) call suffix (potfile,'pot','new') ipot = freeunit () open (unit=ipot,file=potfile,status ='new') rewind (unit=ipot) write (ipot,140) npgrid(1),title(1:ltitle) 140 format (i8,2x,a) do i = 1, npgrid(1) xi = pgrid(1,i,1) yi = pgrid(2,i,1) zi = pgrid(3,i,1) pot = epot(1,i,1) write (ipot,150) i,xi,yi,zi,pot 150 format (i8,3x,3f12.6,2x,f12.4) end do close (unit=ipot) write (iout,160) potfile(1:trimtext(potfile)) 160 format (/,' Electrostatic Potential Written To : ',a) goto 410 end if c c read the first structure and setup atom definitions c call getxyz call field call katom c c reopen the structure file and get all the structures c ixyz = freeunit () xyzfile = filename call suffix (xyzfile,'xyz','old') open (unit=ixyz,file=xyzfile,status ='old') rewind (unit=ixyz) call readxyz (ixyz) nconf = 0 namax = n do while (.not. abort) nconf = nconf + 1 call makeref (nconf) call readxyz (ixyz) namax = max(namax,n) end do close (unit=ixyz) if (nconf .gt. 1) then write (iout,170) nconf 170 format (/,' Structures Used for Potential Analysis :',3x,i16) end if c c perform dynamic allocation of some global arrays c allocate (gatm(namax)) allocate (fatm(namax)) allocate (fxdpl(namax)) allocate (fydpl(namax)) allocate (fzdpl(namax)) c c perform dynamic allocation of some local arrays c allocate (glist(namax)) allocate (flist(namax)) c c set defaults for the active grid atoms and fit atoms c nglist = 0 nflist = 0 ngatm = namax nfatm = namax do i = 1, namax glist(i) = 0 flist(i) = 0 gatm(i) = .true. fatm(i) = .true. fxdpl(i) = .true. fydpl(i) = .true. fzdpl(i) = .true. end do c c get control parameters and target values from keyfile c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:16) .eq. 'POTENTIAL-ATOMS ') then read (string,*,err=180,end=180) (glist(k),k=nglist+1,namax) 180 continue do while (glist(nglist+1) .ne. 0) nglist = nglist + 1 glist(nglist) = max(-namax,min(namax,glist(nglist))) end do else if (keyword(1:14) .eq. 'POTENTIAL-FIT ') then read (string,*,err=190,end=190) (flist(k),k=nflist+1,namax) 190 continue do while (flist(nflist+1) .ne. 0) nflist = nflist + 1 flist(nflist) = max(-namax,min(namax,flist(nflist))) end do else if (keyword(1:9) .eq. 'RESPTYPE ') then call getword (record,resptyp,next) call upcase (resptyp) else if (keyword(1:12) .eq. 'RESP-WEIGHT ') then read (string,*,err=200,end=200) wresp 200 continue else if (keyword(1:13) .eq. 'FIX-MONOPOLE ') then fit_mpl = .false. else if (keyword(1:11) .eq. 'FIX-DIPOLE ') then fit_dpl = .false. else if (keyword(1:16) .eq. 'FIX-ATOM-DIPOLE ') then read (string,*,err=210,end=210) k,ax call upcase (ax) 210 continue if (ax .eq. 'X') then fxdpl(k) = .false. else if (ax .eq. 'Y') then fydpl(k) = .false. else if (ax .eq. 'Z') then fzdpl(k) = .false. end if else if (keyword(1:15) .eq. 'FIX-QUADRUPOLE ') then fit_qpl = .false. else if (keyword(1:11) .eq. 'FIX-CHGPEN ') then fit_chgpen = .false. else if (keyword(1:14) .eq. 'TARGET-DIPOLE ') then use_dpl = .true. k = 1 read (string,*,err=220,end=220) x0,y0,z0,k 220 continue xdpl0(k) = x0 ydpl0(k) = y0 zdpl0(k) = z0 else if (keyword(1:18) .eq. 'TARGET-QUADRUPOLE ') then use_qpl = .true. k = 1 read (string,*,err=230,end=230) xx0,xy0,xz0,yy0,yz0,zz0,k 230 continue xxqpl0(k) = xx0 xyqpl0(k) = xy0 xzqpl0(k) = xz0 yyqpl0(k) = yy0 yzqpl0(k) = yz0 zzqpl0(k) = zz0 end if end do c c set active grid atoms to only those marked for use c i = 1 do while (glist(i) .ne. 0) if (i .eq. 1) then ngatm = 0 do k = 1, namax gatm(k) = .false. end do end if if (glist(i) .gt. 0) then k = glist(i) if (.not. gatm(k)) then gatm(k) = .true. ngatm = ngatm + 1 end if i = i + 1 else do k = abs(glist(i)), abs(glist(i+1)) if (.not. gatm(k)) then gatm(k) = .true. ngatm = ngatm + 1 end if end do i = i + 2 end if end do c c set active fitting atoms to only those marked for use c i = 1 do while (flist(i) .ne. 0) if (i .eq. 1) then nfatm = 0 do k = 1, namax fatm(k) = .false. end do end if if (flist(i) .gt. 0) then k = flist(i) if (.not. fatm(k)) then fatm(k) = .true. nfatm = nfatm + 1 end if i = i + 1 else do k = abs(flist(i)), abs(flist(i+1)) if (.not. fatm(k)) then fatm(k) = .true. nfatm = nfatm + 1 end if end do i = i + 2 end if end do c c perform deallocation of some local arrays c deallocate (glist) deallocate (flist) c c generate potential grid based on the molecular surface c if (.not. dotarget) then do i = 1, nconf call getref (i) call potgrid (i) end do end if c c get name of optional second structure for comparison c if (dopair) then call nextarg (xyz2file,exist) if (exist) then call basefile (xyz2file) call suffix (xyz2file,'xyz','old') inquire (file=xyz2file,exist=exist) end if do while (.not. exist) write (iout,240) 240 format (/,' Enter Name of Second Coordinate File : ',$) read (input,250) xyz2file 250 format (a240) call basefile (xyz2file) call suffix (xyz2file,'xyz','old') inquire (file=xyz2file,exist=exist) end do end if c c get optional file with grid points and target potential c if (dotarget) then call nextarg (potfile,exist) if (exist) then call basefile (potfile) call suffix (potfile,'pot','old') inquire (file=potfile,exist=exist) end if do while (.not. exist) write (iout,260) 260 format (/,' Enter Target Grid/Potential File Name : ',$) read (input,270) potfile 270 format (a240) call basefile (potfile) call suffix (potfile,'pot','old') inquire (file=potfile,exist=exist) end do end if c c decide whether to output potential at each grid point c dofull = .false. if (domodel .or. dopair .or. dotarget) then call nextarg (answer,exist) if (.not. exist) then write (iout,280) 280 format (/,' Output Potential Value at Each Grid Point', & ' [N] : ',$) read (input,290) record 290 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') dofull = .true. end if c c read grid points where potential will be computed c if (dotarget) then ipot = freeunit () open (unit=ipot,file=potfile,status='old') rewind (unit=ipot) do i = 1, nconf call getref (i) call readpot (ipot,i) end do close (unit=ipot) end if c c output the number of potential grid points to be used c do i = 1, nconf if (i .eq. 1) then write (iout,300) 300 format () end if if (npgrid(i) .gt. maxpgrd) then write (iout,310) 310 format (' POTENTIAL -- Too many Grid Points;', & ' Increase MAXGRID') call fatal else if (nconf .eq. 1) then write (iout,320) npgrid(1) 320 format (' Electrostatic Potential Grid Points :',6x,i16) else write (iout,330) i,npgrid(i) 330 format (' Potential Grid Points for Structure',i4,' :', & 2x,i16) end if end do c c output grid points at which to compute QM potential c if (dogrid) then igrd = freeunit () gridfile = filename(1:leng) call suffix (gridfile,'grid','new') open (unit=igrd,file=gridfile,status='new') do j = 1, nconf do i = 1, npgrid(j) xi = pgrid(1,i,j) yi = pgrid(2,i,j) zi = pgrid(3,i,j) write (igrd,340) xi,yi,zi 340 format (3f15.8) end do end do close (unit=igrd) write (iout,350) gridfile(1:trimtext(gridfile)) 350 format (/,' Gaussian CUBEGEN Input Written To : ',a) write (iout,360) 360 format (/,' Next, run the Gaussian CUBEGEN program; for', & ' example:', & //,' cubegen 0 potential=MP2 FILE.fchk FILE.cube', & ' -5 h < FILE.grid', & //,' Replace FILE with base file name and MP2 with', & ' density label;', & /,' After CUBEGEN, rerun Tinker POTENTIAL program', & ' using Option 2') end if c c get termination criterion for fitting as RMS gradient c if (dofit) then grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=370,end=370) grdmin 370 continue if (grdmin .le. 0.0d0) then write (iout,380) 380 format (/,' Enter RMS Gradient Termination Criterion', & ' [0.01] : ',$) read (input,390) grdmin 390 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.01d0 end if c c print the parameter restraint value to be used in fitting c if (dofit) then write (iout,400) wresp 400 format (/,' Electrostatic Parameter Restraint Value :',f18.4) end if c c setup the potential computation for alternative models c if (.not. dogrid) then do k = 1, nmodel ixyz = freeunit () if (k .eq. 1) then call basefile (xyzfile) open (unit=ixyz,file=xyzfile,status='old') else call basefile (xyz2file) open (unit=ixyz,file=xyz2file,status='old') end if rewind (unit=ixyz) do j = 1, nconf call readxyz (ixyz) call makeref (j) end do close (unit=ixyz) c c get potential for each structure and print statistics c do j = 1, nconf call getref (j) call field call setelect if (use_chgflx) then call alterchg end if if (use_mpole) then call chkpole call rotpole ('MPOLE') end if if (use_polar) then domlst = .true. doulst = .true. call nblist call induce end if !$OMP PARALLEL default(private) shared(j,k,npgrid,pgrid,epot) !$OMP DO do i = 1, npgrid(j) xi = pgrid(1,i,j) yi = pgrid(2,i,j) zi = pgrid(3,i,j) call potpoint (xi,yi,zi,pot) epot(k,i,j) = pot end do !$OMP END DO !$OMP END PARALLEL end do end do call potstat (dofull,domodel,dopair,dotarget) end if c c perform dynamic allocation of some global arrays c if (dofit) then allocate (fit0(12*namax*nconf)) allocate (fchg(maxtyp)) allocate (fpol(13,maxtyp)) allocate (fcpen(maxclass)) allocate (fitchg(maxtyp)) allocate (fitpol(maxtyp)) allocate (fitcpen(maxclass)) allocate (vchg(namax,nconf)) allocate (vpol(13,namax,nconf)) allocate (vcpen(namax,nconf)) allocate (varpot(12*namax*nconf)) c c perform dynamic allocation of some local arrays c allocate (xx(12*namax*nconf)) allocate (xlo(12*namax*nconf)) allocate (xhi(12*namax*nconf)) allocate (tmpchg(maxtyp)) allocate (tmppol(maxtyp)) allocate (tmpcpen(maxclass)) c c zero the keyfile length to avoid parameter reprocessing c numkey = nkey nkey = 0 c c set residual count and optimization parameters with bounds c do j = 1, maxtyp fitchg(j) = .false. fitpol(j) = .false. end do do j = 1, maxclass fitcpen(j) = .false. end do nvar = 0 nresid = 0 do j = 1, nconf call getref (j) call setelect call setvars (j) call prmvar (nvar,xx,j) nresid = nresid + npgrid(j) if (fit_mpl) nresid = nresid + 1 if (use_dpl) nresid = nresid + 3 if (use_qpl) nresid = nresid + 5 end do nresid = nresid + nvar do j = 1, nvar fit0(j) = xx(j) xlo(j) = xx(j) - 1000.0d0 xhi(j) = xx(j) + 1000.0d0 end do c c perform dynamic allocation of some local arrays c allocate (gc(nvar)) allocate (presid(nresid)) allocate (pjac(nresid,nvar)) c c perform potential fit via least squares optimization c nkey = numkey call square (nvar,nresid,xlo,xhi,xx,presid,gc,pjac, & grdmin,fitrsd,potwrt) nkey = 0 c c set the final electrostatic parameter values c nvar = 0 do j = 1, maxtyp fitchg(j) = .false. fitpol(j) = .false. end do do j = 1, maxclass fitcpen(j) = .false. end do do j = 1, nconf call getref (j) call setelect next = nvar do k = 1, maxtyp tmpchg(k) = fitchg(k) tmppol(k) = fitpol(k) end do do k = 1, maxclass tmpcpen(k) = fitcpen(k) end do call varprm (nvar,xx,j) nvar = next do k = 1, maxtyp fitchg(k) = tmpchg(k) fitpol(k) = tmppol(k) end do do k = 1, maxclass fitcpen(k) = tmpcpen(k) end do call prmvar (nvar,xx,j) end do c c get potential for each structure and print statistics c nvar = 0 do j = 1, maxtyp fitchg(j) = .false. fitpol(j) = .false. end do do j = 1, maxclass fitcpen(j) = .false. end do do j = 1, nconf call getref (j) call setelect call varprm (nvar,xx,j) call prmvar (nvar,xx,j) if (use_mpole) then call chkpole call rotpole ('MPOLE') end if if (use_polar) then domlst = .true. doulst = .true. call nblist call induce end if !$OMP PARALLEL default(private) shared(j,npgrid,pgrid,epot) !$OMP DO do i = 1, npgrid(j) xi = pgrid(1,i,j) yi = pgrid(2,i,j) zi = pgrid(3,i,j) call potpoint (xi,yi,zi,pot) epot(1,i,j) = pot end do !$OMP END DO !$OMP END PARALLEL end do call prtfit call potstat (dofull,domodel,dopair,dotarget) c c perform deallocation of some local arrays c deallocate (xx) deallocate (xlo) deallocate (xhi) deallocate (presid) deallocate (gc) deallocate (pjac) deallocate (tmpchg) deallocate (tmppol) deallocate (tmpcpen) end if c c perform any final tasks before program exit c 410 continue call final end c c c ############################################################# c ## ## c ## subroutine readpot -- get and assign potential grid ## c ## ## c ############################################################# c c c "readpot" gets a set of grid points and target electrostatic c potential values from an external disk file c c subroutine readpot (ipot,iconf) use atoms use katoms use potfit use ptable implicit none integer i,j,k integer ipot,iconf integer npoint,atn real*8 xi,yi,zi real*8 big,small real*8 r2,dist real*8, allocatable :: rad(:) character*240 record c c c read the grid points and target potential from a file c npoint = 0 read (ipot,10,err=20,end=20) record 10 format (a240) read (record,*,err=20,end=20) npoint 20 continue do i = 1, npoint pgrid(1,i,iconf) = 0.0d0 pgrid(2,i,iconf) = 0.0d0 pgrid(3,i,iconf) = 0.0d0 epot(2,i,iconf) = 0.0d0 read (ipot,30,err=40,end=40) record 30 format (a240) read (record,*,err=40,end=40) k,(pgrid(j,i,iconf),j=1,3), & epot(2,i,iconf) 40 continue end do c c perform dynamic allocation of some local arrays c allocate (rad(n)) c c set base atomic radii from consensus vdw values c do i = 1, n rad(i) = 0.0d0 atn = atmnum(type(i)) if (atn .ne. 0) rad(i) = vdwrad(atn) if (rad(i) .eq. 0.0d0) rad(i) = 1.7d0 end do c c assign each grid point to atom on molecular surface c big = 1000.0d0 do i = 1, npoint small = big xi = pgrid(1,i,iconf) yi = pgrid(2,i,iconf) zi = pgrid(3,i,iconf) do k = 1, n r2 = (xi-x(k))**2 + (yi-y(k))**2 + (zi-z(k))**2 dist = sqrt(r2) - rad(k) if (dist .lt. small) then small = dist ipgrid(i,iconf) = k end if end do end do c c perform deallocation of some local arrays c deallocate (rad) c c use potential grid points only for active grid atoms c k = 0 do i = 1, npoint if (gatm(ipgrid(i,iconf))) then k = k + 1 ipgrid(k,iconf) = ipgrid(i,iconf) pgrid(1,k,iconf) = pgrid(1,i,iconf) pgrid(2,k,iconf) = pgrid(2,i,iconf) pgrid(3,k,iconf) = pgrid(3,i,iconf) epot(2,k,iconf) = epot(2,i,iconf) end if end do npgrid(iconf) = k return end c c c ############################################################## c ## ## c ## subroutine potgrid -- generate shells of grid points ## c ## ## c ############################################################## c c c "potgrid" generates electrostatic potential grid points in c radially distributed shells based on the molecular surface c c subroutine potgrid (iconf) use atoms use iounit use katoms use keys use math use potfit use ptable implicit none integer i,j,k,m integer iconf,next integer npoint,nshell integer maxdot integer ndot,atn real*8 r2,rfactor real*8 roffset real*8 spacing real*8 density real*8 round real*8 xi,yi,zi real*8 xj,yj,zj real*8 xr,yr,zr real*8, allocatable :: rad(:) real*8, allocatable :: rad2(:) real*8, allocatable :: dot(:,:) character*20 keyword character*240 record character*240 string c c c set default values for grid point generation parameters c npoint = 0 nshell = 4 maxdot = 50000 spacing = 0.35d0 density = 4.0d0 * pi / spacing**2 rfactor = 1.0d0 roffset = 1.0d0 round = 0.000001d0 c c check for keywords containing any altered parameters c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:17) .eq. 'POTENTIAL-SHELLS ') then read (string,*,err=10,end=10) nshell else if (keyword(1:18) .eq. 'POTENTIAL-SPACING ') then read (string,*,err=10,end=10) spacing density = 4.0d0 * pi / spacing**2 else if (keyword(1:17) .eq. 'POTENTIAL-FACTOR ') then read (string,*,err=10,end=10) rfactor else if (keyword(1:17) .eq. 'POTENTIAL-OFFSET ') then read (string,*,err=10,end=10) roffset end if 10 continue end do c c perform dynamic allocation of some local arrays c allocate (rad(n)) allocate (rad2(n)) c c get modified atomic radii from consensus vdw values c do i = 1, n atn = atmnum(type(i)) rad(i) = vdwrad(atn) if (rad(i) .eq. 0.0d0) rad(i) = 1.7d0 rad(i) = rfactor*rad(i) + roffset rad2(i) = rad(i) * rad(i) end do c c perform dynamic allocation of some local arrays c allocate (dot(3,maxdot)) c c find points on each of the molecular surface shells c do m = 1, nshell if (m .ne. 1) then do i = 1, n rad(i) = rad(i) + spacing rad2(i) = rad(i) * rad(i) end do end if do i = 1, n xi = x(i) yi = y(i) zi = z(i) ndot = int(density*rad2(i)) if (ndot .gt. maxdot) then write (iout,20) 20 format (/,' POTGRID -- Too many Surface Grid', & ' Points; Increase MAXDOT') call fatal end if call sphere (ndot,dot) do j = 1, ndot xj = xi + rad(i)*dot(1,j) yj = yi + rad(i)*dot(2,j) zj = zi + rad(i)*dot(3,j) xj = dble(nint(xj/round)) * round yj = dble(nint(yj/round)) * round zj = dble(nint(zj/round)) * round do k = 1, i-1 xr = xj - x(k) yr = yj - y(k) zr = zj - z(k) r2 = xr*xr + yr*yr + zr*zr if (r2 .lt. rad2(k)) goto 30 end do do k = i+1, n xr = xj - x(k) yr = yj - y(k) zr = zj - z(k) r2 = xr*xr + yr*yr + zr*zr if (r2 .lt. rad2(k)) goto 30 end do npoint = npoint + 1 ipgrid(npoint,iconf) = i pgrid(1,npoint,iconf) = xj pgrid(2,npoint,iconf) = yj pgrid(3,npoint,iconf) = zj 30 continue end do end do end do c c perform deallocation of some local arrays c deallocate (rad) deallocate (rad2) deallocate (dot) c c use potential grid points only for active grid atoms c k = npoint npoint = 0 do i = 1, k if (gatm(ipgrid(i,iconf))) then npoint = npoint + 1 ipgrid(npoint,iconf) = ipgrid(i,iconf) pgrid(1,npoint,iconf) = pgrid(1,i,iconf) pgrid(2,npoint,iconf) = pgrid(2,i,iconf) pgrid(3,npoint,iconf) = pgrid(3,i,iconf) end if end do npgrid(iconf) = npoint return end c c c ################################################################ c ## ## c ## subroutine setelect -- assign electrostatic parameters ## c ## ## c ################################################################ c c c "setelect" assigns partial charge, bond dipole and atomic c multipole parameters for the current structure, as needed c for computation of the electrostatic potential c c subroutine setelect use potent implicit none c c c get connectivity info and make parameter assignments c call attach call active call bonds call angles call torsions call bitors call rings call cutoffs call katom call kcharge call kdipole call kmpole call kpolar call kchgtrn call kchgflx c c bond and angle parameters are needed if using charge flux c if (use_chgflx) then call kbond call kangle end if return end c c c ################################################################# c ## ## c ## subroutine setvars -- find nonzero parameters for atoms ## c ## ## c ################################################################# c c c "setvars" finds and stores nonzero partial charge, atomic c multipole and charge penetration parameters for each atom of c the current structure c c subroutine setvars (iconf) use atoms use charge use chgpen use mplpot use mpole use potent use potfit implicit none integer i,j,ii integer iconf c c c initialize use of electrostatic parameter types for atoms c do i = 1, n vchg(i,iconf) = .false. do j = 1, 13 vpol(j,i,iconf) = .false. end do vcpen(i,iconf) = .false. end do c c set nonzero partial charges as fitting variables c do ii = 1, nion i = iion(ii) if (use_chgflx) then if (pchg0(i) .ne. 0.0d0) then vchg(i,iconf) = .true. end if else if (pchg(i) .ne. 0.0d0) then vchg(i,iconf) = .true. end if end if end do c c set nonzero atomic multipoles as fitting variables c do ii = 1, npole i = ipole(ii) if (use_chgflx) then if (mono0(i) .ne. 0.0d0) then vpol(1,i,iconf) = .true. end if else if (pole(1,i) .ne. 0.0d0) then vpol(1,i,iconf) = .true. end if end if do j = 2, 13 if (pole(j,i) .ne. 0.0d0) then vpol(j,i,iconf) = .true. end if end do end do c c set nonzero charge penetration values as fitting variables c if (use_chgpen) then do ii = 1, npole i = ipole(ii) if (palpha(i) .ne. 0.0d0) then vcpen(i,iconf) = .true. end if end do end if return end c c c ################################################################# c ## ## c ## subroutine potpoint -- electrostatic potential at point ## c ## ## c ################################################################# c c c "potpoint" calculates the electrostatic potential at a grid c point "i" as the total electrostatic interaction energy of c the system with a positive charge located at the grid point c c subroutine potpoint (xi,yi,zi,pot) use atoms use charge use chgpen use chgpot use dipole use mplpot use mpole use polar use potent use units implicit none integer k,kk,k1,k2 real*8 e,ei,pot real*8 ec,ed,em,ep real*8 xi,yi,zi real*8 xk,yk,zk real*8 xr,yr,zr real*8 r,r2,dotk real*8 rk2,rkr3 real*8 rr1,rr3,rr5 real*8 rr1k,rr3k,rr5k real*8 corek,valk real*8 alphak real*8 f,fi,ci,ck real*8 dkx,dky,dkz real*8 ukx,uky,ukz real*8 qkxx,qkxy,qkxz real*8 qkyy,qkyz,qkzz real*8 qkx,qky,qkz real*8 dkr,qkr,ukr real*8 dmpk(5) c c c zero out charge, dipole and multipole potential terms c ec = 0.0d0 ed = 0.0d0 em = 0.0d0 ep = 0.0d0 c c set charge of probe site and electrostatic constants c f = electric / dielec ci = 1.0d0 fi = f * ci c c calculate the charge contribution to the potential c do kk = 1, nion k = iion(kk) xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi r2 = xr*xr + yr* yr + zr*zr r = sqrt(r2) e = fi * pchg(k) / r ec = ec + e end do c c calculate the bond dipole contribution to the potential c do kk = 1, ndipole k1 = idpl(1,kk) k2 = idpl(2,kk) xk = x(k2) - x(k1) yk = y(k2) - y(k1) zk = z(k2) - z(k1) xr = x(k1) + xk*sdpl(kk) - xi yr = y(k1) + yk*sdpl(kk) - yi zr = z(k1) + zk*sdpl(kk) - zi r2 = xr*xr + yr* yr + zr*zr rk2 = xk*xk + yk*yk + zk*zk rkr3 = sqrt(rk2*r2) * r2 dotk = xk*xr + yk*yr + zk*zr e = (fi/debye) * bdpl(kk) * dotk / rkr3 ed = ed + e end do c c calculate the multipole contribution to the potential c do kk = 1, npole k = ipole(kk) xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi r2 = xr*xr + yr* yr + zr*zr r = sqrt(r2) ck = rpole(1,k) dkx = rpole(2,k) dky = rpole(3,k) dkz = rpole(4,k) qkxx = rpole(5,k) qkxy = rpole(6,k) qkxz = rpole(7,k) qkyy = rpole(9,k) qkyz = rpole(10,k) qkzz = rpole(13,k) if (use_polar) then ukx = uind(1,k) uky = uind(2,k) ukz = uind(3,k) else ukx = 0.0d0 uky = 0.0d0 ukz = 0.0d0 end if c c construct some common multipole and distance values c qkx = qkxx*xr + qkxy*yr + qkxz*zr qky = qkxy*xr + qkyy*yr + qkyz*zr qkz = qkxz*xr + qkyz*yr + qkzz*zr dkr = dkx*xr + dky*yr + dkz*zr qkr = qkx*xr + qky*yr + qkz*zr ukr = ukx*xr + uky*yr + ukz*zr rr1 = 1.0d0 / r rr3 = rr1 / r2 rr5 = 3.0d0 * rr3 / r2 c c compute the potential contributions for this site c if (use_chgpen) then corek = pcore(k) c valk = pval(k) valk = -corek + rpole(1,k) alphak = palpha(k) call damppot (r,alphak,dmpk) rr1k = dmpk(1) * rr1 rr3k = dmpk(3) * rr3 rr5k = dmpk(5) * rr5 e = corek*rr1 + valk*rr1k - dkr*rr3k + qkr*rr5k else e = ck*rr1 - dkr*rr3 + qkr*rr5 end if ei = -ukr * rr3 c c increment the overall multipole and polarization terms c e = fi * e ei = fi * ei em = em + e ep = ep + ei end do c c potential is sum of all interactions with probe site c pot = ec + ed + em + ep return end c c c ################################################################ c ## ## c ## subroutine fitrsd -- residual values for potential fit ## c ## ## c ################################################################ c c c "fitrsd" computes residuals for electrostatic potential fitting c including total charge restraints, dipole and quadrupole moment c targets, and restraints on initial parameter values c c subroutine fitrsd (nvar,nresid,xx,resid) use atoms use keys use moment use mpole use neigh use potent use potfit use units implicit none integer i,j,nvar integer nresid integer npoint integer iresid integer numkey real*8 xi,yi,zi real*8 pot,pval real*8 tscale,cscale real*8 pscale,rscale real*8 rconf,ratio real*8 dterm,qterm real*8 xx(*) real*8 resid(*) character*6 mode c c c initialize least squares residuals and scaling factors c npoint = 0 do j = 1, nconf npoint = npoint + npgrid(j) end do do j = 1, nresid resid(j) = 0.0d0 end do tscale = 300.0d0 cscale = 10000.0d0 pscale = 10.0d0 c c set electrostatic potential weight vs. parameter restraints c rconf = dble(nconf) ratio = dble(npoint) / dble(nvar*nconf) rscale = 2.2d0 * sqrt(wresp) * rconf * sqrt(ratio) c rscale = 0.18d0 * sqrt(wresp) * rconf * ratio c rscale = 0.015d0 * sqrt(wresp) * rconf * sqrt(ratio**3) c c initialize counters for parameters and residual components c nvar = 0 iresid = 0 do j = 1, maxtyp fitchg(j) = .false. fitpol(j) = .false. end do do j = 1, maxclass fitcpen(j) = .false. end do c c zero the keyfile length to avoid parameter reprocessing c numkey = nkey nkey = 0 c c find least squares residuals via loop over conformations c do j = 1, nconf call getref (j) call setelect call varprm (nvar,xx,j) if (use_mpole) call rotpole ('MPOLE') if (use_polar) then domlst = .true. doulst = .true. call nblist call induce end if c c get residuals due to potential error over grid points c !$OMP PARALLEL default(private) !$OMP& shared(j,npgrid,pgrid,epot,iresid,resid,rconf) !$OMP DO do i = 1, npgrid(j) xi = pgrid(1,i,j) yi = pgrid(2,i,j) zi = pgrid(3,i,j) call potpoint (xi,yi,zi,pot) epot(1,i,j) = pot resid(iresid+i) = epot(1,i,j) - epot(2,i,j) end do !$OMP END DO !$OMP END PARALLEL iresid = iresid + npgrid(j) c c find moments if they contribute to the overall residual c if (fit_mpl .or. use_dpl .or. use_qpl) then mode = 'FULL' call moments (mode) end if c c get residual due to total molecular charge restraint c if (fit_mpl) then iresid = iresid + 1 resid(iresid) = (netchg-dble(nint(netchg))) * cscale end if c c get residuals from dipole and quadrupole target violations c if (use_dpl) then resid(iresid+1) = (xdpl-xdpl0(j)) * tscale resid(iresid+2) = (ydpl-ydpl0(j)) * tscale resid(iresid+3) = (zdpl-zdpl0(j)) * tscale iresid = iresid + 3 end if if (use_qpl) then resid(iresid+1) = (xxqpl-xxqpl0(j)) * tscale resid(iresid+2) = (xyqpl-xyqpl0(j)) * tscale resid(iresid+3) = (xzqpl-xzqpl0(j)) * tscale resid(iresid+4) = (yyqpl-yyqpl0(j)) * tscale resid(iresid+5) = (yzqpl-yzqpl0(j)) * tscale resid(iresid+6) = (zzqpl-zzqpl0(j)) * tscale iresid = iresid + 6 end if end do c c scaling factors for dipole and quadrupole residuals c dterm = 1.0d0 qterm = 1.0d0 c dterm = 1.0d0 / bohr c qterm = 3.0d0 / bohr**2 c c get residuals due to restraints on parameter values c do i = 1, nvar iresid = iresid + 1 if (varpot(i) .ne. 'CHGPEN') then if (resptyp .eq. 'ORIG') then resid(iresid) = (xx(i)-fit0(i)) * rscale else if (resptyp .eq. 'ZERO') then resid(iresid) = xx(i) * rscale else resid(iresid) = 0.0d0 end if if (varpot(i) .eq. 'DIPOLE') then resid(iresid) = resid(iresid) / dterm else if (varpot(i) .eq. 'QUADPL') then resid(iresid) = resid(iresid) / qterm end if end if if (varpot(i) .eq. 'CHGPEN') then pval = max(xx(i)-6.5d0,2.5d0-xx(i),0.0d0) resid(iresid) = pval * pscale end if end do c c reset the keyfile length to its original value c nkey = numkey return end c c c ############################################################# c ## ## c ## subroutine varprm -- optimization to electrostatics ## c ## ## c ############################################################# c c c "varprm" copies the current optimization values into the c corresponding electrostatic potential energy parameters c c subroutine varprm (nvar,xx,iconf) use atomid use atoms use charge use chgpen use mplpot use mpole use potent use potfit use units implicit none integer i,j,ii integer it,ic integer nvar,iconf real*8 dterm,qterm real*8 xx(*) logical done c c c translate optimization values back to partial charges c do ii = 1, nion done = .true. i = iion(ii) it = type(i) if (fatm(i)) done = .false. if (.not. done) then if (fitchg(it)) then done = .true. if (use_chgflx) then pchg0(i) = fchg(it) else pchg(i) = fchg(it) end if end if end if if (.not. done) then fitchg(it) = .true. if (use_chgflx) then if (vchg(i,iconf)) then nvar = nvar + 1 pchg0(i) = xx(nvar) end if fchg(it) = pchg0(i) else if (vchg(i,iconf)) then nvar = nvar + 1 pchg(i) = xx(nvar) end if fchg(it) = pchg(i) end if end if end do c c conversion factors for dipole and quadrupole moments c dterm = bohr qterm = bohr**2 / 3.0d0 c c translate optimization values back to atomic multipoles c do ii = 1, npole done = .true. i = ipole(ii) it = type(i) if (fatm(i)) done = .false. if (.not. done) then if (fitpol(it)) then done = .true. if (use_chgflx) then mono0(i) = fpol(1,it) else pole(1,i) = fpol(1,it) end if do j = 2, 13 pole(j,i) = fpol(j,it) end do end if end if if (.not. done) then if (use_chgflx) then if (fit_mpl .and. vpol(1,i,iconf)) then nvar = nvar + 1 mono0(i) = xx(nvar) end if else if (fit_mpl .and. vpol(1,i,iconf)) then nvar = nvar + 1 pole(1,i) = xx(nvar) end if end if if (fit_dpl .and. vpol(2,i,iconf) .and. fxdpl(i)) then nvar = nvar + 1 pole(2,i) = dterm * xx(nvar) end if if (fit_dpl .and. vpol(3,i,iconf) .and. fydpl(i)) then nvar = nvar + 1 pole(3,i) = dterm * xx(nvar) end if if (fit_dpl .and. vpol(4,i,iconf) .and. fzdpl(i)) then nvar = nvar + 1 pole(4,i) = dterm * xx(nvar) end if if (fit_qpl .and. vpol(5,i,iconf)) then if (polaxe(i) .ne. 'Z-Only') then nvar = nvar + 1 pole(5,i) = qterm * xx(nvar) end if end if if (fit_qpl .and. vpol(6,i,iconf)) then nvar = nvar + 1 pole(6,i) = qterm * xx(nvar) pole(8,i) = qterm * xx(nvar) end if if (fit_qpl .and. vpol(7,i,iconf)) then nvar = nvar + 1 pole(7,i) = qterm * xx(nvar) pole(11,i) = qterm * xx(nvar) end if if (fit_qpl .and. vpol(9,i,iconf)) then if (polaxe(i) .ne. 'Z-Only') then nvar = nvar + 1 pole(9,i) = qterm * xx(nvar) end if end if if (fit_qpl .and. vpol(10,i,iconf)) then nvar = nvar + 1 pole(10,i) = qterm * xx(nvar) pole(12,i) = qterm * xx(nvar) end if if (fit_qpl .and. vpol(13,i,iconf)) then if (polaxe(i) .eq. 'Z-Only') then nvar = nvar + 1 pole(13,i) = qterm * xx(nvar) pole(5,i) = -0.5d0 * pole(13,i) pole(9,i) = pole(5,i) else pole(13,i) = -pole(5,i) - pole(9,i) end if end if fitpol(it) = .true. if (use_chgflx) then fpol(1,it) = mono0(i) else fpol(1,it) = pole(1,i) end if do j = 2, 13 fpol(j,it) = pole(j,i) end do end if end do c c translate optimization values back to charge penetration c if (use_chgpen) then do ii = 1, npole done = .true. i = ipole(ii) ic = class(i) if (fatm(i)) done = .false. if (.not. done) then if (fitcpen(ic)) then done = .true. palpha(i) = fcpen(ic) end if end if if (.not. done) then if (fit_chgpen .and. vcpen(i,iconf)) then nvar = nvar + 1 palpha(i) = xx(nvar) end if fitcpen(ic) = .true. fcpen(ic) = palpha(i) end if end do end if c c check chiral multipoles and rotate into global frame c if (use_mpole) then call chkpole call rotpole ('MPOLE') end if c c modify partial charges and monopoles for charge flux c if (use_chgflx) call alterchg return end c c c ############################################################# c ## ## c ## subroutine prmvar -- electrostatics to optimization ## c ## ## c ############################################################# c c c "prmvar" determines the optimization values from the c corresponding electrostatic potential energy parameters c c subroutine prmvar (nvar,xx,iconf) use atomid use atoms use charge use chgpen use iounit use mplpot use mpole use potent use potfit use units implicit none integer i,j,k,m integer ii,it,ic integer ktype integer nvar,iconf integer, allocatable :: equiv(:) real*8 dterm,qterm real*8 eps,sum,big real*8 ival,kval real*8 xx(*) logical done character*18 prmtyp c c c conversion factors for dipole and quadrupole moments c dterm = 1.0d0 / bohr qterm = 3.0d0 / bohr**2 c c regularize charges, monopoles and diagonal quadrupoles c eps = 0.00001d0 do ii = 1, nion i = iion(ii) pchg(i) = dble(nint(pchg(i)/eps)) * eps pchg0(i) = dble(nint(pchg0(i)/eps)) * eps end do do ii = 1, npole i = ipole(ii) pole(1,i) = dble(nint(pole(1,i)/eps)) * eps pole(5,i) = dble(nint(qterm*pole(5,i)/eps)) * eps/qterm pole(9,i) = dble(nint(qterm*pole(9,i)/eps)) * eps/qterm pole(13,i) = dble(nint(qterm*pole(13,i)/eps)) * eps/qterm mono0(i) = dble(nint(mono0(i)/eps)) * eps end do c c perform dynamic allocation of some local arrays c allocate (equiv(maxtyp)) c c enforce integer net charge over partial charges c ktype = 0 kval = 0 sum = 0.0d0 do i = 1, maxtyp equiv(i) = 0 end do do ii = 1, nion i = iion(ii) it = type(i) equiv(it) = equiv(it) + 1 if (use_chgflx) then sum = sum + pchg0(i) else sum = sum + pchg(i) end if end do sum = sum - dble(nint(sum)) k = nint(abs(sum)/eps) do j = 1, k m = k / j if (k .eq. m*j) then do ii = 1, nion i = iion(ii) it = type(i) if (equiv(it) .eq. m) then if (use_chgflx) then ival = abs(pchg0(i)) else ival = abs(pchg(i)) end if if (ktype .eq. 0) then ktype = it kval = ival else if (ival .gt. kval) then ktype = it kval = ival end if end if end do end if if (ktype .ne. 0) goto 10 end do 10 continue if (ktype .ne. 0) then sum = sum / dble(m) do ii = 1, nion i = iion(ii) it = type(i) if (it .eq. ktype) then if (use_chgflx) then pchg0(i) = pchg0(i) - sum fchg(it) = pchg0(i) else pchg(i) = pchg(i) - sum fchg(it) = pchg(i) end if end if end do end if c c enforce integer net charge over atomic monopoles c ktype = 0 kval = 0 sum = 0.0d0 do i = 1, maxtyp equiv(i) = 0 end do do ii = 1, npole i = ipole(ii) it = type(i) equiv(it) = equiv(it) + 1 if (use_chgflx) then sum = sum + mono0(i) else sum = sum + pole(1,i) end if end do sum = sum - dble(nint(sum)) k = nint(abs(sum)/eps) do j = 1, k m = k / j if (k .eq. m*j) then do ii = 1, npole i = ipole(ii) it = type(i) if (equiv(it) .eq. m) then if (use_chgflx) then ival = abs(mono0(i)) else ival = abs(pole(1,i)) end if if (ktype .eq. 0) then ktype = it kval = ival else if (ival .gt. kval) then ktype = it kval = ival end if end if end do end if if (ktype .ne. 0) goto 20 end do 20 continue if (ktype .ne. 0) then sum = sum / dble(m) do ii = 1, npole i = ipole(ii) it = type(i) if (it .eq. ktype) then if (use_chgflx) then mono0(i) = mono0(i) - sum fpol(1,it) = mono0(i) else pole(1,i) = pole(1,i) - sum fpol(1,it) = pole(1,i) end if end if end do end if c c perform deallocation of some local arrays c deallocate (equiv) c c enforce traceless quadrupole at each multipole site c do ii = 1, npole i = ipole(ii) sum = pole(5,i) + pole(9,i) + pole(13,i) big = max(abs(pole(5,i)),abs(pole(9,i)),abs(pole(13,i))) k = 0 if (big .eq. abs(pole(5,i))) k = 5 if (big .eq. abs(pole(9,i))) k = 9 if (big .eq. abs(pole(13,i))) k = 13 if (k .ne. 0) then it = type(ipole(i)) pole(k,i) = pole(k,i) - sum fpol(k,it) = pole(k,i) end if end do c c list active atoms when not all are used in optimization c if (nconf.eq.1 .and. nfatm.ne.n) then write (iout,30) 30 format (/,' Atomic Parameters Included in Potential Fitting :', & //,3x,'Atom',10x,'Atom Name',6x,'Atom Type/Class', & 6x,'Parameters',/) do ii = 1, nion i = iion(ii) if (fatm(i)) then it = type(i) prmtyp = 'Partial Charge' write (iout,40) i,name(i),it,prmtyp 40 format (i6,15x,a3,7x,i6,' Type',11x,a) end if end do do ii = 1, npole i = ipole(ii) if (fatm(i)) then it = type(i) prmtyp = 'Atomic Multipoles' write (iout,50) i,name(i),it,prmtyp 50 format (i6,15x,a3,7x,i6,' Type',11x,a) end if end do if (fit_chgpen) then do ii = 1, npole i = ipole(ii) if (fatm(i)) then ic = class(i) prmtyp = 'Charge Penetration' write (iout,60) i,name(i),ic,prmtyp 60 format (i6,15x,a3,7x,i6,' Class',10x,a) end if end do end if end if c c print header information for electrostatic parameters c if (nvar .eq. 0) then write (iout,70) 70 format (/,' Potential Fitting of Electrostatic Parameters :', & //,1x,'Parameter',5x,'Atom Type/Class',6x,'Category', & 10x,'Value',9x,'Fixed',/) end if c c get optimization parameters from partial charge values c do ii = 1, nion done = .true. i = iion(ii) it = type(i) if (fatm(i)) done = .false. if (.not. done) then if (fitchg(it)) done = .true. fitchg(it) = .true. end if if (.not. done) then if (vchg(i,iconf)) then nvar = nvar + 1 varpot(nvar) = 'CHARGE' if (use_chgflx) then xx(nvar) = pchg0(i) else xx(nvar) = pchg(i) end if write (iout,80) nvar,it,'Charge ',xx(nvar) 80 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,90) it,'Charge ',pchg0(i) 90 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if end if end do c c get optimization parameters from atomic multipole values c do ii = 1, npole done = .true. i = ipole(ii) it = type(i) if (fatm(i)) done = .false. if (.not. done) then if (fitpol(it)) done = .true. fitpol(it) = .true. end if if (.not. done) then if (fit_mpl .and. vpol(1,i,iconf)) then nvar = nvar + 1 varpot(nvar) = 'MONOPL' if (use_chgflx) then xx(nvar) = mono0(i) else xx(nvar) = pole(1,i) end if write (iout,100) nvar,it,'Monopole',xx(nvar) 100 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,110) it,'Monopole',mono0(i) 110 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if if (fit_dpl .and. vpol(2,i,iconf) .and. fxdpl(i)) then nvar = nvar + 1 varpot(nvar) = 'DIPOLE' xx(nvar) = dterm * pole(2,i) write (iout,120) nvar,it,'X-Dipole',xx(nvar) 120 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,130) it,'X-Dipole',dterm*pole(2,i) 130 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if if (fit_dpl .and. vpol(3,i,iconf) .and. fydpl(i)) then nvar = nvar + 1 varpot(nvar) = 'DIPOLE' xx(nvar) = dterm * pole(3,i) write (iout,140) nvar,it,'Y-Dipole',xx(nvar) 140 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,150) it,'Y-Dipole',dterm*pole(3,i) 150 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if if (fit_dpl .and. vpol(4,i,iconf) .and. fzdpl(i)) then nvar = nvar + 1 varpot(nvar) = 'DIPOLE' xx(nvar) = dterm * pole(4,i) write (iout,160) nvar,it,'Z-Dipole',xx(nvar) 160 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,170) it,'Z-Dipole',dterm*pole(4,i) 170 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if if (fit_qpl .and. vpol(5,i,iconf)) then if (polaxe(i) .ne. 'Z-Only') then nvar = nvar + 1 varpot(nvar) = 'QUADPL' xx(nvar) = qterm * pole(5,i) write (iout,180) nvar,it,'XX-Quad ',xx(nvar) 180 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,190) it,'XX-Quad ',qterm*pole(5,i) 190 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5) end if else write (iout,200) it,'XX-Quad ',qterm*pole(5,i) 200 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if if (fit_qpl .and. vpol(6,i,iconf)) then nvar = nvar + 1 varpot(nvar) = 'QUADPL' xx(nvar) = qterm * pole(6,i) write (iout,210) nvar,it,'XY-Quad ',xx(nvar) 210 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,220) it,'XY-Quad ',qterm*pole(6,i) 220 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if if (fit_qpl .and. vpol(7,i,iconf)) then nvar = nvar + 1 varpot(nvar) = 'QUADPL' xx(nvar) = qterm * pole(7,i) write (iout,230) nvar,it,'XZ-Quad ',xx(nvar) 230 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,240) it,'XZ-Quad ',qterm*pole(7,i) 240 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if if (fit_qpl .and. vpol(9,i,iconf)) then if (polaxe(i) .ne. 'Z-Only') then nvar = nvar + 1 varpot(nvar) = 'QUADPL' xx(nvar) = qterm * pole(9,i) write (iout,250) nvar,it,'YY-Quad ',xx(nvar) 250 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,260) it,'YY-Quad ',qterm*pole(9,i) 260 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5) end if else write (iout,270) it,'YY-Quad ',qterm*pole(9,i) 270 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if if (fit_qpl .and. vpol(10,i,iconf)) then nvar = nvar + 1 varpot(nvar) = 'QUADPL' xx(nvar) = qterm * pole(10,i) write (iout,280) nvar,it,'YZ-Quad ',xx(nvar) 280 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,290) it,'YZ-Quad ',qterm*pole(10,i) 290 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if if (fit_qpl .and. vpol(13,i,iconf)) then if (polaxe(i) .eq. 'Z-Only') then nvar = nvar + 1 varpot(nvar) = 'QUADPL' xx(nvar) = qterm * pole(13,i) write (iout,300) nvar,it,'ZZ-Quad ',xx(nvar) 300 format (i6,7x,i8,' Type',10x,a8,4x,f12.5) else write (iout,310) it,'ZZ-Quad ',qterm*pole(13,i) 310 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5) end if else write (iout,320) it,'ZZ-Quad ',qterm*pole(13,i) 320 format (4x,'--',7x,i8,' Type',10x,a8,4x,f12.5,10x,'X') end if end if end do c c get optimization parameters from charge penetration values c if (use_chgpen) then do ii = 1, npole done = .true. i = ipole(ii) ic = class(i) if (fatm(i)) done = .false. if (.not. done) then if (fitcpen(ic)) done = .true. fitcpen(ic) = .true. end if if (.not. done) then if (fit_chgpen .and. vcpen(i,iconf)) then nvar = nvar + 1 varpot(nvar) = 'CHGPEN' xx(nvar) = palpha(i) write (iout,330) nvar,ic,'ChgPen ',xx(nvar) 330 format (i6,7x,i8,' Class',9x,a8,4x,f12.5) else write (iout,340) ic,'ChgPen ',palpha(i) 340 format (4x,'--',7x,i8,' Class',9x,a8,4x,f12.5,10x,'X') end if end if end do end if return end c c c ################################################################## c ## ## c ## subroutine potstat -- electrostatic potential statistics ## c ## ## c ################################################################## c c c "potstat" computes and prints statistics for the electrostatic c potential over a set of grid points c c subroutine potstat (dofull,domodel,dopair,dotarget) use atoms use files use iounit use potfit use refer use titles implicit none integer i,j,k integer ipot,npoint integer freeunit integer trimtext integer, allocatable :: natm(:) real*8 xi,yi,zi real*8 pave1,pave2 real*8 mave1,mave2 real*8 tave,uave,rmsd real*8, allocatable :: patm1(:) real*8, allocatable :: patm2(:) real*8, allocatable :: rmsa(:) logical dofull,domodel logical dopair,dotarget character*240 potfile c c c output potential values for each model at each point c if (dofull) then if (domodel) then ipot = freeunit () potfile = filename(1:leng)//'.pot' call version (potfile,'new') open (unit=ipot,file=potfile,status='new') end if do j = 1, nconf if (nconf .eq. 1) then write (iout,10) 10 format (/,' Electrostatic Potential at Each Grid', & ' Point :', & /,8x,'(Kcal/mole per unit charge)') else write (iout,20) j 20 format (/,' Electrostatic Potential at Grid Points', & ' for Structure',i4,' :', & /,12x,'(Kcal/mole per unit charge)') end if if (dotarget) then write (iout,30) 30 format (/,3x,'Point',15x,'XYZ-Coordinates',15x, & 'Potential',5x,'Target',/) else if (dopair) then write (iout,40) 40 format (/,3x,'Point',15x,'XYZ-Coordinates',13x, & 'Potential 1',3x,'Potential 2',/) else if (domodel) then write (iout,50) 50 format (/,3x,'Point',15x,'XYZ-Coordinates',14x, & 'Potential',/) write (ipot,60) npgrid(j),title(1:ltitle) 60 format (i8,2x,a) end if do i = 1, npgrid(j) xi = pgrid(1,i,j) yi = pgrid(2,i,j) zi = pgrid(3,i,j) if (dotarget .or. dopair) then write (iout,70) i,xi,yi,zi,epot(1,i,j),epot(2,i,j) 70 format (i8,3x,3f12.6,2x,2f12.4) else if (domodel) then write (iout,80) i,xi,yi,zi,epot(1,i,j) 80 format (i8,3x,3f12.6,2x,f12.4) write (ipot,90) i,xi,yi,zi,epot(1,i,j) 90 format (i8,3x,3f12.6,2x,f12.4) end if end do end do if (domodel) then close (unit=ipot) write (iout,100) potfile(1:trimtext(potfile)) 100 format (/,' Electrostatic Potential Written To : ',a) end if end if c c perform dynamic allocation of some local arrays c allocate (natm(namax)) allocate (patm1(namax)) allocate (patm2(namax)) allocate (rmsa(namax)) c c find average electrostatic potential around each atom c write (iout,110) 110 format (/,' Average Electrostatic Potential over Atoms :', & /,6x,'(Kcal/mole per unit charge)') if (dotarget) then write (iout,120) 120 format (/,3x,'Structure',3x,'Atom',6x,'Points', & 6x,'Potential',8x,'Target',8x,'RMS Diff',/) else if (dopair) then write (iout,130) 130 format (/,3x,'Structure',3x,'Atom',6x,'Points', & 5x,'Potential 1',4x,'Potential 2',6x,'RMS Diff',/) else if (domodel) then write (iout,140) 140 format (/,3x,'Structure',3x,'Atom',5x,'Points', & 6x,'Potential',/) end if do j = 1, nconf call getref (j) do i = 1, n natm(i) = 0 patm1(i) = 0.0d0 patm2(i) = 0.0d0 rmsa(i) = 0.0d0 end do do i = 1, npgrid(j) k = ipgrid(i,j) natm(k) = natm(k) + 1 patm1(k) = patm1(k) + epot(1,i,j) patm2(k) = patm2(k) + epot(2,i,j) rmsa(k) = rmsa(k) + (epot(1,i,j)-epot(2,i,j))**2 end do do i = 1, n if (natm(i) .ne. 0) then patm1(i) = patm1(i) / dble(natm(i)) patm2(i) = patm2(i) / dble(natm(i)) rmsa(i) = sqrt(rmsa(i)/dble(natm(i))) end if if (gatm(i)) then if (dotarget .or. dopair) then write (iout,150) j,i,natm(i),patm1(i), & patm2(i),rmsa(i) 150 format (2i9,3x,i9,3x,f12.4,3x,f12.4,3x,f12.4) else if (domodel) then write (iout,160) j,i,natm(i),patm1(i) 160 format (2i9,3x,i9,3x,f12.4) end if end if end do end do c c perform deallocation of some local arrays c deallocate (natm) deallocate (patm1) deallocate (patm2) deallocate (rmsa) c c overall averages for the sets of electrostatic potentials c npoint = 0 pave1 = 0.0d0 pave2 = 0.0d0 mave1 = 0.0d0 mave2 = 0.0d0 tave = 0.0d0 uave = 0.0d0 rmsd = 0.0d0 do j = 1, nconf npoint = npoint + npgrid(j) do i = 1, npgrid(j) pave1 = pave1 + epot(1,i,j) pave2 = pave2 + epot(2,i,j) mave1 = mave1 + abs(epot(1,i,j)) mave2 = mave2 + abs(epot(2,i,j)) tave = tave + epot(1,i,j) - epot(2,i,j) uave = uave + abs(epot(1,i,j)-epot(2,i,j)) rmsd = rmsd + (epot(1,i,j)-epot(2,i,j))**2 end do end do pave1 = pave1 / dble(npoint) pave2 = pave2 / dble(npoint) mave1 = mave1 / dble(npoint) mave2 = mave2 / dble(npoint) tave = tave / dble(npoint) uave = uave / dble(npoint) rmsd = sqrt(rmsd/dble(npoint)) if (dopair) then write (iout,170) pave1,mave1 170 format (/,' Electrostatic Potential over all Grid Points :', & //,' Average Potential Value for Model 1 :',10x,f12.4, & /,' Average Potential Magnitude for Model 1 :', & 6x,f12.4) else write (iout,180) pave1,mave1 180 format (/,' Electrostatic Potential over all Grid Points :', & //,' Average Potential Value for Model :',12x,f12.4, & /,' Average Potential Magnitude for Model :',8x,f12.4) end if if (dotarget) then write (iout,190) pave2,mave2,tave,uave,rmsd 190 format (' Average Potential Value for Target :',11x,f12.4, & /,' Average Potential Magnitude for Target :',7x,f12.4, & //,' Average Signed Potential Difference :',10x,f12.4, & /,' Average Unsigned Potential Difference :',8x,f12.4, & /,' Root Mean Square Potential Difference :',8x,f12.4) else if (dopair) then write (iout,200) pave2,mave2,tave,uave,rmsd 200 format (' Average Potential Value for Model 2 :',10x,f12.4, & /,' Average Potential Magnitude for Model 2 :', & 6x,f12.4, & //,' Average Signed Potential Difference :',10x,f12.4, & /,' Average Unsigned Potential Difference :',8x,f12.4, & /,' Root Mean Square Potential Difference :',8x,f12.4) end if return end c c c ################################################################## c ## ## c ## subroutine prtfit -- create file with optimal parameters ## c ## ## c ################################################################## c c c "prtfit" makes a key file containing results from fitting a c charge or multipole model to an electrostatic potential grid c c subroutine prtfit use atomid use atoms use charge use chgpen use files use keys use mpole use potfit use units implicit none integer i,j,k,m integer ii,it,ic integer ix,iy,iz integer ikey,size integer ntot integer freeunit integer trimtext real*8 dterm,qterm logical done,header character*4 pa,pb,pc,pd character*16, allocatable :: pt(:) character*240 keyfile character*240 record c c c reread the contents of any previously existing keyfile c call getkey c c open a new keyfile to contain the optimized parameters c ikey = freeunit () keyfile = filename(1:leng)//'.key' call version (keyfile,'new') open (unit=ikey,file=keyfile,status='new') c c copy the contents of any previously existing keyfile c do i = 1, nkey record = keyline(i) size = trimtext (record) write (ikey,10) record(1:size) 10 format (a) end do c c zero the keyfile length to avoid parameter reprocessing c nkey = 0 c c output optimized partial charge values to the keyfile c header = .true. do i = 1, maxtyp fitchg(i) = .false. end do do k = 1, nconf call getref (k) call setelect do ii = 1, nion done = .true. i = iion(ii) it = type(i) if (fatm(i)) done = .false. if (.not. done) then if (fitchg(it)) done = .true. fitchg(it) = .true. end if if (.not. done) then pchg(i) = fchg(it) if (header) then header = .false. write (ikey,20) 20 format (/,'#',/,'# Charges from Electrostatic', & ' Potential Fitting',/,'#',/) end if write (ikey,30) it,pchg(i) 30 format ('charge',4x,i5,10x,f11.4) end if end do end do c c conversion factors for dipole and quadrupole moments c dterm = 1.0d0 / bohr qterm = 3.0d0 / bohr**2 c c get total atoms in all structures used in the fitting c ntot = 0 do k = 1, nconf call getref(k) ntot = ntot + n end do c c perform dynamic allocation of some local arrays c allocate (pt(ntot)) c c initialize atom type and local frame defining strings c do i = 1, ntot pt(i) = ' ' end do c c output optimized atomic multipole values to the keyfile c header = .true. m = 0 do k = 1, nconf call getref (k) call setelect do ii = 1, npole done = .true. i = ipole(ii) it = type(i) if (fatm(i)) done = .false. if (.not. done) then iz = zaxis(i) ix = xaxis(i) iy = yaxis(i) if (iz .ne. 0) iz = type(iz) if (ix .ne. 0) ix = type(ix) if (iy .ne. 0) iy = type(abs(iy)) size = 4 call numeral (it,pa,size) call numeral (iz,pb,size) call numeral (ix,pc,size) call numeral (iy,pd,size) m = m + 1 pt(m) = pa//pb//pc//pd do j = 1, m-1 if (pt(m) .eq. pt(j)) then done = .true. goto 40 end if end do 40 continue end if if (.not. done) then if (header) then header = .false. write (ikey,50) 50 format (/,'#',/,'# Multipoles from Electrostatic', & ' Potential Fitting',/,'#',/) end if pole(1,i) = fpol(1,it) do j = 2, 4 pole(j,i) = dterm * fpol(j,it) end do do j = 5, 13 pole(j,i) = qterm * fpol(j,it) end do if (polaxe(i) .eq. 'None') then write (ikey,60) it,pole(1,i) 60 format ('multipole',1x,i5,21x,f11.5) else if (polaxe(i) .eq. 'Z-Only') then write (ikey,70) it,iz,pole(1,i) 70 format ('multipole',1x,2i5,16x,f11.5) else if (polaxe(i) .eq. 'Z-then-X') then if (yaxis(i) .eq. 0) then write (ikey,80) it,iz,ix,pole(1,i) 80 format ('multipole',1x,3i5,11x,f11.5) else if (yaxis(i) .lt. 0) 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 write (ikey,90) it,iz,ix,iy,pole(1,i) 90 format ('multipole',1x,4i5,6x,f11.5) end if else if (polaxe(i) .eq. 'Bisector') then if (yaxis(i) .eq. 0) then write (ikey,100) it,-iz,-ix,pole(1,i) 100 format ('multipole',1x,3i5,11x,f11.5) else write (ikey,110) it,-iz,-ix,iy,pole(1,i) 110 format ('multipole',1x,4i5,6x,f11.5) end if else if (polaxe(i) .eq. 'Z-Bisect') then write (ikey,120) it,iz,-ix,-iy,pole(1,i) 120 format ('multipole',1x,4i5,6x,f11.5) else if (polaxe(i) .eq. '3-Fold') then write (ikey,130) it,-iz,-ix,-iy,pole(1,i) 130 format ('multipole',1x,4i5,6x,f11.5) end if write (ikey,140) pole(2,i),pole(3,i),pole(4,i) 140 format (36x,3f11.5) write (ikey,150) pole(5,i) 150 format (36x,f11.5) write (ikey,160) pole(8,i),pole(9,i) 160 format (36x,2f11.5) write (ikey,170) pole(11,i),pole(12,i),pole(13,i) 170 format (36x,3f11.5) end if end do end do c c output optimized charge penetration values to the keyfile c if (fit_chgpen) then header = .true. do i = 1, maxclass fitcpen(i) = .false. end do do k = 1, nconf call getref (k) call setelect do ii = 1, npole done = .true. i = ipole(ii) ic = class(i) if (fatm(i)) done = .false. if (.not. done) then if (fitcpen(ic)) done = .true. fitcpen(ic) = .true. end if if (.not. done) then palpha(i) = fcpen(ic) if (header) then header = .false. write (ikey,180) 180 format (/,'#',/,'# Charge Penetration from', & ' Electrostatic Potential Fitting', & /,'#',/) end if write (ikey,190) ic,pcore(i),palpha(i) 190 format ('chgpen',9x,i5,5x,f11.4,f11.5) end if end do end do end if close (unit=ikey) c c perform deallocation of some local arrays c deallocate (pt) return end c c c ########################################################### c ## ## c ## subroutine potwrt -- least squares output routine ## c ## ## c ########################################################### c c subroutine potwrt (niter,nresid,xx,gs,resid) implicit none integer niter integer nresid real*8 xx(*) real*8 gs(*) real*8 resid(*) c c c information to be printed at each least squares iteration c return end c c c ############################################################## c ## COPYRIGHT (C) 2008 by Chuanjie Wu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ################################################################# c ## ## c ## module potfit -- values for electrostatic potential fit ## c ## ## c ################################################################# c c c nconf total number of configurations to be analyzed c namax maximum number of atoms in the largest configuration c ngatm total atom number with active potential grid points c nfatm total atom number in electrostatic potential fit c npgrid total number of electrostatic potential grid points c ipgrid atom associated with each potential grid point c wresp weight used to restrain electrostatic parameters c xdpl0 target x-component of total dipole moment c ydpl0 target y-component of total dipole moment c zdpl0 target z-component of total dipole moment c xxqpl0 target xx-component of total quadrupole moment c xyqpl0 target xy-component of total quadrupole moment c xzqpl0 target xz-component of total quadrupole moment c yyqpl0 target yy-component of total quadrupole moment c yzqpl0 target yz-component of total quadrupole moment c zzqpl0 target zz-component of total quadrupole moment c fit0 initial value of each parameter used in potential fit c fchg partial charges by atom type during potential fit c fpol atomic multipoles by atom type during potential fit c fcpen charge penetration by atom type during potential fit c pgrid Cartesian coordinates of potential grid points c epot values of electrostatic potential at grid points c use_dpl flag to include total dipole in potential fit c use_qpl flag to include total quadrupole in potential fit c fit_mpl flag for atomic monopoles to vary in potential fit c fit_dpl flag for atomic dipoles to vary in potential fit c fit_qpl flag for atomic quadrupoles to vary in potential fit c fit_chgpen flag for atomic quadrupoles to vary in potential fit c fitchg flag marking atom types used in partial charge fit c fitpol flag marking atom types used in atomic multipole fit c fitcpen flag marking atom types used in charge penetration c gatm flag to use potential grid points around each atom c fatm flag to use each atom in electrostatic potential fit c fxdpl flag to use each atom x-dipole in electrostatic fit c fydpl flag to use each atom y-dipole in electrostatic fit c fzdpl flag to use each atom z-dipole in electrostatic fit c vchg flag for partial charge at each atom in fitting c vpol flag for atomic multipoles at each atom in fitting c vcpen flag for charge penetration at each atom in fitting c resptyp electrostatic restraint target (ORIG, ZERO or NONE) c varpot descriptive name for each variable in potential fit c c module potfit use sizes implicit none integer nconf,namax integer ngatm,nfatm integer npgrid(maxref) integer, allocatable :: ipgrid(:,:) real*8 wresp real*8 xdpl0(maxref) real*8 ydpl0(maxref) real*8 zdpl0(maxref) real*8 xxqpl0(maxref) real*8 xyqpl0(maxref) real*8 xzqpl0(maxref) real*8 yyqpl0(maxref) real*8 yzqpl0(maxref) real*8 zzqpl0(maxref) real*8, allocatable :: fit0(:) real*8, allocatable :: fchg(:) real*8, allocatable :: fpol(:,:) real*8, allocatable :: fcpen(:) real*8, allocatable :: pgrid(:,:,:) real*8, allocatable :: epot(:,:,:) logical use_dpl,use_qpl logical fit_mpl,fit_dpl logical fit_qpl,fit_chgpen logical, allocatable :: fitchg(:) logical, allocatable :: fitpol(:) logical, allocatable :: fitcpen(:) logical, allocatable :: gatm(:) logical, allocatable :: fatm(:) logical, allocatable :: fxdpl(:) logical, allocatable :: fydpl(:) logical, allocatable :: fzdpl(:) logical, allocatable :: vchg(:,:) logical, allocatable :: vpol(:,:,:) logical, allocatable :: vcpen(:,:) character*4 resptyp character*6, allocatable :: varpot(:) save end c c c ################################################### c ## COPYRIGHT (C) 2020 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine predict -- induced dipole prediction values ## c ## ## c ################################################################ c c c "predict" checks for use of methods for predicting induced c dipoles, extrapolation coefficients and IELSCF parameters c c subroutine predict use atoms use ielscf use keys use uprior implicit none integer i,j,k integer next character*20 keyword character*240 record character*240 string c c c set defaults for use of induced dipole prediction c use_pred = .false. use_ielscf = .false. polpred = ' ' maxualt = 0 nualt = 0 c c get keywords containing induced dipole prediction options c do j = 1, nkey next = 1 record = keyline(j) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:14) .eq. 'POLAR-PREDICT ') then call getword (record,polpred,next) call upcase (polpred) use_pred = .true. if (polpred .eq. ' ') then polpred = 'ASPC' else if (polpred .eq. 'IEL ') then use_pred = .false. use_ielscf = .true. end if else if (keyword(1:8) .eq. 'IEL-SCF ') then use_ielscf = .true. end if end do c c set always stable predictor-corrector (ASPC) coefficients c if (polpred .eq. 'ASPC') then maxualt = 17 aspc(1) = 62.0d0 / 17.0d0 aspc(2) = -310.0d0 / 51.0d0 aspc(3) = 2170.0d0 / 323.0d0 aspc(4) = -2329.0d0 / 400.0d0 aspc(5) = 1701.0d0 / 409.0d0 aspc(6) = -806.0d0 / 323.0d0 aspc(7) = 1024.0d0 / 809.0d0 aspc(8) = -479.0d0 / 883.0d0 aspc(9) = 257.0d0 / 1316.0d0 aspc(10) = -434.0d0 / 7429.0d0 aspc(11) = 191.0d0 / 13375.0d0 aspc(12) = -62.0d0 / 22287.0d0 aspc(13) = 3.0d0 / 7217.0d0 aspc(14) = -3.0d0 / 67015.0d0 aspc(15) = 2.0d0 / 646323.0d0 aspc(16) = -1.0d0 / 9694845.0d0 aspc(17) = 0.0d0 end if c c set the 6th-order Gear predictor binomial coefficients c if (polpred .eq. 'GEAR') then maxualt = 7 gear(1) = 6.0d0 gear(2) = -15.0d0 gear(3) = 20.0d0 gear(4) = -15.0d0 gear(5) = 6.0d0 gear(6) = -1.0d0 gear(7) = 0.0d0 end if c c set maximum storage size for least squares prediction c if (polpred .eq. 'LSQR') then maxualt = 6 end if c c perform dynamic allocation of some global arrays c if (use_pred) then if (allocated(udalt)) deallocate (udalt) if (allocated(upalt)) deallocate (upalt) if (allocated(usalt)) deallocate (usalt) if (allocated(upsalt)) deallocate (upsalt) if (use_pred) then allocate (udalt(maxualt,3,n)) allocate (upalt(maxualt,3,n)) allocate (usalt(maxualt,3,n)) allocate (upsalt(maxualt,3,n)) end if end if c c initialize prior values of induced dipole moments c if (use_pred) then do i = 1, n do j = 1, 3 do k = 1, maxualt udalt(k,j,i) = 0.0d0 upalt(k,j,i) = 0.0d0 usalt(k,j,i) = 0.0d0 upsalt(k,j,i) = 0.0d0 end do end do end do end if c c initialize inertial extended Lagrangian method c if (use_ielscf) call auxinit return end c c c ################################################################## c ## ## c ## subroutine auxinit -- setup auxiliary dipoles for IELSCF ## c ## ## c ################################################################## c c c "auxinit" initializes auxiliary variables and settings for c inertial extended Lagrangian induced dipole prediction c c literature reference: c c A. Albaugh, O. Demerdash, and T. Head-Gordon, "An Efficient and c Stable Hybrid Extended Lagrangian/Self-Consistent Field Scheme c for Solving Classical Mutual Induction", Journal of Chemical c Physics, 143, 174104 (2015) c c subroutine auxinit use atomid use atoms use ielscf use keys use polar implicit none integer i,j,next real*8 speed real*8 weight real*8 maxwell real*8 vec(3) character*20 keyword character*240 record character*240 string c c c set defaults for auxiliary thermostat control variables c nfree_aux = 3 * npolar kelvin_aux = 100000.0d0 tautemp_aux = 0.1d0 c c check for keywords containing auxiliary thermostat values c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:13) .eq. 'AUX-TAUTEMP ') then read (string,*,err=10,end=10) tautemp_aux else if (keyword(1:9) .eq. 'AUX-TEMP ') then read (string,*,err=10,end=10) kelvin_aux end if 10 continue end do c c perform dynamic allocation of some global arrays c allocate (uaux(3,n)) allocate (vaux(3,n)) allocate (aaux(3,n)) allocate (upaux(3,n)) allocate (vpaux(3,n)) allocate (apaux(3,n)) c c set auxiliary dipole values equal to induced dipoles c use_ielscf = .false. call induce use_ielscf = .true. do i = 1, n do j = 1, 3 uaux(j,i) = uind(j,i) upaux(j,i) = uinp(j,i) end do end do c c set velocities and accelerations for auxiliary dipoles c do i = 1, n weight = 1.0d0 speed = maxwell (weight,kelvin_aux) call ranvec (vec) do j = 1, 3 vaux(j,i) = speed * vec(j) aaux(j,i) = 0.0d0 vpaux(j,i) = vaux(j,i) apaux(j,i) = 0.0d0 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 pressure -- barostat applied at full-step ## c ## ## c ############################################################## c c c "pressure" uses the internal virial to find the pressure c in a periodic box and maintains a constant desired pressure c via a barostat method c c subroutine pressure (dt,epot,ekin,temp,pres,stress) use bath use boxes use bound use math use units use virial implicit none integer i,j real*8 dt,epot real*8 temp,pres real*8 factor real*8 ekin(3,3) real*8 stress(3,3) c c c only necessary if periodic boundaries are in use c if (.not. use_bounds) return c c calculate the stress tensor for anisotropic systems c factor = prescon / volbox do i = 1, 3 do j = 1, 3 stress(j,i) = factor * (2.0d0*ekin(j,i)-vir(j,i)) end do end do c c set isotropic pressure to the average of tensor diagonal c pres = third * (stress(1,1)+stress(2,2)+stress(3,3)) c c use the desired barostat to maintain constant pressure c if (isobaric) then if (barostat .eq. 'BERENDSEN') call pscale (dt,pres,stress) c if (barostat .eq. 'MONTECARLO') call pmonte (epot,temp) end if return end c c c ############################################################### c ## ## c ## subroutine pressure2 -- barostat applied at half-step ## c ## ## c ############################################################### c c c "pressure2" applies a box size and velocity correction at c the half time step as needed for the Monte Carlo barostat c c subroutine pressure2 (epot,temp) use bath use bound implicit none real*8 epot,temp c c c only necessary if periodic boundaries are in use c if (.not. use_bounds) return c c use the desired barostat to maintain constant pressure c if (isobaric) then c if (barostat .eq. 'BERENDSEN') call pscale (dt,pres,stress) if (barostat .eq. 'MONTECARLO') call pmonte (epot,temp) end if return end c c c ############################################################### c ## ## c ## subroutine pmonte -- Monte Carlo barostat trial moves ## c ## ## c ############################################################### c c c "pmonte" implements a Monte Carlo barostat via random trial c changes in the periodic box volume and shape c c literature references: c c D. Frenkel and B. Smit, "Understanding Molecular Simulation, c 2nd Edition", Academic Press, San Diego, CA, 2002; Section 5.4.2 c c original version written by Alan Grossfield, January 2004; c anisotropic modification implemented by Lee-Ping Wang, Stanford c University, March 2013 c c subroutine pmonte (epot,temp) use atomid use atoms use bath use boxes use group use math use mdstuf use molcul use moldyn use units use usage implicit none integer i,j,k integer start,stop real*8 epot,temp,term real*8 energy,random real*8 expterm,weigh real*8 kt,step,scale real*8 eold,rnd6 real*8 xcm,ycm,zcm real*8 volold,cosine real*8 dpot,dpv,dkin real*8 xmove,ymove,zmove real*8 xboxold,yboxold,zboxold real*8 alphaold,betaold,gammaold real*8 temp3(3,3) real*8 hbox(3,3) real*8 ascale(3,3) real*8, allocatable :: xold(:) real*8, allocatable :: yold(:) real*8, allocatable :: zold(:) logical dotrial logical isotropic external random c c c decide whether to attempt a box size change at this step c dotrial = .false. if (random() .lt. 1.0d0/dble(voltrial)) dotrial = .true. c c set constants and decide on type of trial box size change c if (dotrial) then kt = gasconst * temp if (isothermal) kt = gasconst * kelvin isotropic = .true. if (anisotrop .and. random().gt.0.5d0) isotropic = .false. c c perform dynamic allocation of some local arrays c allocate (xold(n)) allocate (yold(n)) allocate (zold(n)) c c save the system state prior to trial box size change c xboxold = xbox yboxold = ybox zboxold = zbox alphaold = alpha betaold = beta gammaold = gamma volold = volbox eold = epot do i = 1, n xold(i) = x(i) yold(i) = y(i) zold(i) = z(i) end do c c for the isotropic case, change the lattice lengths uniformly c if (isotropic) then step = volmove * (2.0d0*random()-1.0d0) volbox = volbox + step scale = (volbox/volold)**third xbox = xbox * scale ybox = ybox * scale zbox = zbox * scale call lattice if (integrate .eq. 'RIGIDBODY') then scale = scale - 1.0d0 do i = 1, ngrp xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 start = igrp(1,i) stop = igrp(2,i) do j = start, stop k = kgrp(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do xmove = scale * xcm/grpmass(i) ymove = scale * ycm/grpmass(i) zmove = scale * zcm/grpmass(i) do j = start, stop k = kgrp(j) x(k) = x(k) + xmove y(k) = y(k) + ymove z(k) = z(k) + zmove end do end do else if (volscale .eq. 'MOLECULAR') then scale = scale - 1.0d0 do i = 1, nmol xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 start = imol(1,i) stop = imol(2,i) do j = start, stop k = kmol(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do xmove = scale * xcm/molmass(i) ymove = scale * ycm/molmass(i) zmove = scale * zcm/molmass(i) do j = start, stop k = kmol(j) if (use(k)) then x(k) = x(k) + xmove y(k) = y(k) + ymove z(k) = z(k) + zmove end if end do end do else do i = 1, nuse k = iuse(i) x(k) = x(k) * scale y(k) = y(k) * scale z(k) = z(k) * scale end do end if c c for anisotropic case alter lattice angles, then scale lengths c else rnd6 = 6.0d0*random() step = volmove * (2.0d0*random()-1.0d0) scale = (1.0d0+step/volold)**third ascale(1,1) = 1.0d0 ascale(2,2) = 1.0d0 ascale(3,3) = 1.0d0 if (monoclinic .or. triclinic) then if (rnd6 .lt. 1.0d0) then ascale(1,1) = scale else if (rnd6 .lt. 2.0d0) then ascale(2,2) = scale else if (rnd6 .lt. 3.0d0) then ascale(3,3) = scale else if (rnd6 .lt. 4.0d0) then ascale(1,2) = scale - 1.0d0 ascale(2,1) = scale - 1.0d0 else if (rnd6 .lt. 5.0d0) then ascale(1,3) = scale - 1.0d0 ascale(3,1) = scale - 1.0d0 else ascale(2,3) = scale - 1.0d0 ascale(3,2) = scale - 1.0d0 end if else if (rnd6 .lt. 2.0d0) then ascale(1,1) = scale else if (rnd6 .lt. 4.0d0) then ascale(2,2) = scale else ascale(3,3) = scale end if end if c c modify the current periodic box lattice angle values c temp3(1,1) = xbox temp3(2,1) = 0.0d0 temp3(3,1) = 0.0d0 temp3(1,2) = ybox * gamma_cos temp3(2,2) = ybox * gamma_sin temp3(3,2) = 0.0d0 temp3(1,3) = zbox * beta_cos temp3(2,3) = zbox * beta_term temp3(3,3) = zbox * gamma_term do i = 1, 3 do j = 1, 3 hbox(j,i) = 0.0d0 do k = 1, 3 hbox(j,i) = hbox(j,i) + ascale(j,k)*temp3(k,i) end do end do end do xbox = sqrt(hbox(1,1)**2 + hbox(2,1)**2 + hbox(3,1)**2) ybox = sqrt(hbox(1,2)**2 + hbox(2,2)**2 + hbox(3,2)**2) zbox = sqrt(hbox(1,3)**2 + hbox(2,3)**2 + hbox(3,3)**2) if (monoclinic) then cosine = (hbox(1,1)*hbox(1,3) + hbox(2,1)*hbox(2,3) & + hbox(3,1)*hbox(3,3)) / (xbox*zbox) beta = radian * acos(cosine) else if (triclinic) then cosine = (hbox(1,2)*hbox(1,3) + hbox(2,2)*hbox(2,3) & + hbox(3,2)*hbox(3,3)) / (ybox*zbox) alpha = radian * acos(cosine) cosine = (hbox(1,1)*hbox(1,3) + hbox(2,1)*hbox(2,3) & + hbox(3,1)*hbox(3,3)) / (xbox*zbox) beta = radian * acos(cosine) cosine = (hbox(1,1)*hbox(1,2) + hbox(2,1)*hbox(2,2) & + hbox(3,1)*hbox(3,2)) / (xbox*ybox) gamma = radian * acos(cosine) end if c c find the new box dimensions and other lattice values c call lattice scale = (volbox/volold)**third xbox = xbox * scale ybox = ybox * scale zbox = zbox * scale call lattice c c scale the coordinates by groups, molecules or atoms c if (integrate .eq. 'RIGIDBODY') then ascale(1,1) = ascale(1,1) - 1.0d0 ascale(2,2) = ascale(2,2) - 1.0d0 ascale(3,3) = ascale(3,3) - 1.0d0 do i = 1, ngrp xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 start = igrp(1,i) stop = igrp(2,i) do j = start, stop k = kmol(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do xcm = xcm / grpmass(i) ycm = ycm / grpmass(i) zcm = zcm / grpmass(i) xmove = xcm*ascale(1,1) + ycm*ascale(1,2) & + zcm*ascale(1,3) ymove = xcm*ascale(2,1) + ycm*ascale(2,2) & + zcm*ascale(2,3) zmove = xcm*ascale(3,1) + ycm*ascale(3,2) & + zcm*ascale(3,3) do j = start, stop k = kgrp(j) x(k) = x(k) + xmove y(k) = y(k) + ymove z(k) = z(k) + zmove end do end do else if (volscale .eq. 'MOLECULAR') then ascale(1,1) = ascale(1,1) - 1.0d0 ascale(2,2) = ascale(2,2) - 1.0d0 ascale(3,3) = ascale(3,3) - 1.0d0 do i = 1, nmol xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 start = imol(1,i) stop = imol(2,i) do j = start, stop k = kmol(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do xcm = xcm / molmass(i) ycm = ycm / molmass(i) zcm = zcm / molmass(i) xmove = xcm*ascale(1,1) + ycm*ascale(1,2) & + zcm*ascale(1,3) ymove = xcm*ascale(2,1) + ycm*ascale(2,2) & + zcm*ascale(2,3) zmove = xcm*ascale(3,1) + ycm*ascale(3,2) & + zcm*ascale(3,3) do j = start, stop k = kmol(j) if (use(k)) then x(k) = x(k) + xmove y(k) = y(k) + ymove z(k) = z(k) + zmove end if end do end do else do i = 1, nuse k = iuse(i) x(k) = x(k)*ascale(1,1) + y(k)*ascale(1,2) & + z(k)*ascale(1,3) y(k) = x(k)*ascale(2,1) + y(k)*ascale(2,2) & + z(k)*ascale(2,3) z(k) = x(k)*ascale(3,1) + y(k)*ascale(3,2) & + z(k)*ascale(3,3) end do end if end if c c get the potential energy and PV work changes for trial move c epot = energy () dpot = epot - eold dpv = atmsph * (volbox-volold) / prescon c c estimate the kinetic energy change as an ideal gas term c if (integrate .eq. 'RIGIDBODY') then dkin = dble(ngrp) * kt * log(volold/volbox) else if (volscale .eq. 'MOLECULAR') then dkin = dble(nmol) * kt * log(volold/volbox) else dkin = dble(nmol) * kt * log(volold/volbox) c dkin = dble(nuse) * kt * log(volold/volbox) end if c c alternatively get the kinetic energy change from velocities c c dkin = 0.0d0 c do i = 1, nuse c k = iuse(i) c term = 1.5d0 * mass(k) / ekcal c do j = 1, 3 c dkin = dkin + term*(v(j,k)**2-vold(j,k)**2) c end do c end do c if (integrate .eq. 'RIGIDBODY') then c dkin = dkin * dble(ngrp)/dble(nuse) c else if (volscale .eq. 'MOLECULAR') then c dkin = dkin * dble(nmol)/dble(nuse) c else c dkin = dkin * dble(nuse)/dble(nuse) c end if c c acceptance ratio from Epot change, Ekin change and PV work c term = -(dpot+dpv+dkin) / kt expterm = exp(term) c c reject the step, and restore values prior to trial change c if (random() .gt. expterm) then epot = eold xbox = xboxold ybox = yboxold zbox = zboxold alpha = alphaold beta = betaold gamma = gammaold call lattice do i = 1, n x(i) = xold(i) y(i) = yold(i) z(i) = zold(i) end do end if c c perform deallocation of some local arrays c deallocate (xold) deallocate (yold) deallocate (zold) end if return end c c c ############################################################# c ## ## c ## subroutine pscale -- Berendsen barostat via scaling ## c ## ## c ############################################################# c c c "pscale" implements a Berendsen barostat by scaling the c coordinates and box dimensions via coupling to an external c constant pressure bath c c literature references: c c H. J. C. Berendsen, J. P. M. Postma, W. F. van Gunsteren, c A. DiNola and J. R. Hauk, "Molecular Dynamics with Coupling c to an External Bath", Journal of Chemical Physics, 81, c 3684-3690 (1984) c c S. E. Feller, Y. Zhang, R. W. Pastor, B. R. Brooks, "Constant c Pressure Molecular Dynamics Simulation: The Langevin Piston c Method", Journal of Chemical Physics, 103, 4613-4621 (1995) c c code for anisotropic pressure coupling was provided by Guido c Raos, Dipartimento di Chimica, Politecnico di Milano, Italy c c subroutine pscale (dt,pres,stress) use atomid use atoms use bath use boxes use group use math use mdstuf use usage implicit none integer i,j,k integer start,stop real*8 dt,pres,weigh real*8 cosine,scale real*8 xcm,xmove real*8 ycm,ymove real*8 zcm,zmove real*8 stress(3,3) real*8 temp(3,3) real*8 hbox(3,3) real*8 ascale(3,3) c c c find the isotropic scale factor for constant pressure c if (.not. anisotrop) then scale = (1.0d0 + (dt*compress/taupres)*(pres-atmsph))**third c c modify the current periodic box dimension values c xbox = xbox * scale ybox = ybox * scale zbox = zbox * scale c c propagate the new box dimensions to other lattice values c call lattice c c couple to pressure bath via atom scaling in Cartesian space c if (integrate .ne. 'RIGIDBODY') then do i = 1, nuse k = iuse(i) x(k) = x(k) * scale y(k) = y(k) * scale z(k) = z(k) * scale end do c c couple to pressure bath via center of mass of rigid bodies c else scale = scale - 1.0d0 do i = 1, ngrp start = igrp(1,i) stop = igrp(2,i) xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 do j = start, stop k = kgrp(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do xmove = scale * xcm/grpmass(i) ymove = scale * ycm/grpmass(i) zmove = scale * zcm/grpmass(i) do j = start, stop k = kgrp(j) x(k) = x(k) + xmove y(k) = y(k) + ymove z(k) = z(k) + zmove end do end do end if c c find the anisotropic scale factors for constant pressure c else scale = third * dt * compress / taupres do i = 1, 3 do j = 1, 3 if (j. eq. i) then ascale(j,i) = 1.0d0 + scale*(stress(i,i)-atmsph) else ascale(j,i) = scale*stress(j,i) end if end do end do c c modify the current periodic box dimension values c temp(1,1) = xbox temp(2,1) = 0.0d0 temp(3,1) = 0.0d0 temp(1,2) = ybox * gamma_cos temp(2,2) = ybox * gamma_sin temp(3,2) = 0.0d0 temp(1,3) = zbox * beta_cos temp(2,3) = zbox * beta_term temp(3,3) = zbox * gamma_term do i = 1, 3 do j = 1, 3 hbox(j,i) = 0.0d0 do k = 1, 3 hbox(j,i) = hbox(j,i) + ascale(j,k)*temp(k,i) end do end do end do xbox = sqrt(hbox(1,1)**2 + hbox(2,1)**2 + hbox(3,1)**2) ybox = sqrt(hbox(1,2)**2 + hbox(2,2)**2 + hbox(3,2)**2) zbox = sqrt(hbox(1,3)**2 + hbox(2,3)**2 + hbox(3,3)**2) if (monoclinic) then cosine = (hbox(1,1)*hbox(1,3) + hbox(2,1)*hbox(2,3) & + hbox(3,1)*hbox(3,3)) / (xbox*zbox) beta = radian * acos(cosine) else if (triclinic) then cosine = (hbox(1,2)*hbox(1,3) + hbox(2,2)*hbox(2,3) & + hbox(3,2)*hbox(3,3)) / (ybox*zbox) alpha = radian * acos(cosine) cosine = (hbox(1,1)*hbox(1,3) + hbox(2,1)*hbox(2,3) & + hbox(3,1)*hbox(3,3)) / (xbox*zbox) beta = radian * acos(cosine) cosine = (hbox(1,1)*hbox(1,2) + hbox(2,1)*hbox(2,2) & + hbox(3,1)*hbox(3,2)) / (xbox*ybox) gamma = radian * acos(cosine) end if c c propagate the new box dimensions to other lattice values c call lattice c c couple to pressure bath via atom scaling in Cartesian space c if (integrate .ne. 'RIGIDBODY') then do i = 1, nuse k = iuse(i) x(k) = x(k)*ascale(1,1) + y(k)*ascale(1,2) & + z(k)*ascale(1,3) y(k) = x(k)*ascale(2,1) + y(k)*ascale(2,2) & + z(k)*ascale(2,3) z(k) = x(k)*ascale(3,1) + y(k)*ascale(3,2) & + z(k)*ascale(3,3) end do c c couple to pressure bath via center of mass of rigid bodies c else ascale(1,1) = ascale(1,1) - 1.0d0 ascale(2,2) = ascale(2,2) - 1.0d0 ascale(3,3) = ascale(3,3) - 1.0d0 do i = 1, ngrp start = igrp(1,i) stop = igrp(2,i) xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 do j = start, stop k = kgrp(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = xcm + y(k)*weigh zcm = xcm + z(k)*weigh end do xcm = xcm / grpmass(i) ycm = ycm / grpmass(i) zcm = zcm / grpmass(i) xmove = xcm*ascale(1,1) + ycm*ascale(1,2) & + zcm*ascale(1,3) ymove = xcm*ascale(2,1) + ycm*ascale(2,2) & + zcm*ascale(2,3) zmove = xcm*ascale(3,1) + ycm*ascale(3,2) & + zcm*ascale(3,3) do j = start, stop k = kgrp(j) x(k) = x(k) + xmove y(k) = y(k) + ymove z(k) = z(k) + zmove end do end do end if end if return end c c c ################################################### c ## COPYRIGHT (C) 2004 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## program prmedit -- edit and renumber parameter files ## c ## ## c ############################################################## c c c "prmedit" reformats an existing parameter file, and revises c type and class numbers based on the "atom" parameter ordering c c program prmedit use iounit implicit none integer iprm integer nmode,mode integer freeunit integer trimtext logical dotype,doclass logical exist,query character*240 prmfile character*240 string c c c read and store the original force field parameter file c call initial call getprm nmode = 7 c c get the desired type of parameter file modification c 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 Parameter Editing Facility can Provide :', & //,4x,'(1) Format Individual Parameter Records', & /,4x,'(2) Reorder Individual Parameter Records', & /,4x,'(3) Renumber the Atom Types, and Reorder', & /,4x,'(4) Renumber the Atom Classes, and Reorder', & /,4x,'(5) Renumber Types and Classes, and Reorder', & /,4x,'(6) Sort and Format Multipole Parameters', & /,4x,'(7) Renumber and Format Biotype Parameters') do while (mode.lt.1 .or. mode.gt.nmode) 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 set the renumbering operations to be performed c dotype = .false. doclass = .false. if (mode .eq. 3) dotype = .true. if (mode .eq. 4) doclass = .true. if (mode .eq. 5) then dotype = .true. doclass = .true. end if c c format records in the original parameter file c if (mode .eq. 1) then iprm = freeunit () prmfile = 'parameter.prm' call version (prmfile,'new') open (unit=iprm,file=prmfile,status='new') call prmform (iprm) write (iout,60) prmfile(1:trimtext(prmfile)) 60 format (/,' Reformated Parameter File Written To : ',a) close (unit=iprm) end if c c reorder and renumber the original parameter file c if (mode.ge.2 .and. mode.le.5) then iprm = freeunit () prmfile = 'parameter.prm' call version (prmfile,'new') open (unit=iprm,file=prmfile,status='new') call prmorder (iprm,dotype,doclass) write (iout,70) prmfile(1:trimtext(prmfile)) 70 format (/,' Renumbered Parameter File Written To : ',a) close (unit=iprm) end if c c sort the atomic multipole parameters by atom type c if (mode .eq. 6) then iprm = freeunit () prmfile = 'multipole.prm' call version (prmfile,'new') open (unit=iprm,file=prmfile,status='new') call polesort (iprm) write (iout,80) prmfile(1:trimtext(prmfile)) 80 format (/,' Sorted Multipole Values Written To : ',a) close (unit=iprm) end if c c renumber and format any biotype parameter values c if (mode .eq. 7) then iprm = freeunit () prmfile = 'biotype.prm' call version (prmfile,'new') open (unit=iprm,file=prmfile,status='new') call biosort (iprm) write (iout,90) prmfile(1:trimtext(prmfile)) 90 format (/,' Renumbered Biotype Values Written To : ',a) close (unit=iprm) end if call final end c c c ############################################################## c ## ## c ## subroutine prmform -- reformat individual parameters ## c ## ## c ############################################################## c c c "prmform" formats each individual parameter record to conform c to a consistent text layout c c subroutine prmform (iprm) use angpot use bndpot use math use params use sizes use urypot implicit none integer i,j,iprm integer ia,ib,ic integer id,ie integer length,next integer trimtext integer atn,lig integer kg,kt integer nx,ny,nxy integer ft(6) integer ig(20) real*8 wght real*8 rd,ep,rdn real*8 spr,apr,epr real*8 cdp,adp real*8 dl,fc,bd real*8 an1,an2,an3 real*8 an,pr real*8 ba1,ba2 real*8 ds,dk,vd,pt real*8 aa1,aa2,aa3 real*8 bt1,bt2,bt3 real*8 bt4,bt5,bt6 real*8 bt7,bt8,bt9 real*8 at1,at2,at3 real*8 at4,at5,at6 real*8 tx,ty,tf real*8 cg,dp,ps,pl real*8 pl1,pl2,pl3 real*8 pel,pal real*8 pol,thl,thd real*8 ctrn,atrn real*8 cfb,cfa1,cfa2 real*8 cfb1,cfb2 real*8 el,iz,rp real*8 pbrd,csrd real*8 gkrd,snek real*8 ss,ts real*8 vt(6),st(6) character*3 sym character*20 keyword character*20 text character*24 note character*30 blank character*240 record character*240 string c c c reformat and print the various parameters c i = 0 blank = ' ' do while (i .lt. nprm) i = i + 1 record = prmline(i) length = trimtext (record) next = 1 call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:5) .eq. 'ATOM ') then ia = -1 ib = -1 sym = ' ' note = ' ' atn = 0 wght = 0.0d0 lig = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call gettext (record,sym,next) call getstring (record,note,next) string = record(next:240) read (string,*,err=10,end=10) atn,wght,lig 10 continue length = trimtext(note) string = '"'//note(1:length)//'"'//blank if (ib .ge. 0) then write (iprm,20) ia,ib,sym,string(1:26),atn,wght,lig 20 format ('atom',6x,2i5,4x,a3,3x,a26,1x,i5,f10.3,i5) else if (ia .ge. 0) then write (iprm,30) ia,sym,string(1:26),atn,wght,lig 30 format ('atom',6x,i5,4x,a3,3x,a26,1x,i5,f10.3,i5) else write (iprm,40) record(1:length) 40 format (a) end if else if (keyword(1:4) .eq. 'VDW ') then ia = 0 rd = 0.0d0 ep = 0.0d0 rdn = 0.0d0 read (string,*,err=50,end=50) ia,rd,ep,rdn 50 continue if (rdn .eq. 0.0d0) then write (iprm,60) ia,rd,ep 60 format ('vdw',7x,i5,10x,2f11.4) else write (iprm,70) ia,rd,ep,rdn 70 format ('vdw',7x,i5,10x,2f11.4,f11.3) end if else if (keyword(1:6) .eq. 'VDW14 ') then ia = 0 rd = 0.0d0 ep = 0.0d0 read (string,*,err=80,end=80) ia,rd,ep 80 continue write (iprm,90) ia,rd,ep 90 format ('vdw14',5x,i5,10x,2f11.4) else if (keyword(1:8) .eq. 'VDWPAIR ' .or. & keyword(1:6) .eq. 'VDWPR ') then ia = 0 ib = 0 rd = 0.0d0 ep = 0.0d0 read (string,*,err=100,end=100) ia,ib,rd,ep 100 continue write (iprm,110) ia,ib,rd,ep 110 format ('vdwpair',3x,2i5,5x,2f11.4) else if (keyword(1:6) .eq. 'HBOND ') then ia = 0 ib = 0 rd = 0.0d0 ep = 0.0d0 read (string,*,err=120,end=120) ia,ib,rd,ep 120 continue write (iprm,130) ia,ib,rd,ep 130 format ('hbond',5x,2i5,5x,2f11.4) else if (keyword(1:10) .eq. 'REPULSION ') then ia = 0 spr = 0.0d0 apr = 0.0d0 epr = 0.0d0 read (string,*,err=140,end=140) ia,spr,apr,epr 140 continue write (iprm,150) ia,spr,apr,epr 150 format ('repulsion',6x,i5,5x,2f11.4,f11.3) else if (keyword(1:11) .eq. 'DISPERSION ') then ia = 0 cdp = 0.0d0 adp = 0.0d0 read (string,*,err=160,end=160) ia,cdp,adp 160 continue write (iprm,170) ia,cdp,adp 170 format ('dispersion',5x,i5,5x,2f11.4) else if (keyword(1:5) .eq. 'BOND ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 read (string,*,err=180,end=180) ia,ib,fc,bd 180 continue if (bndunit .lt. 10.0d0) then write (iprm,190) ia,ib,fc,bd 190 format ('bond',6x,2i5,5x,f11.2,f11.4) else write (iprm,200) ia,ib,fc,bd 200 format ('bond',6x,2i5,5x,f11.3,f11.4) end if else if (keyword(1:6) .eq. 'BOND5 ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 read (string,*,err=210,end=210) ia,ib,fc,bd 210 continue if (bndunit .lt. 10.0d0) then write (iprm,220) ia,ib,fc,bd 220 format ('bond5',5x,2i5,5x,f11.2,f11.4) else write (iprm,230) ia,ib,fc,bd 230 format ('bond5',5x,2i5,5x,f11.3,f11.4) end if else if (keyword(1:6) .eq. 'BOND4 ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 read (string,*,err=240,end=240) ia,ib,fc,bd 240 continue if (bndunit .lt. 10.0d0) then write (iprm,250) ia,ib,fc,bd 250 format ('bond4',5x,2i5,5x,f11.2,f11.4) else write (iprm,260) ia,ib,fc,bd 260 format ('bond4',5x,2i5,5x,f11.3,f11.4) end if else if (keyword(1:6) .eq. 'BOND3 ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 read (string,*,err=270,end=270) ia,ib,fc,bd 270 continue if (bndunit .lt. 10.0d0) then write (iprm,280) ia,ib,fc,bd 280 format ('bond3',5x,2i5,5x,f11.2,f11.4) else write (iprm,290) ia,ib,fc,bd 290 format ('bond3',5x,2i5,5x,f11.3,f11.4) end if else if (keyword(1:9) .eq. 'ELECTNEG ') then ia = 0 ib = 0 ic = 0 dl = 0.0d0 read (string,*,err=300,end=300) ia,ib,ic,dl 300 continue write (iprm,310) ia,ib,ic,dl 310 format ('electneg',2x,3i5,11x,f11.4) else if (keyword(1:6) .eq. 'ANGLE ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 an3 = 0.0d0 read (string,*,err=320,end=320) ia,ib,ic,fc,an1,an2,an3 320 continue if (an2.eq.0.0d0 .and. an3.eq.0.0d0) then if (angunit .lt. 10.0d0/radian**2) then write (iprm,330) ia,ib,ic,fc,an1 330 format ('angle',5x,3i5,f11.2,f11.2) else write (iprm,340) ia,ib,ic,fc,an1 340 format ('angle',5x,3i5,f11.3,f11.2) end if else if (angunit .lt. 10.0d0/radian**2) then write (iprm,350) ia,ib,ic,fc,an1,an2,an3 350 format ('angle',5x,3i5,f11.2,3f11.2) else write (iprm,360) ia,ib,ic,fc,an1,an2,an3 360 format ('angle',5x,3i5,f11.3,3f11.2) end if end if else if (keyword(1:7) .eq. 'ANGLE5 ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 an3 = 0.0d0 read (string,*,err=370,end=370) ia,ib,ic,fc,an1,an2,an3 370 continue if (an2.eq.0.0d0 .and. an3.eq.0.0d0) then if (angunit .lt. 10.0d0/radian**2) then write (iprm,380) ia,ib,ic,fc,an1 380 format ('angle5',4x,3i5,f11.2,f11.2) else write (iprm,390) ia,ib,ic,fc,an1 390 format ('angle5',4x,3i5,f11.3,f11.2) end if else if (angunit .lt. 10.0d0/radian**2) then write (iprm,400) ia,ib,ic,fc,an1,an2,an3 400 format ('angle5',4x,3i5,f11.2,3f11.2) else write (iprm,410) ia,ib,ic,fc,an1,an2,an3 410 format ('angle5',4x,3i5,f11.3,3f11.2) end if end if else if (keyword(1:7) .eq. 'ANGLE4 ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 an3 = 0.0d0 read (string,*,err=420,end=420) ia,ib,ic,fc,an1,an2,an3 420 continue if (an2.eq.0.0d0 .and. an3.eq.0.0d0) then if (angunit .lt. 10.0d0/radian**2) then write (iprm,430) ia,ib,ic,fc,an1 430 format ('angle4',4x,3i5,f11.2,f11.2) else write (iprm,440) ia,ib,ic,fc,an1 440 format ('angle4',4x,3i5,f11.3,f11.2) end if else if (angunit .lt. 10.0d0/radian**2) then write (iprm,450) ia,ib,ic,fc,an1,an2,an3 450 format ('angle4',4x,3i5,f11.2,3f11.2) else write (iprm,460) ia,ib,ic,fc,an1,an2,an3 460 format ('angle4',4x,3i5,f11.3,3f11.2) end if end if else if (keyword(1:7) .eq. 'ANGLE3 ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 an3 = 0.0d0 read (string,*,err=470,end=470) ia,ib,ic,fc,an1,an2,an3 470 continue if (an2.eq.0.0d0 .and. an3.eq.0.0d0) then if (angunit .lt. 10.0d0/radian**2) then write (iprm,480) ia,ib,ic,fc,an1 480 format ('angle3',4x,3i5,f11.2,f11.2) else write (iprm,490) ia,ib,ic,fc,an1 490 format ('angle3',4x,3i5,f11.3,f11.2) end if else if (angunit .lt. 10.0d0/radian**2) then write (iprm,500) ia,ib,ic,fc,an1,an2,an3 500 format ('angle3',4x,3i5,f11.2,3f11.2) else write (iprm,510) ia,ib,ic,fc,an1,an2,an3 510 format ('angle3',4x,3i5,f11.3,3f11.2) end if end if else if (keyword(1:7) .eq. 'ANGLEP ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 an3 = 0.0d0 read (string,*,err=520,end=520) ia,ib,ic,fc,an1,an2,an3 520 continue if (an2.eq.0.0d0 .and. an3.eq.0.0d0) then if (angunit .lt. 10.0d0/radian**2) then write (iprm,530) ia,ib,ic,fc,an1 530 format ('anglep',4x,3i5,f11.2,f11.2) else write (iprm,540) ia,ib,ic,fc,an1 540 format ('anglep',4x,3i5,f11.3,f11.2) end if else if (angunit .lt. 10.0d0/radian**2) then write (iprm,550) ia,ib,ic,fc,an1,an2,an3 550 format ('anglep',4x,3i5,f11.2,3f11.2) else write (iprm,560) ia,ib,ic,fc,an1,an2,an3 560 format ('anglep',4x,3i5,f11.3,3f11.2) end if end if else if (keyword(1:7) .eq. 'ANGLEF ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an = 0.0d0 pr = 0.0d0 read (string,*,err=570,end=570) ia,ib,ic,fc,an,pr 570 continue if (angunit .lt. 10.0d0/radian**2) then write (iprm,580) ia,ib,ic,fc,an,pr 580 format ('anglef',4x,3i5,f11.2,f11.2,f11.1) else write (iprm,590) ia,ib,ic,fc,an,pr 590 format ('anglef',4x,3i5,f11.3,f11.2,f11.1) end if else if (keyword(1:7) .eq. 'STRBND ') then ia = 0 ib = 0 ic = 0 ba1 = 0.0d0 ba2 = 0.0d0 read (string,*,err=600,end=600) ia,ib,ic,ba1,ba2 600 continue if (stbnunit .lt. 10.0d0/radian) then write (iprm,610) ia,ib,ic,ba1,ba2 610 format ('strbnd',4x,3i5,2f11.2) else write (iprm,620) ia,ib,ic,ba1,ba2 620 format ('strbnd',4x,3i5,2f11.3) end if else if (keyword(1:9) .eq. 'UREYBRAD ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 ds = 0.0d0 read (string,*,err=630,end=630) ia,ib,ic,fc,ds 630 continue if (ureyunit .lt. 10.0d0) then write (iprm,640) ia,ib,ic,fc,ds 640 format ('ureybrad',2x,3i5,f11.2,f11.4) else write (iprm,650) ia,ib,ic,fc,ds 650 format ('ureybrad',2x,3i5,f11.3,f11.4) end if else if (keyword(1:7) .eq. 'ANGANG ') then ia = 0 aa1 = 0.0d0 aa2 = 0.0d0 aa3 = 0.0d0 read (string,*,err=660,end=660) ia,aa1,aa2,aa3 660 continue if (abs(aaunit) .lt. 10.0d0/radian**2) then write (iprm,670) ia,aa1,aa2,aa3 670 format ('angang',4x,i5,10x,3f11.2) else write (iprm,680) ia,aa1,aa2,aa3 680 format ('angang',4x,i5,10x,3f11.3) end if else if (keyword(1:7) .eq. 'OPBEND ') then ia = 0 ib = 0 ic = 0 id = 0 fc = 0.0d0 read (string,*,err=690,end=690) ia,ib,ic,id,fc 690 continue if (opbunit .lt. 10.0d0/radian**2) then write (iprm,700) ia,ib,ic,id,fc 700 format ('opbend',4x,4i5,6x,f11.2) else write (iprm,710) ia,ib,ic,id,fc 710 format ('opbend',4x,4i5,6x,f11.3) end if else if (keyword(1:7) .eq. 'OPDIST ') then ia = 0 ib = 0 ic = 0 id = 0 fc = 0.0d0 read (string,*,err=720,end=720) ia,ib,ic,id,fc 720 continue if (opdunit .lt. 10.0d0) then write (iprm,730) ia,ib,ic,id,fc 730 format ('opdist',4x,4i5,6x,f11.2) else write (iprm,740) ia,ib,ic,id,fc 740 format ('opdist',4x,4i5,6x,f11.3) end if else if (keyword(1:9) .eq. 'IMPROPER ') then ia = 0 ib = 0 ic = 0 id = 0 dk = 0.0d0 vd = 0.0d0 read (string,*,err=750,end=750) ia,ib,ic,id,dk,vd 750 continue write (iprm,760) ia,ib,ic,id,dk,vd 760 format ('improper',2x,4i5,6x,2f11.2) else if (keyword(1:8) .eq. 'IMPTORS ') then ia = 0 ib = 0 ic = 0 id = 0 do j = 1, 6 vt(j) = 0.0d0 st(j) = 0.0d0 ft(j) = 0 end do read (string,*,err=770,end=770) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,6) 770 continue kt = 0 do j = 1, 6 if (ft(j) .ne. 0) then kt = j end if end do write (iprm,780) ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt) 780 format ('imptors',3x,4i5,6x,6(f11.3,f7.1,i3)) else if (keyword(1:8) .eq. 'TORSION ') then ia = 0 ib = 0 ic = 0 id = 0 do j = 1, 6 vt(j) = 0.0d0 st(j) = 0.0d0 ft(j) = 0 end do read (string,*,err=790,end=790) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,6) 790 continue kt = 0 do j = 1, 6 if (ft(j) .ne. 0) then kt = j end if end do if (kt.eq.3 .and. st(1).eq.0.0d0 .and. st(2).eq.180.0d0 & .and. st(3).eq.0.0d0) then write (iprm,800) ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt) 800 format ('torsion',3x,4i5,3x,f8.3,f4.1,i2, & f8.3,f6.1,i2,f8.3,f4.1,i2) else if (kt .le. 2) then write (iprm,810) ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt) 810 format ('torsion',3x,4i5,6x,2(f11.3,f7.1,i3)) else write (iprm,820) ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt) 820 format ('torsion',3x,4i5,3x,6(f8.3,f6.1,i2)) end if else if (keyword(1:9) .eq. 'TORSION5 ') then ia = 0 ib = 0 ic = 0 id = 0 do j = 1, 6 vt(j) = 0.0d0 st(j) = 0.0d0 ft(j) = 0 end do read (string,*,err=830,end=830) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,6) 830 continue kt = 0 do j = 1, 6 if (ft(j) .ne. 0) then kt = j end if end do if (kt.eq.3 .and. st(1).eq.0.0d0 .and. st(2).eq.180.0d0 & .and. st(3).eq.0.0d0) then write (iprm,840) ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt) 840 format ('torsion5',2x,4i5,3x,f8.3,f4.1,i2, & f8.3,f6.1,i2,f8.3,f4.1,i2) else if (kt .le. 2) then write (iprm,850) ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt) 850 format ('torsion5',2x,4i5,6x,2(f11.3,f7.1,i3)) else write (iprm,860) ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt) 860 format ('torsion5',2x,4i5,3x,6(f8.3,f6.1,i2)) end if else if (keyword(1:9) .eq. 'TORSION4 ') then ia = 0 ib = 0 ic = 0 id = 0 do j = 1, 6 vt(j) = 0.0d0 st(j) = 0.0d0 ft(j) = 0 end do read (string,*,err=870,end=870) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,6) 870 continue kt = 0 do j = 1, 6 if (ft(j) .ne. 0) then kt = j end if end do if (kt.eq.3 .and. st(1).eq.0.0d0 .and. st(2).eq.180.0d0 & .and. st(3).eq.0.0d0) then write (iprm,880) ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt) 880 format ('torsion4',2x,4i5,3x,f8.3,f4.1,i2, & f8.3,f6.1,i2,f8.3,f4.1,i2) else if (kt .le. 2) then write (iprm,890) ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt) 890 format ('torsion4',2x,4i5,6x,2(f11.3,f7.1,i3)) else write (iprm,900) ia,ib,ic,id,(vt(j),st(j),ft(j),j=1,kt) 900 format ('torsion4',2x,4i5,3x,6(f8.3,f6.1,i2)) end if else if (keyword(1:7) .eq. 'PITORS ') then ia = 0 ib = 0 pt = 0.0d0 read (string,*,err=910,end=910) ia,ib,pt 910 continue write (iprm,920) ia,ib,pt 920 format ('pitors',4x,2i5,5x,f11.2) else if (keyword(1:8) .eq. 'STRTORS ') then ia = 0 ib = 0 ic = 0 id = 0 bt1 = 0.0d0 bt2 = 0.0d0 bt3 = 0.0d0 bt4 = 0.0d0 bt5 = 0.0d0 bt6 = 0.0d0 bt7 = 0.0d0 bt8 = 0.0d0 bt9 = 0.0d0 read (string,*,err=930,end=930) ia,ib,ic,id,bt1,bt2,bt3, & bt4,bt5,bt6,bt7,bt8,bt9 930 continue write (iprm,940) ia,ib,ic,id,bt1,bt2,bt3, & bt4,bt5,bt6,bt7,bt8,bt9 940 format ('strtors',3x,4i5,1x,9f8.3) else if (keyword(1:8) .eq. 'ANGTORS ') then ia = 0 ib = 0 ic = 0 id = 0 at1 = 0.0d0 at2 = 0.0d0 at3 = 0.0d0 at4 = 0.0d0 at5 = 0.0d0 at6 = 0.0d0 read (string,*,err=950,end=950) ia,ib,ic,id,at1,at2, & at3,at4,at5,at6 950 continue write (iprm,960) ia,ib,ic,id,at1,at2,at3,at4,at5,at6 960 format ('angtors',3x,4i5,1x,6f8.3) else if (keyword(1:8) .eq. 'TORTORS ') then ia = 0 ib = 0 ic = 0 id = 0 ie = 0 nx = 0 ny = 0 read (string,*,err=970,end=970) ia,ib,ic,id,ie,nx,ny 970 continue write (iprm,980) ia,ib,ic,id,ie,nx,ny 980 format ('tortors',3x,5i5,5x,2i5) nxy = nx * ny do j = 1, nxy i = i + 1 record = prmline(i) read (record,*,err=990,end=990) tx,ty,tf 990 continue write (iprm,1000) tx,ty,tf 1000 format (f8.1,1x,f8.1,1x,f11.5) end do else if (keyword(1:7) .eq. 'CHARGE ') then ia = 0 cg = 0.0d0 read (string,*,err=1010,end=1010) ia,cg 1010 continue write (iprm,1020) ia,cg 1020 format ('charge',4x,i5,10x,f11.4) else if (keyword(1:7) .eq. 'DIPOLE ') then ia = 0 ib = 0 dp = 0.0d0 ps = 0.5d0 read (string,*,err=1030,end=1030) ia,ib,dp,ps 1030 continue write (iprm,1040) ia,ib,dp,ps 1040 format ('dipole',4x,2i5,5x,f11.4,f11.3) else if (keyword(1:8) .eq. 'DIPOLE5 ') then ia = 0 ib = 0 dp = 0.0d0 ps = 0.5d0 read (string,*,err=1050,end=1050) ia,ib,dp,ps 1050 continue write (iprm,1060) ia,ib,dp,ps 1060 format ('dipole5',3x,2i5,5x,f11.4,f11.3) else if (keyword(1:8) .eq. 'DIPOLE4 ') then ia = 0 ib = 0 dp = 0.0d0 ps = 0.5d0 read (string,*,err=1070,end=1070) ia,ib,dp,ps 1070 continue write (iprm,1080) ia,ib,dp,ps 1080 format ('dipole4',3x,2i5,5x,f11.4,f11.3) else if (keyword(1:8) .eq. 'DIPOLE3 ') then ia = 0 ib = 0 dp = 0.0d0 ps = 0.5d0 read (string,*,err=1090,end=1090) ia,ib,dp,ps 1090 continue write (iprm,1100) ia,ib,dp,ps 1100 format ('dipole3',3x,2i5,5x,f11.4,f11.3) else if (keyword(1:10) .eq. 'MULTIPOLE ') then ia = 0 ib = 0 ic = 0 id = 0 pl = 0.0d0 read (string,*,err=1110,end=1110) ia,ib,ic,id,pl goto 1120 1110 continue id = 0 read (string,*,err=1120,end=1120) ia,ib,ic,pl 1120 continue if (id .eq. 0) then write (iprm,1130) ia,ib,ic,pl 1130 format ('multipole',1x,3i5,11x,f11.5) else write (iprm,1140) ia,ib,ic,id,pl 1140 format ('multipole',1x,4i5,6x,f11.5) end if i = i + 1 record = prmline(i) read (record,*,err=1150,end=1150) pl1,pl2,pl3 1150 continue write (iprm,1160) pl1,pl2,pl3 1160 format (36x,3f11.5) i = i + 1 record = prmline(i) read (record,*,err=1170,end=1170) pl1 1170 continue write (iprm,1180) pl1 1180 format (36x,f11.5) i = i + 1 record = prmline(i) read (record,*,err=1190,end=1190) pl1,pl2 1190 continue write (iprm,1200) pl1,pl2 1200 format (36x,2f11.5) i = i + 1 record = prmline(i) read (record,*,err=1210,end=1210) pl1,pl2,pl3 1210 continue write (iprm,1220) pl1,pl2,pl3 1220 format (36x,3f11.5) else if (keyword(1:7) .eq. 'CHGPEN ') then ia = 0 pel = 0.0d0 pal = 0.0d0 read (string,*,err=1230,end=1230) ia,pel,pal 1230 continue write (iprm,1240) ia,pel,pal 1240 format ('chgpen',9x,i5,5x,2f11.4) else if (keyword(1:9) .eq. 'POLARIZE ') then ia = 0 pol = 0.0d0 thl = -1.0d0 thd = -1.0d0 do j = 1, 20 ig(j) = 0 end do call getnumb (record,ia,next) call gettext (record,text,next) read (text,*,err=1250,end=1250) pol call gettext (record,text,next) j = 1 call getnumb (text,ig(1),j) if (ig(1) .eq. 0) then read (text,*,err=1250,end=1250) thl call gettext (record,text,next) j = 1 call getnumb (text,ig(1),j) string = record(next:240) if (ig(1) .eq. 0) then read (text,*,err=1250,end=1250) thd read (string,*,err=1250,end=1250) (ig(j),j=1,20) else read (string,*,err=1250,end=1250) (ig(j),j=2,20) end if else string = record(next:240) read (string,*,err=1250,end=1250) (ig(j),j=2,20) end if 1250 continue kg = 0 do j = 1, 20 if (ig(j) .ne. 0) then kg = j end if end do call sort (kg,ig) if (thd .ge. 0.0d0) then write (iprm,1260) ia,pol,thl,thd,(ig(j),j=1,kg) 1260 format ('polarize',2x,i5,5x,3f11.4,2x,20i5) else if (thl .ge. 0.0d0) then write (iprm,1270) ia,pol,thl,(ig(j),j=1,kg) 1270 format ('polarize',2x,i5,5x,2f11.4,2x,20i5) else write (iprm,1280) ia,pol,(ig(j),j=1,kg) 1280 format ('polarize',2x,i5,5x,f11.4,2x,20i5) end if else if (keyword(1:8) .eq. 'POLPAIR ') then ia = 0 ib = 0 thl = 0.0d0 thd = 0.0d0 read (string,*,err=1290,end=1290) ia,ib,thl,thd 1290 continue write (iprm,1300) ia,ib,thl,thd 1300 format ('polpair',3x,2i5,5x,2f11.4) else if (keyword(1:7) .eq. 'CHGTRN ') then ia = 0 ctrn = 0.0d0 atrn = 0.0d0 read (string,*,err=1310,end=1310) ia,ctrn,atrn 1310 continue write (iprm,1320) ia,ctrn,atrn 1320 format ('chgtrn',9x,i5,5x,2f11.4) else if (keyword(1:9) .eq. 'BNDCFLUX ') then ia = 0 ib = 0 cfb = 0.0d0 read (string,*,err=1330,end=1330) ia,ib,cfb 1330 continue write (iprm,1340) ia,ib,cfb 1340 format ('bndcflux',2x,2i5,9x,f11.5) else if (keyword(1:9) .eq. 'ANGCFLUX ') then ia = 0 ib = 0 ic = 0 cfa1 = 0.0d0 cfa2 = 0.0d0 cfb1 = 0.0d0 cfb2 = 0.0d0 read (string,*,err=1350,end=1350) ia,ib,cfa1,cfa2,cfb1,cfb2 1350 continue write (iprm,1360) ia,ib,cfa1,cfa2,cfb1,cfb2 1360 format ('angcflux',2x,2i5,9x,4f11.5) else if (keyword(1:7) .eq. 'SOLUTE ') then ia = 0 pbrd = 0.0d0 csrd = 0.0d0 gkrd = 0.0d0 snek = 0.0d0 read (string,*,err=1370,end=1370) ia,pbrd,csrd,gkrd,snek 1370 continue write (iprm,1380) ia,pbrd,csrd,gkrd,snek 1380 format ('solute',4x,i5,5x,4f11.4) else if (keyword(1:7) .eq. 'PIATOM ') then ia = 0 el = 0.0d0 iz = 0.0d0 rp = 0.0d0 read (string,*,err=1390,end=1390) ia,el,iz,rp 1390 continue write (iprm,1400) ia,el,iz,rp 1400 format ('piatom',4x,i5,10x,f11.1,2f11.3) else if (keyword(1:7) .eq. 'PIBOND ') then ia = 0 ib = 0 ss = 0.0d0 ts = 0.0d0 read (string,*,err=1410,end=1410) ia,ib,ss,ts 1410 continue write (iprm,1420) ia,ib,ss,ts 1420 format ('pibond',4x,2i5,5x,f11.3,f11.4) else if (keyword(1:8) .eq. 'PIBOND5 ') then ia = 0 ib = 0 ss = 0.0d0 ts = 0.0d0 read (string,*,err=1430,end=1430) ia,ib,ss,ts 1430 continue write (iprm,1440) ia,ib,ss,ts 1440 format ('pibond5',3x,2i5,5x,f11.3,f11.4) else if (keyword(1:8) .eq. 'PIBOND4 ') then ia = 0 ib = 0 ss = 0.0d0 ts = 0.0d0 read (string,*,err=1450,end=1450) ia,ib,ss,ts 1450 continue write (iprm,1460) ia,ib,ss,ts 1460 format ('pibond4',3x,2i5,5x,f11.3,f11.4) else if (keyword(1:6) .eq. 'METAL ') then ia = 0 call getnumb (record,ia,next) write (iprm,1470) ia,record(next:length) 1470 format ('metal',5x,i5,a) else if (keyword(1:8) .eq. 'BIOTYPE ') then ia = 0 ib = 0 sym = ' ' note = ' ' read (string,*,err=1480,end=1480) ia call getword (record,sym,next) call getstring (record,note,next) string = record(next:240) read (string,*,err=1480,end=1480) ib 1480 continue length = trimtext(note) string = '"'//note(1:length)//'"'//blank write (iprm,1490) ia,sym,string(1:30),ib 1490 format ('biotype',3x,i5,4x,a3,5x,a30,2x,i5) else if (length .eq. 0) then write (iprm,1500) 1500 format () else write (iprm,1510) record(1:length) 1510 format (a) end if end do return end c c c ############################################################### c ## ## c ## subroutine prmorder -- reorder atom types and classes ## c ## ## c ############################################################### c c c "prmorder" places a list of atom type or class numbers into c canonical order for potential energy parameter definitions c c subroutine prmorder (iprm,dotype,doclass) use iounit use params use sizes use vdwpot implicit none integer i,j,iprm integer it,ic,kt,kc integer ia,ib,id,ie integer offset,next integer length integer trimtext integer kg,ig(20) integer itype(0:maxtyp) integer iclass(0:maxclass) real*8 pol,thl,thd logical dotype,doclass logical prtclass character*20 keyword character*20 text character*30 blank character*240 record character*240 string c c c zero out the storage for atom types and classes c ia = 0 ib = 0 ic = 0 id = 0 ie = 0 kt = 0 kc = 0 do i = 0, maxtyp itype(i) = 0 end do do i = 0, maxclass iclass(i) = 0 end do blank = ' ' c c get the starting numbers for atom types and classes c if (dotype) then write (iout,10) 10 format (/,' Enter Starting Number for Atom Types [1] : ',$) read (input,20) offset 20 format (i10) if (offset .gt. 0) kt = offset - 1 end if if (doclass) then write (iout,30) 30 format (/,' Enter Starting Number for Atom Classes [1] : ',$) read (input,40) offset 40 format (i10) if (offset .gt. 0) kc = offset - 1 end if c c count, order and test equivalence of atom types and classes c prtclass = .false. do i = 1, nprm record = prmline(i) next = 1 call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:5) .eq. 'ATOM ') then it = 0 ic = 0 call getnumb (record,it,next) call getnumb (record,ic,next) if (ic .eq. 0) ic = it if (it .ne. ic) prtclass = .true. if (itype(it) .eq. 0) then kt = kt + 1 if (dotype) then itype(it) = kt else itype(it) = it end if end if if (iclass(ic) .eq. 0) then kc = kc + 1 if (doclass) then iclass(ic) = kc else iclass(ic) = ic end if end if end if end do c c reorder, renumber and print the various parameters c do i = 1, nprm record = prmline(i) length = trimtext (record) next = 1 call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:5) .eq. 'ATOM ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) if (ib .eq. 0) ib = ia ia = itype(ia) ib = iclass(ib) if (prtclass) then write (iprm,50) ia,ib,record(next:length) 50 format ('atom',6x,2i5,a) else write (iprm,60) ia,record(next:length) 60 format ('atom',6x,i5,a) end if else if (keyword(1:4) .eq. 'VDW ') then ia = 0 call getnumb (record,ia,next) if (vdwindex .eq. 'TYPE') then ia = itype(ia) else ia = iclass(ia) end if write (iprm,70) ia,record(next:length) 70 format ('vdw',7x,i5,a) else if (keyword(1:6) .eq. 'VDW14 ') then ia = 0 call getnumb (record,ia,next) if (vdwindex .eq. 'TYPE') then ia = itype(ia) else ia = iclass(ia) end if write (iprm,80) ia,record(next:length) 80 format ('vdw14',5x,i5,a) else if (keyword(1:8) .eq. 'VDWPAIR ' .or. & keyword(1:6) .eq. 'VDWPR ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) if (vdwindex .eq. 'TYPE') then ia = itype(ia) ib = itype(ib) else ia = iclass(ia) ib = iclass(ib) end if call prmsort (2,ia,ib,0,0,0) write (iprm,90) ia,ib,record(next:length) 90 format ('vdwpair',3x,2i5,a) else if (keyword(1:6) .eq. 'HBOND ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) if (vdwindex .eq. 'TYPE') then ia = itype(ia) ib = itype(ib) else ia = iclass(ia) ib = iclass(ib) end if call prmsort (2,ia,ib,0,0,0) write (iprm,100) ia,ib,record(next:length) 100 format ('hbond',5x,2i5,a) else if (keyword(1:10) .eq. 'REPULSION ') then ia = 0 call getnumb (record,ia,next) ia = iclass(ia) write (iprm,110) ia,record(next:length) 110 format ('repulsion',1x,i5,a) else if (keyword(1:11) .eq. 'DISPERSION ') then ia = 0 call getnumb (record,ia,next) ia = iclass(ia) write (iprm,120) ia,record(next:length) 120 format ('dispersion',i5,a) else if (keyword(1:5) .eq. 'BOND ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = iclass(ia) ib = iclass(ib) call prmsort (2,ia,ib,0,0,0) write (iprm,130) ia,ib,record(next:length) 130 format ('bond',6x,2i5,a) else if (keyword(1:6) .eq. 'BOND5 ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = iclass(ia) ib = iclass(ib) call prmsort (2,ia,ib,0,0,0) write (iprm,140) ia,ib,record(next:length) 140 format ('bond5',5x,2i5,a) else if (keyword(1:6) .eq. 'BOND4 ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = iclass(ia) ib = iclass(ib) call prmsort (2,ia,ib,0,0,0) write (iprm,150) ia,ib,record(next:length) 150 format ('bond4',5x,2i5,a) else if (keyword(1:6) .eq. 'BOND3 ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = iclass(ia) ib = iclass(ib) call prmsort (2,ia,ib,0,0,0) write (iprm,160) ia,ib,record(next:length) 160 format ('bond3',5x,2i5,a) else if (keyword(1:9) .eq. 'ELECTNEG ') then ia = 0 ib = 0 ic = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) write (iprm,170) ia,ib,ic,record(next:length) 170 format ('electneg',2x,3i5,a) else if (keyword(1:6) .eq. 'ANGLE ') then ia = 0 ib = 0 ic = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) call prmsort (3,ia,ib,ic,0,0) write (iprm,180) ia,ib,ic,record(next:length) 180 format ('angle',5x,3i5,a) else if (keyword(1:7) .eq. 'ANGLE5 ') then ia = 0 ib = 0 ic = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) call prmsort (3,ia,ib,ic,0,0) write (iprm,190) ia,ib,ic,record(next:length) 190 format ('angle5',4x,3i5,a) else if (keyword(1:7) .eq. 'ANGLE4 ') then ia = 0 ib = 0 ic = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) call prmsort (3,ia,ib,ic,0,0) write (iprm,200) ia,ib,ic,record(next:length) 200 format ('angle4',4x,3i5,a) else if (keyword(1:7) .eq. 'ANGLE3 ') then ia = 0 ib = 0 ic = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) call prmsort (3,ia,ib,ic,0,0) write (iprm,210) ia,ib,ic,record(next:length) 210 format ('angle3',4x,3i5,a) else if (keyword(1:7) .eq. 'ANGLEP ') then ia = 0 ib = 0 ic = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) call prmsort (3,ia,ib,ic,0,0) write (iprm,220) ia,ib,ic,record(next:length) 220 format ('anglep',4x,3i5,a) else if (keyword(1:7) .eq. 'ANGLEF ') then ia = 0 ib = 0 ic = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) call prmsort (3,ia,ib,ic,0,0) write (iprm,230) ia,ib,ic,record(next:length) 230 format ('anglef',4x,3i5,a) else if (keyword(1:7) .eq. 'STRBND ') then ia = 0 ib = 0 ic = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) write (iprm,240) ia,ib,ic,record(next:length) 240 format ('strbnd',4x,3i5,a) else if (keyword(1:9) .eq. 'UREYBRAD ') then ia = 0 ib = 0 ic = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) call prmsort (3,ia,ib,ic,0,0) write (iprm,250) ia,ib,ic,record(next:length) 250 format ('ureybrad',2x,3i5,a) else if (keyword(1:7) .eq. 'ANGANG ') then ia = 0 call getnumb (record,ia,next) ia = iclass(ia) write (iprm,260) ia,record(next:length) 260 format ('angang',4x,i5,a) else if (keyword(1:7) .eq. 'OPBEND ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) id = iclass(id) call prmsort (2,ic,id,0,0,0) write (iprm,270) ia,ib,ic,id,record(next:length) 270 format ('opbend',4x,4i5,a) else if (keyword(1:7) .eq. 'OPDIST ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) id = iclass(id) call prmsort (2,ib,ic,0,0,0) call prmsort (2,ib,id,0,0,0) call prmsort (2,ic,id,0,0,0) write (iprm,280) ia,ib,ic,id,record(next:length) 280 format ('opdist',4x,4i5,a) else if (keyword(1:9) .eq. 'IMPROPER ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) id = iclass(id) write (iprm,290) ia,ib,ic,id,record(next:length) 290 format ('improper',2x,4i5,a) else if (keyword(1:8) .eq. 'IMPTORS ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) id = iclass(id) write (iprm,300) ia,ib,ic,id,record(next:length) 300 format ('imptors',3x,4i5,a) else if (keyword(1:8) .eq. 'TORSION ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) id = iclass(id) call prmsort (4,ia,ib,ic,id,0) write (iprm,310) ia,ib,ic,id,record(next:length) 310 format ('torsion',3x,4i5,a) else if (keyword(1:9) .eq. 'TORSION5 ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) id = iclass(id) call prmsort (4,ia,ib,ic,id,0) write (iprm,320) ia,ib,ic,id,record(next:length) 320 format ('torsion5',2x,4i5,a) else if (keyword(1:9) .eq. 'TORSION4 ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) id = iclass(id) call prmsort (4,ia,ib,ic,id,0) write (iprm,330) ia,ib,ic,id,record(next:length) 330 format ('torsion4',2x,4i5,a) else if (keyword(1:7) .eq. 'PITORS ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = iclass(ia) ib = iclass(ib) call prmsort (2,ia,ib,0,0,0) write (iprm,340) ia,ib,record(next:length) 340 format ('pitors',4x,2i5,a) else if (keyword(1:8) .eq. 'STRTORS ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) id = iclass(id) write (iprm,350) ia,ib,ic,id,record(next:length) 350 format ('strtors',3x,4i5,a) else if (keyword(1:8) .eq. 'ANGTORS ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) id = iclass(id) write (iprm,360) ia,ib,ic,id,record(next:length) 360 format ('angtors',3x,4i5,a) else if (keyword(1:8) .eq. 'TORTORS ') then ia = 0 ib = 0 ic = 0 id = 0 ie = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) call getnumb (record,ie,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) id = iclass(id) ie = iclass(ie) write (iprm,370) ia,ib,ic,id,ie,record(next:length) 370 format ('tortors',3x,5i5,a) else if (keyword(1:7) .eq. 'CHARGE ') then ia = 0 call getnumb (record,ia,next) ia = itype(ia) write (iprm,380) ia,record(next:length) 380 format ('charge',4x,i5,a) else if (keyword(1:7) .eq. 'DIPOLE ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = itype(ia) ib = itype(ib) write (iprm,390) ia,ib,record(next:length) 390 format ('dipole',4x,2i5,a) else if (keyword(1:8) .eq. 'DIPOLE5 ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = itype(ia) ib = itype(ib) write (iprm,400) ia,ib,record(next:length) 400 format ('dipole5',3x,2i5,a) else if (keyword(1:8) .eq. 'DIPOLE4 ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = itype(ia) ib = itype(ib) write (iprm,410) ia,ib,record(next:length) 410 format ('dipole4',3x,2i5,a) else if (keyword(1:8) .eq. 'DIPOLE3 ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = itype(ia) ib = itype(ib) write (iprm,420) ia,ib,record(next:length) 420 format ('dipole3',3x,2i5,a) else if (keyword(1:10) .eq. 'MULTIPOLE ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = itype(ia) ib = isign(1,ib) * itype(abs(ib)) ic = isign(1,ic) * itype(abs(ic)) id = isign(1,id) * itype(abs(id)) if (id .eq. 0) then write (iprm,430) ia,ib,ic,record(next:length) 430 format ('multipole',1x,3i5,a) else write (iprm,440) ia,ib,ic,id,record(next:length) 440 format ('multipole',1x,4i5,a) end if else if (keyword(1:7) .eq. 'CHGPEN ') then ia = 0 call getnumb (record,ia,next) ia = iclass(ia) write (iprm,450) ia,record(next:length) 450 format ('chgpen',4x,i5,a) else if (keyword(1:9) .eq. 'POLARIZE ') then ia = 0 pol = 0.0d0 thl = -1.0d0 thd = -1.0d0 do j = 1, 20 ig(j) = 0 end do call getnumb (record,ia,next) call gettext (record,text,next) read (text,*,err=460,end=460) pol call gettext (record,text,next) j = 1 call getnumb (text,ig(1),j) if (ig(1) .eq. 0) then read (text,*,err=460,end=460) thl call gettext (record,text,next) j = 1 call getnumb (text,ig(1),j) string = record(next:240) if (ig(1) .eq. 0) then read (text,*,err=460,end=460) thd read (string,*,err=460,end=460) (ig(j),j=1,20) else read (string,*,err=460,end=460) (ig(j),j=2,20) end if else string = record(next:240) read (string,*,err=460,end=460) (ig(j),j=2,20) end if 460 continue ia = itype(ia) kg = 0 do j = 1, 20 if (ig(j) .ne. 0) then kg = j ig(j) = itype(ig(j)) end if end do call sort (kg,ig) if (thd .ge. 0.0d0) then write (iprm,470) ia,pol,thl,thd,(ig(j),j=1,kg) 470 format ('polarize',2x,i5,5x,3f11.4,2x,20i5) else if (thl .ge. 0.0d0) then write (iprm,480) ia,pol,thl,(ig(j),j=1,kg) 480 format ('polarize',2x,i5,5x,2f11.4,2x,20i5) else write (iprm,490) ia,pol,(ig(j),j=1,kg) 490 format ('polarize',2x,i5,5x,f11.4,2x,20i5) end if else if (keyword(1:8) .eq. 'VDWPAIR ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = itype(ia) ib = itype(ib) call prmsort (2,ia,ib,0,0,0) write (iprm,500) ia,ib,record(next:length) 500 format ('polpair',3x,2i5,a) else if (keyword(1:7) .eq. 'CHGTRN ') then ia = 0 call getnumb (record,ia,next) ia = iclass(ia) write (iprm,510) ia,record(next:length) 510 format ('chgtrn',4x,i5,a) else if (keyword(1:9) .eq. 'BNDCFLUX ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = iclass(ia) ib = iclass(ib) call prmsort (2,ia,ib,0,0,0) write (iprm,520) ia,ib,record(next:length) 520 format ('bndcflux',2x,2i5,a) else if (keyword(1:9) .eq. 'ANGCFLUX ') then ia = 0 ib = 0 ic = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) ia = iclass(ia) ib = iclass(ib) ic = iclass(ic) call prmsort (3,ia,ib,ic,0,0) write (iprm,530) ia,ib,ic,record(next:length) 530 format ('angcflux',2x,3i5,a) else if (keyword(1:7) .eq. 'PIATOM ') then ia = 0 call getnumb (record,ia,next) ia = iclass(ia) write (iprm,540) ia,record(next:length) 540 format ('piatom',4x,i5,a) else if (keyword(1:7) .eq. 'PIBOND ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = iclass(ia) ib = iclass(ib) call prmsort (2,ia,ib,0,0,0) write (iprm,550) ia,ib,record(next:length) 550 format ('pibond',4x,2i5,a) else if (keyword(1:8) .eq. 'PIBOND5 ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = iclass(ia) ib = iclass(ib) call prmsort (2,ia,ib,0,0,0) write (iprm,560) ia,ib,record(next:length) 560 format ('pibond5',3x,2i5,a) else if (keyword(1:8) .eq. 'PIBOND4 ') then ia = 0 ib = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) ia = iclass(ia) ib = iclass(ib) call prmsort (2,ia,ib,0,0,0) write (iprm,570) ia,ib,record(next:length) 570 format ('pibond4',3x,2i5,a) else if (keyword(1:6) .eq. 'METAL ') then ia = 0 call getnumb (record,ia,next) ia = iclass(ia) write (iprm,580) ia,record(next:length) 580 format ('metal',5x,i5,a) else if (keyword(1:8) .eq. 'BIOTYPE ') then ia = 0 ib = 0 string = record(next:240) read (string,*,err=590,end=590) ia call getword (record,string,next) call getstring (record,string,next) string = record(next:240) read (string,*,err=590,end=590) ib 590 continue if (ib .gt. 0) ib = itype(ib) length = min(30,max(1,59-next)) write (iprm,600) record(8:next)//blank(1:length),ib 600 format ('biotype',a,i5) else if (length .eq. 0) then write (iprm,610) 610 format () else write (iprm,620) record(1:length) 620 format (a) end if end do return end c c c ############################################################## c ## ## c ## subroutine prmsort -- reorder atom types and classes ## c ## ## c ############################################################## c c c "prmsort" places a list of atom type or class numbers into c canonical order for potential energy parameter definitions c c subroutine prmsort (index,ia,ib,ic,id,ie) implicit none integer ia,ib,ic,id,ie integer index,temp c c c put the atom type or class numbers into canonical order c if (index .eq. 2) then if (ia .gt. ib) then temp = ia ia = ib ib = temp end if else if (index .eq. 3) then if (ia .gt. ic) then temp = ia ia = ic ic = temp end if else if (index .eq. 4) then if (ib.gt.ic .or. (ib.eq.ic.and.ia.gt.id)) then temp = ib ib = ic ic = temp temp = ia ia = id id = temp end if else if (index .eq. 5) then if (ib.gt.id .or. (ib.eq.id.and.ia.gt.ie)) then temp = ib ib = id id = temp temp = ia ia = ie ie = temp end if end if return end c c c ############################################################# c ## ## c ## subroutine polesort -- sort multipoles by atom type ## c ## ## c ############################################################# c c c "polesort" sorts a set of atomic multipole parameters based c on the atom types of centers involved c c subroutine polesort (iprm) use params implicit none integer i,j,n,iprm integer size,next integer ia,ib,ic,id integer, allocatable :: key(:) integer, allocatable :: line(:) real*8 v1,v2,v3 character*4 pa,pb,pc,pd character*16, allocatable :: list(:) character*20 keyword character*240 record character*240 string c c c perform dynamic allocation of some local arrays c allocate (key(nprm)) allocate (line(nprm)) allocate (list(nprm)) c c find and store atom types for the multipole parameters c n = 0 do i = 1, nprm record = prmline(i) next = 1 call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:10) .eq. 'MULTIPOLE ') then ia = 0 ib = 0 ic = 0 id = 0 call getnumb (record,ia,next) call getnumb (record,ib,next) call getnumb (record,ic,next) call getnumb (record,id,next) ia = abs(ia) ib = abs(ib) ic = abs(ic) id = abs(id) size = 4 call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) n = n + 1 line(n) = i list(n) = pa//pb//pc//pd end if end do c c sort the parameters based on the atom type numbers c call sort7 (n,list,key) c c format and output the sorted multipole parameters c do i = 1, n j = line(key(i)) record = prmline(j) next = 1 call gettext (record,keyword,next) ia = 0 ib = 0 ic = 0 id = 0 string = record(next:240) read (string,*,err=20,end=20) ia,ib,ic,id,v1 write (iprm,10) ia,ib,ic,id,v1 10 format ('multipole ',4i5,6x,f11.5) goto 40 20 continue read (string,*,err=90,end=90) ia,ib,ic,v1 write (iprm,30) ia,ib,ic,v1 30 format ('multipole ',3i5,11x,f11.5) 40 continue j = j + 1 record = prmline(j) read (record,*,err=90,end=90) v1,v2,v3 write (iprm,50) v1,v2,v3 50 format (36x,3f11.5) j = j + 1 record = prmline(j) read (record,*,err=90,end=90) v1 write (iprm,60) v1 60 format (36x,f11.5) j = j + 1 record = prmline(j) read (record,*,err=90,end=90) v1,v2 write (iprm,70) v1,v2 70 format (36x,2f11.5) j = j + 1 record = prmline(j) read (record,*,err=90,end=90) v1,v2,v3 write (iprm,80) v1,v2,v3 80 format (36x,3f11.5) 90 continue end do c c perform deallocation of some local arrays c deallocate (key) deallocate (line) deallocate (list) return end c c c ############################################################ c ## ## c ## subroutine biosort -- renumber and format biotypes ## c ## ## c ############################################################ c c c "biosort" renumbers and formats biotype parameters used to c convert biomolecular structure into force field atom types c c subroutine biosort (iprm) use params implicit none integer i,n,iprm integer next integer length integer trimtext integer ia,ib character*3 sym character*20 keyword character*30 blank character*240 record character*240 string c c c find, renumber and format the biotype parameters c blank = ' ' n = 0 do i = 1, nprm record = prmline(i) next = 1 call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:8) .eq. 'BIOTYPE ') then n = n + 1 call getnumb (record,ia,next) call getword (record,sym,next) call getstring (record,string,next) call getnumb (record,ib,next) if (ia .gt. n) n = ia length = trimtext (string) string = '"'//string(1:length)//'"'//blank(1:30-length) write (iprm,10) n,sym,string(1:32),ib 10 format ('biotype',i8,4x,a3,5x,a32,i5) end if 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 prmkey -- interpret force field keywords ## c ## ## c ############################################################# c c c "prmkey" parses a text string to extract keywords related to c force field potential energy functional forms and constants c c subroutine prmkey (text) use angpot use bndpot use chgpot use ctrpot use dsppot use expol use extfld use fields use mplpot use polpot use potent use reppot use rxnpot use torpot use units use urypot use vdwpot implicit none integer i,next character*4 value character*20 keyword character*240 text character*240 record character*240 string c c c parse the line to extract any possible keyword c record = text next = 1 call upcase (record) call gettext (record,keyword,next) string = record(next:240) c c select the individual force field potential terms c if (keyword(1:9) .eq. 'BONDTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_bond = .true. if (value .eq. 'NONE') use_bond = .false. else if (keyword(1:10) .eq. 'ANGLETERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_angle = .true. if (value .eq. 'NONE') use_angle = .false. else if (keyword(1:11) .eq. 'STRBNDTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_strbnd = .true. if (value .eq. 'NONE') use_strbnd = .false. else if (keyword(1:13) .eq. 'UREYBRADTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_urey = .true. if (value .eq. 'NONE') use_urey = .false. else if (keyword(1:11) .eq. 'ANGANGTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_angang = .true. if (value .eq. 'NONE') use_angang = .false. else if (keyword(1:11) .eq. 'OPBENDTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_opbend = .true. if (value .eq. 'NONE') use_opbend = .false. else if (keyword(1:11) .eq. 'OPDISTTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_opdist = .true. if (value .eq. 'NONE') use_opdist = .false. else if (keyword(1:11) .eq. 'IMPROPTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_improp = .true. if (value .eq. 'NONE') use_improp = .false. else if (keyword(1:11) .eq. 'IMPTORTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_imptor = .true. if (value .eq. 'NONE') use_imptor = .false. else if (keyword(1:12) .eq. 'TORSIONTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_tors = .true. if (value .eq. 'NONE') use_tors = .false. else if (keyword(1:11) .eq. 'PITORSTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_pitors = .true. if (value .eq. 'NONE') use_pitors = .false. else if (keyword(1:11) .eq. 'STRTORTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_strtor = .true. if (value .eq. 'NONE') use_strtor = .false. else if (keyword(1:11) .eq. 'ANGTORTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_angtor = .true. if (value .eq. 'NONE') use_angtor = .false. else if (keyword(1:11) .eq. 'TORTORTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_tortor = .true. if (value .eq. 'NONE') use_tortor = .false. else if (keyword(1:8) .eq. 'VDWTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_vdw = .true. if (value .eq. 'NONE') use_vdw = .false. else if (keyword(1:14) .eq. 'REPULSIONTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_repel = .true. if (value .eq. 'NONE') use_repel = .false. else if (keyword(1:15) .eq. 'DISPERSIONTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_disp = .true. if (value .eq. 'NONE') use_disp = .false. else if (keyword(1:11) .eq. 'CHARGETERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_charge = .true. if (value .eq. 'NONE') use_charge = .false. else if (keyword(1:11) .eq. 'CHGDPLTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_chgdpl = .true. if (value .eq. 'NONE') use_chgdpl = .false. else if (keyword(1:11) .eq. 'DIPOLETERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_dipole = .true. if (value .eq. 'NONE') use_dipole = .false. else if (keyword(1:14) .eq. 'MULTIPOLETERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_mpole = .true. if (value .eq. 'NONE') use_mpole = .false. else if (keyword(1:13) .eq. 'POLARIZETERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_polar = .true. if (value .eq. 'NONE') use_polar = .false. else if (keyword(1:11) .eq. 'CHGTRNTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_chgtrn = .true. if (value .eq. 'NONE') use_chgtrn = .false. else if (keyword(1:11) .eq. 'CHGFLXTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_chgflx = .true. if (value .eq. 'NONE') use_chgflx = .false. else if (keyword(1:13) .eq. 'RXNFIELDTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_rxnfld = .true. if (value .eq. 'NONE') use_rxnfld = .false. else if (keyword(1:12) .eq. 'SOLVATETERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_solv = .true. if (value .eq. 'NONE') use_solv = .false. else if (keyword(1:12) .eq. 'METALTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_metal = .true. if (value .eq. 'NONE') use_metal = .false. else if (keyword(1:13) .eq. 'RESTRAINTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_geom = .true. if (value .eq. 'NONE') use_geom = .false. else if (keyword(1:10) .eq. 'EXTRATERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call potoff use_extra = .true. if (value .eq. 'NONE') use_extra = .false. else if (keyword(1:12) .eq. 'VALENCETERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call nbondoff if (value .eq. 'NONE') call valoff else if (keyword(1:12) .eq. 'NONBONDTERM ') then call getword (record,value,next) if (value .eq. 'ONLY') call valoff if (value .eq. 'NONE') call nbondoff end if c c select the name of the force field parameter set c if (keyword(1:11) .eq. 'FORCEFIELD ') then call getword (record,forcefield,next) c c set control parameters for bond stretching potentials c else if (keyword(1:9) .eq. 'BONDTYPE ') then call getword (record,bndtyp,next) else if (keyword(1:9) .eq. 'BONDUNIT ') then read (string,*,err=10,end=10) bndunit else if (keyword(1:11) .eq. 'BOND-CUBIC ') then read (string,*,err=10,end=10) cbnd else if (keyword(1:13) .eq. 'BOND-QUARTIC ') then read (string,*,err=10,end=10) qbnd c c set control parameters for bond angle bending potentials c else if (keyword(1:10) .eq. 'ANGLEUNIT ') then read (string,*,err=10,end=10) angunit else if (keyword(1:12) .eq. 'ANGLE-CUBIC ') then read (string,*,err=10,end=10) cang else if (keyword(1:14) .eq. 'ANGLE-QUARTIC ') then read (string,*,err=10,end=10) qang else if (keyword(1:13) .eq. 'ANGLE-PENTIC ') then read (string,*,err=10,end=10) pang else if (keyword(1:13) .eq. 'ANGLE-SEXTIC ') then read (string,*,err=10,end=10) sang c c set control parameters for stretch-bend potentials c else if (keyword(1:11) .eq. 'STRBNDUNIT ') then read (string,*,err=10,end=10) stbnunit c c set control parameters for Urey-Bradley potentials c else if (keyword(1:9) .eq. 'UREYUNIT ') then read (string,*,err=10,end=10) ureyunit else if (keyword(1:11) .eq. 'UREY-CUBIC ') then read (string,*,err=10,end=10) cury else if (keyword(1:13) .eq. 'UREY-QUARTIC ') then read (string,*,err=10,end=10) qury c c set control parameters for out-of-plane bend potentials c else if (keyword(1:11) .eq. 'OPBENDTYPE ') then call getword (record,opbtyp,next) else if (keyword(1:11) .eq. 'OPBENDUNIT ') then read (string,*,err=10,end=10) opbunit else if (keyword(1:13) .eq. 'OPBEND-CUBIC ') then read (string,*,err=10,end=10) copb else if (keyword(1:15) .eq. 'OPBEND-QUARTIC ') then read (string,*,err=10,end=10) qopb else if (keyword(1:14) .eq. 'OPBEND-PENTIC ') then read (string,*,err=10,end=10) popb else if (keyword(1:14) .eq. 'OPBEND-SEXTIC ') then read (string,*,err=10,end=10) sopb c c set control parameters for out-of-plane distance potentials c else if (keyword(1:11) .eq. 'OPDISTUNIT ') then read (string,*,err=10,end=10) opdunit else if (keyword(1:13) .eq. 'OPDIST-CUBIC ') then read (string,*,err=10,end=10) copd else if (keyword(1:15) .eq. 'OPDIST-QUARTIC ') then read (string,*,err=10,end=10) qopd else if (keyword(1:14) .eq. 'OPDIST-PENTIC ') then read (string,*,err=10,end=10) popd else if (keyword(1:14) .eq. 'OPDIST-SEXTIC ') then read (string,*,err=10,end=10) sopd c c set control parameters for other local geometry potentials c else if (keyword(1:11) .eq. 'ANGANGUNIT ') then read (string,*,err=10,end=10) aaunit else if (keyword(1:11) .eq. 'IMPROPUNIT ') then read (string,*,err=10,end=10) idihunit else if (keyword(1:11) .eq. 'IMPTORUNIT ') then read (string,*,err=10,end=10) itorunit else if (keyword(1:12) .eq. 'TORSIONUNIT ') then read (string,*,err=10,end=10) torsunit else if (keyword(1:11) .eq. 'PITORSUNIT ') then read (string,*,err=10,end=10) ptorunit else if (keyword(1:11) .eq. 'STRTORUNIT ') then read (string,*,err=10,end=10) storunit else if (keyword(1:11) .eq. 'ANGTORUNIT ') then read (string,*,err=10,end=10) atorunit else if (keyword(1:11) .eq. 'TORTORUNIT ') then read (string,*,err=10,end=10) ttorunit c c set control parameters for van der Waals potentials c else if (keyword(1:9) .eq. 'VDWINDEX ') then call getword (record,vdwindex,next) else if (keyword(1:8) .eq. 'VDWTYPE ') then call getword (record,vdwtyp,next) else if (keyword(1:11) .eq. 'RADIUSTYPE ') then call getword (record,radtyp,next) else if (keyword(1:11) .eq. 'RADIUSSIZE ') then call getword (record,radsiz,next) else if (keyword(1:11) .eq. 'RADIUSRULE ') then call getword (record,radrule,next) else if (keyword(1:12) .eq. 'EPSILONRULE ') then call getword (record,epsrule,next) else if (keyword(1:14) .eq. 'GAUSSTYPE ') then call getword (record,gausstyp,next) else if (keyword(1:10) .eq. 'A-EXPTERM ') then read (string,*,err=10,end=10) abuck else if (keyword(1:10) .eq. 'B-EXPTERM ') then read (string,*,err=10,end=10) bbuck else if (keyword(1:10) .eq. 'C-EXPTERM ') then read (string,*,err=10,end=10) cbuck else if (keyword(1:14) .eq. 'GAMMA-HALGREN ') then read (string,*,err=10,end=10) ghal else if (keyword(1:14) .eq. 'DELTA-HALGREN ') then read (string,*,err=10,end=10) dhal else if (keyword(1:13) .eq. 'VDW-12-SCALE ') then read (string,*,err=10,end=10) v2scale if (v2scale .gt. 1.0d0) v2scale = 1.0d0 / v2scale else if (keyword(1:13) .eq. 'VDW-13-SCALE ') then read (string,*,err=10,end=10) v3scale if (v3scale .gt. 1.0d0) v3scale = 1.0d0 / v3scale else if (keyword(1:13) .eq. 'VDW-14-SCALE ') then read (string,*,err=10,end=10) v4scale if (v4scale .gt. 1.0d0) v4scale = 1.0d0 / v4scale else if (keyword(1:13) .eq. 'VDW-15-SCALE ') then read (string,*,err=10,end=10) v5scale if (v5scale .gt. 1.0d0) v5scale = 1.0d0 / v5scale else if (keyword(1:15) .eq. 'VDW-CORRECTION ') then use_vcorr = .true. c c set control parameters for Pauli repulsion potential c else if (keyword(1:13) .eq. 'REP-12-SCALE ') then read (string,*,err=10,end=10) r2scale if (r2scale .gt. 1.0d0) r2scale = 1.0d0 / r2scale else if (keyword(1:13) .eq. 'REP-13-SCALE ') then read (string,*,err=10,end=10) r3scale if (r3scale .gt. 1.0d0) r3scale = 1.0d0 / r3scale else if (keyword(1:13) .eq. 'REP-14-SCALE ') then read (string,*,err=10,end=10) r4scale if (r4scale .gt. 1.0d0) r4scale = 1.0d0 / r4scale else if (keyword(1:13) .eq. 'REP-15-SCALE ') then read (string,*,err=10,end=10) r5scale if (r5scale .gt. 1.0d0) r5scale = 1.0d0 / r5scale c c set control parameters for dispersion potential c else if (keyword(1:14) .eq. 'DISP-12-SCALE ') then read (string,*,err=10,end=10) dsp2scale if (dsp2scale .gt. 1.0d0) dsp2scale = 1.0d0 / dsp2scale else if (keyword(1:14) .eq. 'DISP-13-SCALE ') then read (string,*,err=10,end=10) dsp3scale if (dsp3scale .gt. 1.0d0) dsp3scale = 1.0d0 / dsp3scale else if (keyword(1:14) .eq. 'DISP-14-SCALE ') then read (string,*,err=10,end=10) dsp4scale if (dsp4scale .gt. 1.0d0) dsp4scale = 1.0d0 / dsp4scale else if (keyword(1:14) .eq. 'DISP-15-SCALE ') then read (string,*,err=10,end=10) dsp5scale if (dsp5scale .gt. 1.0d0) dsp5scale = 1.0d0 / dsp5scale else if (keyword(1:16) .eq. 'DISP-CORRECTION ') then use_dcorr = .true. c c set control parameters for charge-charge potentials c else if (keyword(1:9) .eq. 'ELECTRIC ') then read (string,*,err=10,end=10) electric else if (keyword(1:11) .eq. 'DIELECTRIC ') then read (string,*,err=10,end=10) dielec else if (keyword(1:11) .eq. 'CHG-BUFFER ') then read (string,*,err=10,end=10) ebuffer else if (keyword(1:13) .eq. 'CHG-11-SCALE ') then read (string,*,err=10,end=10) c1scale if (c1scale .gt. 1.0d0) c1scale = 1.0d0 / c1scale else if (keyword(1:13) .eq. 'CHG-12-SCALE ') then read (string,*,err=10,end=10) c2scale if (c2scale .gt. 1.0d0) c2scale = 1.0d0 / c2scale else if (keyword(1:13) .eq. 'CHG-13-SCALE ') then read (string,*,err=10,end=10) c3scale if (c3scale .gt. 1.0d0) c3scale = 1.0d0 / c3scale else if (keyword(1:13) .eq. 'CHG-14-SCALE ') then read (string,*,err=10,end=10) c4scale if (c4scale .gt. 1.0d0) c4scale = 1.0d0 / c4scale else if (keyword(1:13) .eq. 'CHG-15-SCALE ') then read (string,*,err=10,end=10) c5scale if (c5scale .gt. 1.0d0) c5scale = 1.0d0 / c5scale else if (keyword(1:16) .eq. 'NEIGHBOR-GROUPS ') then neutnbr = .true. else if (keyword(1:15) .eq. 'NEUTRAL-GROUPS ') then neutcut = .true. else if (keyword(1:15) .eq. 'EXTERNAL-FIELD ') then read (string,*,err=10,end=10) (exfld(i),i=1,3) use_exfld = .true. do i = 1, 3 exfld(i) = exfld(i) / elefield end do c c set control parameters for atomic multipole potentials c else if (keyword(1:12) .eq. 'PENETRATION ') then call getword (record,pentyp,next) else if (keyword(1:15) .eq. 'MPOLE-12-SCALE ') then read (string,*,err=10,end=10) m2scale if (m2scale .gt. 1.0d0) m2scale = 1.0d0 / m2scale else if (keyword(1:15) .eq. 'MPOLE-13-SCALE ') then read (string,*,err=10,end=10) m3scale if (m3scale .gt. 1.0d0) m3scale = 1.0d0 / m3scale else if (keyword(1:15) .eq. 'MPOLE-14-SCALE ') then read (string,*,err=10,end=10) m4scale if (m4scale .gt. 1.0d0) m4scale = 1.0d0 / m4scale else if (keyword(1:15) .eq. 'MPOLE-15-SCALE ') then read (string,*,err=10,end=10) m5scale if (m5scale .gt. 1.0d0) m5scale = 1.0d0 / m5scale c c set control parameters for polarization potentials c else if (keyword(1:13) .eq. 'POLARIZATION ') then call getword (record,poltyp,next) else if (keyword(1:15) .eq. 'EXCHANGE-POLAR ') then call getword (record,scrtyp,next) else if (keyword(1:11) .eq. 'POLAR-ITER ') then read (string,*,err=10,end=10) politer else if (keyword(1:10) .eq. 'POLAR-EPS ') then read (string,*,err=10,end=10) poleps else if (keyword(1:13) .eq. 'USOLVE-ACCEL ') then read (string,*,err=10,end=10) uaccel else if (keyword(1:11) .eq. 'D-EQUALS-P ') then dpequal = .true. else if (keyword(1:15) .eq. 'POLAR-12-SCALE ') then read (string,*,err=10,end=10) p2scale if (p2scale .gt. 1.0d0) p2scale = 1.0d0 / p2scale else if (keyword(1:15) .eq. 'POLAR-13-SCALE ') then read (string,*,err=10,end=10) p3scale if (p3scale .gt. 1.0d0) p3scale = 1.0d0 / p3scale else if (keyword(1:15) .eq. 'POLAR-14-SCALE ') then read (string,*,err=10,end=10) p4scale if (p4scale .gt. 1.0d0) p4scale = 1.0d0 / p4scale else if (keyword(1:15) .eq. 'POLAR-15-SCALE ') then read (string,*,err=10,end=10) p5scale if (p5scale .gt. 1.0d0) p5scale = 1.0d0 / p5scale else if (keyword(1:15) .eq. 'POLAR-12-INTRA ') then read (string,*,err=10,end=10) p2iscale if (p2iscale .gt. 1.0d0) p2iscale = 1.0d0 / p2iscale else if (keyword(1:15) .eq. 'POLAR-13-INTRA ') then read (string,*,err=10,end=10) p3iscale if (p3iscale .gt. 1.0d0) p3iscale = 1.0d0 / p3iscale else if (keyword(1:15) .eq. 'POLAR-14-INTRA ') then read (string,*,err=10,end=10) p4iscale if (p4iscale .gt. 1.0d0) p4iscale = 1.0d0 / p4iscale else if (keyword(1:15) .eq. 'POLAR-15-INTRA ') then read (string,*,err=10,end=10) p5iscale if (p5iscale .gt. 1.0d0) p5iscale = 1.0d0 / p5iscale else if (keyword(1:16) .eq. 'DIRECT-11-SCALE ') then read (string,*,err=10,end=10) d1scale if (d1scale .gt. 1.0d0) d1scale = 1.0d0 / d1scale else if (keyword(1:16) .eq. 'DIRECT-12-SCALE ') then read (string,*,err=10,end=10) d2scale if (d2scale .gt. 1.0d0) d2scale = 1.0d0 / d2scale else if (keyword(1:16) .eq. 'DIRECT-13-SCALE ') then read (string,*,err=10,end=10) d3scale if (d3scale .gt. 1.0d0) d3scale = 1.0d0 / d3scale else if (keyword(1:16) .eq. 'DIRECT-14-SCALE ') then read (string,*,err=10,end=10) d4scale if (d4scale .gt. 1.0d0) d4scale = 1.0d0 / d4scale else if (keyword(1:16) .eq. 'MUTUAL-11-SCALE ') then read (string,*,err=10,end=10) u1scale if (u1scale .gt. 1.0d0) u1scale = 1.0d0 / u1scale else if (keyword(1:16) .eq. 'MUTUAL-12-SCALE ') then read (string,*,err=10,end=10) u2scale if (u2scale .gt. 1.0d0) u2scale = 1.0d0 / u2scale else if (keyword(1:16) .eq. 'MUTUAL-13-SCALE ') then read (string,*,err=10,end=10) u3scale if (u3scale .gt. 1.0d0) u3scale = 1.0d0 / u3scale else if (keyword(1:16) .eq. 'MUTUAL-14-SCALE ') then read (string,*,err=10,end=10) u4scale if (u4scale .gt. 1.0d0) u4scale = 1.0d0 / u4scale else if (keyword(1:16) .eq. 'INDUCE-12-SCALE ') then read (string,*,err=10,end=10) w2scale if (w2scale .gt. 1.0d0) w2scale = 1.0d0 / w2scale else if (keyword(1:16) .eq. 'INDUCE-13-SCALE ') then read (string,*,err=10,end=10) w3scale if (w3scale .gt. 1.0d0) w3scale = 1.0d0 / w3scale else if (keyword(1:16) .eq. 'INDUCE-14-SCALE ') then read (string,*,err=10,end=10) w4scale if (w4scale .gt. 1.0d0) w4scale = 1.0d0 / w4scale else if (keyword(1:16) .eq. 'INDUCE-15-SCALE ') then read (string,*,err=10,end=10) w5scale if (w5scale .gt. 1.0d0) w5scale = 1.0d0 / w5scale c c set control parameters for charge transfer potentials c else if (keyword(1:15) .eq. 'CHARGETRANSFER ') then call getword (record,ctrntyp,next) c c set control parameters for reaction field potentials c else if (keyword(1:14) .eq. 'REACTIONFIELD ') then read (string,*,err=10,end=10) rfsize,rfbulkd,rfterms end if c c jump directly to the end if any error was detected c 10 continue return end c c c ############################################################### c ## ## c ## subroutine potoff -- turn off all potential functions ## c ## ## c ############################################################### c c c "potoff" clears the forcefield definition by turning off c the use of each of the potential energy functions c c subroutine potoff use potent implicit none c c c turn off the use of each of the potential energy functions c use_bond = .false. use_angle = .false. use_strbnd = .false. use_urey = .false. use_angang = .false. use_opbend = .false. use_opdist = .false. use_improp = .false. use_imptor = .false. use_tors = .false. use_pitors = .false. use_strtor = .false. use_angtor = .false. use_tortor = .false. use_vdw = .false. use_repel = .false. use_disp = .false. use_charge = .false. use_chgdpl = .false. use_dipole = .false. use_mpole = .false. use_polar = .false. use_chgtrn = .false. use_rxnfld = .false. use_solv = .false. use_metal = .false. use_geom = .false. use_extra = .false. return end c c c ############################################################### c ## ## c ## subroutine valoff -- turn off valence potential terms ## c ## ## c ############################################################### c c c "valoff" turns off the use of each of the valence c potential energy functions c c subroutine valoff use potent implicit none c c c turn off the use of each of the valence energy functions c use_bond = .false. use_angle = .false. use_strbnd = .false. use_urey = .false. use_angang = .false. use_opbend = .false. use_opdist = .false. use_improp = .false. use_imptor = .false. use_tors = .false. use_pitors = .false. use_strtor = .false. use_angtor = .false. use_tortor = .false. use_geom = .false. return end c c c ################################################################# c ## ## c ## subroutine nbondoff -- turn off nonbond potential terms ## c ## ## c ################################################################# c c c "nbondoff" turns off the use of each of the nonbonded c potential energy functions c c subroutine nbondoff use potent implicit none c c c turn off the use of each of the nonbonded energy functions c use_vdw = .false. use_repel = .false. use_disp = .false. use_charge = .false. use_chgdpl = .false. use_dipole = .false. use_mpole = .false. use_polar = .false. use_chgtrn = .false. use_rxnfld = .false. use_solv = .false. use_metal = .false. return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine promo -- version info and copywrite notice ## c ## ## c ############################################################### c c c "promo" writes a banner message containing information c about the Tinker version, release date and copyright notice c c subroutine promo use iounit implicit none c c c print out the informational header message c write (iout,10) 10 format (/,5x,70('#'), & /,3x,74('#'), & /,2x,'###',70x,'###', & /,1x,'###',12x,'Tinker --- Software Tools for', & ' Molecular Design',12x,'###', & /,1x,'##',74x,'##', & /,1x,'##',24x,'Version 8.11.3 June 2024',24x,'##', & /,1x,'##',74x,'##', & /,1x,'##',15x,'Copyright (c) Jay William Ponder', & ' 1990-2024',15x,'##', & /,1x,'###',27x,'All Rights Reserved',26x,'###', & /,2x,'###',70x,'###', & /,3x,74('#'), & /,5x,70('#'),/) flush (iout) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## program protein -- build a polypeptide from sequence ## c ## ## c ############################################################## c c c "protein" builds the internal and Cartesian coordinates c of a polypeptide from amino acid sequence and torsional c angle values for the peptide backbone and side chains c c program protein use atoms use files use iounit use sequen use titles implicit none integer i,izmt integer ixyz,iseq integer natom,mode integer freeunit,trimtext logical exist,clash character*240 seqfile character*240 intfile character*240 xyzfile c c c get the name to use for the output structure files c call initial call nextarg (filename,exist) if (.not. exist) then write (iout,10) 10 format (/,' Enter Name to be Used for Output Files : ',$) read (input,20) filename 20 format (a240) end if call basefile (filename) c c get the title line for the output files c write (iout,30) 30 format (/,' Enter Title : ',$) read (input,40) title 40 format (a240) ltitle = trimtext (title) c c read the keyfile and force field parameter file c call getkey call field c c get the sequence and build Z-matrix for the structure c call getseq call prochain c c find connectivities and generate Cartesian coordinates c call connect call attach call molecule call makexyz c c perform a packing calculation for multiple chains c if (nchain .gt. 1) then call pauling call inertia (2) end if c c remove dummy atoms and set undefined atoms to type zero c natom = n do i = natom, 1, -1 if (type(i) .eq. 0) call delete (i) if (type(i) .lt. 0) type(i) = 0 end do c c convert to internal and Cartesian coordinates c mode = 0 call makeint (mode) call makexyz c c check for atom pairs with identical coordinates c clash = .false. call chkxyz (clash) c c write out a amino acid sequence file c iseq = freeunit () seqfile = filename(1:leng)//'.seq' call version (seqfile,'new') open (unit=iseq,file=seqfile,status='new') call prtseq (iseq) close (unit=iseq) c c write out an internal coordinates file c izmt = freeunit () intfile = filename(1:leng)//'.int' call version (intfile,'new') open (unit=izmt,file=intfile,status='new') call prtint (izmt) close (unit=izmt) c c write out a Cartesian coordinates file c ixyz = freeunit () xyzfile = filename(1:leng)//'.xyz' call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') 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 getseq -- amino acid sequence and angles ## c ## ## c ############################################################# c c c "getseq" asks the user for the amino acid sequence c and torsional angle values needed to define a peptide c c subroutine getseq use iounit use phipsi use resdue use sequen implicit none integer i,j,next integer length,trimtext logical done character*1 chir character*1 ucase(26) character*3 name character*240 record character*240 string data ucase / 'A','B','C','D','E','F','G','H','I','J','K','L', & 'M','N','O','P','Q','R','S','T','U','V','W','X', & 'Y','Z' / c c c provide a header to explain the method of sequence input c write (iout,10) 10 format (/,' Enter One Residue Name per Line as the Standard', & ' Three-Letter Code, and', & /,' optionally, Phi-Psi-Omega Angles (3F), Chi Angles' & ' (4F), Disulfide Partner', & /,' if CYX Residue (I), and D/L Chirality (A1)', & //,' If Only Residue Names are Entered, the Default', & ' is to Build an Extended', & /,' Conformation Using L-Amino Acids and Zwitterionic', & ' Termini', & //,' Standard Amino Acids: GLY, ALA, VAL, LEU, ILE,', & ' SER, THR, CYS, CYX, PRO,', & /,' PHE, TYR, TRP, HIS, ASP, ASN, GLU, GLN, MET, LYS,', & ' ARG, ORN, AIB', & //,' Alternative Protonation States: CYD, TYD, HID,', & ' HIE, HIP, ASH, GLH, LYD', & //,' N-Terminal Cap Residues: H2N=Deprotonated,', & ' FOR=Formyl, ACE=Acetyl,', & /,27x,'PCA=Pyroglutamic Acid', & /,' C-Terminal Cap Residues: COH=Protonated, NH2=Amide,', & ' NME=N-MethylAmide', & //,' Use Residue Name=MOL to Start a New Chain, and', & ' Use to End Input') c c initially, assume that only a single strand is present c nchain = 1 ichain(1,1) = 1 chnnam(1) = ' ' c c get the amino acid sequence data and dihedral angle values c i = 0 done = .false. do while (.not. done) i = i + 1 phi(i) = 0.0d0 psi(i) = 0.0d0 omg(i) = 0.0d0 do j = 1, 4 chi(j,i) = 0.0d0 end do chiral(i) = 1 disulf(i) = 0 chir = ' ' write (iout,20) i 20 format (/,' Enter Residue',i4,' : ',$) read (input,30) record 30 format (a240) call upcase (record) next = 1 call gettext (record,name,next) length = trimtext (name) string = record(next:240) read (string,*,err=40,end=40) phi(i),psi(i),omg(i), & (chi(j,i),j=1,4),disulf(i) 40 continue call getword (record,chir,next) c c handle special names used for certain amino acids c if (name .eq. 'CYH') name = 'CYS' if (name .eq. 'CSS') name = 'CYX' if (name .eq. 'HIP') name = 'HIS' c c disulfide bridged residues are cystine instead of cysteine c if (name(1:1).eq.'C' .and. disulf(i).ne.0) then length = 3 name = 'CYX' end if c c check the D/L chirality of the current residue c if (chir .eq. 'D') chiral(i) = -1 c c process and store the current amino acid residue type c if (name .eq. 'MOL') then i = i - 1 ichain(2,nchain) = i nchain = nchain + 1 ichain(1,nchain) = i + 1 else if (name .eq. ' ') then done = .true. nseq = i - 1 ichain(2,nchain) = nseq else seq(i) = amino(maxamino) seqtyp(i) = 0 if (length .eq. 1) then do j = 1, maxamino if (name(1:1) .eq. amino1(j)) then seq(i) = amino(j) seqtyp(i) = j end if end do else if (length .eq. 3) then do j = 1, maxamino if (name .eq. amino(j)) then seq(i) = amino(j) seqtyp(i) = j end if end do end if if (seqtyp(i) .eq. 0) then i = i - 1 write (iout,50) name 50 format (/,' GETSEQ -- Amino Acid Type ',a3, & ' is Not Supported') end if end if end if end do c c set chain identifiers if multiple chains are present c if (nchain .gt. 1) then do i = 1, nchain chnnam(i) = ucase(i) end do end if c c set default values for the phi-psi-omega-chi angles; c use extended values if no phi-psi values were given c do i = 1, nseq if (phi(i).eq.0.0d0 .and. psi(i).eq.0.0d0) then phi(i) = -135.0d0 if (seq(i) .eq. 'PRO') phi(i) = -60.0d0 psi(i) = 135.0d0 end if if (omg(i) .eq. 0.0d0) then omg(i) = 180.0d0 end if if (chi(1,i) .eq. 0.0d0) then do j = 1, 4 chi(j,i) = 180.0d0 if (seq(i) .eq. 'PRO') chi(j,i) = 0.0d0 if (seq(i) .eq. 'PCA') chi(j,i) = 0.0d0 end do if (seq(i) .eq. 'PHE') chi(2,i) = 90.0d0 if (seq(i) .eq. 'TYR') chi(2,i) = 90.0d0 if (seq(i) .eq. 'TYD') chi(2,i) = 90.0d0 if (seq(i) .eq. 'TRP') chi(2,i) = 90.0d0 if (seq(i) .eq. 'HIS') chi(2,i) = 90.0d0 if (seq(i) .eq. 'HID') chi(2,i) = 90.0d0 if (seq(i) .eq. 'HIE') chi(2,i) = 90.0d0 end if c c check for the presence of any disulfide bonds c if (disulf(i) .ne. 0) then if (seq(i) .ne. 'CYX') then write (iout,60) i 60 format (' GETSEQ -- Error in Disulfide Bond', & ' at Residue',i5) end if if (i.lt.disulf(i) .and. disulf(disulf(i)).ne.i) then write (iout,70) i,disulf(i) 70 format (' GETSEQ -- Error in Disulfide Bond', & ' at Residue',i5,' or',i5) end if end if end do return end c c c ########################################################### c ## ## c ## subroutine prochain -- build polypeptide backbone ## c ## ## c ########################################################### c c c "prochain" builds up the internal coordinates for an amino c acid sequence from the phi, psi, omega and chi values c c subroutine prochain use atoms use iounit use phipsi use resdue use sequen implicit none integer i,k,m integer next,nsave integer, allocatable :: ni(:) integer, allocatable :: cai(:) integer, allocatable :: ci(:) logical single,cyclic character*1 answer character*3 resname character*240 record c c c determine whether the peptide chain is cyclic c cyclic = .false. write (iout,10) 10 format (/,' Cyclize the Polypeptide Chain [N] : ',$) read (input,20) record 20 format (a240) next = 1 call gettext (record,answer,next) call upcase (answer) if (answer .eq. 'Y') cyclic = .true. c c perform dynamic allocation of some local arrays c allocate (ni(nseq)) allocate (cai(nseq)) allocate (ci(nseq)) c c initialize the atom counter to the first atom c n = 1 c c set the first residue number and get the type and name c do m = 1, nchain single = .false. if (ichain(1,m) .eq. ichain(2,m)) single = .true. i = ichain(1,m) k = seqtyp(i) resname = amino(k) c c build the first residue for a cyclic peptide c if (cyclic) then if (m .eq. 1) then ni(i) = n call zatom (ntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0) cai(i) = n call zatom (catyp(k),1.46d0,0.0d0,0.0d0,ni(i),0,0,0) ci(i) = n call zatom (ctyp(k),1.51d0,110.7d0,0.0d0, & cai(i),ni(i),0,0) else ni(i) = n call zatom (ntyp(k),30.0d0,150.0d0,180.0d0,n-1,n-2,n-3,0) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) cai(i) = n call zatom (catyp(k),1.46d0,150.0d0,180.0d0, & ni(i),n-2,n-3,0) ci(i) = n call zatom (ctyp(k),1.51d0,110.7d0,180.0d0, & cai(i),ni(i),n-3,0) end if call zatom (otyp(k),1.22d0,122.5d0,psi(i)-180.0d0, & ci(i),cai(i),ni(i),0) call zatom (hntyp(k),1.02d0,121.0d0,phi(i)-180.0d0, & ni(i),cai(i),ci(i),0) call zatom (hatyp(k),1.11d0,109.5d0,107.9d0, & cai(i),ni(i),ci(i),-chiral(i)) call proside (resname,i,cai(i),ni(i),ci(i)) c c build the first residue as an N-terminal formyl group c else if (resname .eq. 'FOR') then if (m .eq. 1) then ci(i) = n call zatom (cntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0) ni(i) = n call zatom (ontyp(k),1.22d0,0.0d0,0.0d0,n-1,0,0,0) cai(i) = n call zatom (hantyp(k),1.12d0,120.0d0,0.0d0,n-2,n-1,0,0) else ci(i) = n call zatom (cntyp(k),30.0d0,150.0d0,180.0d0, & n-1,n-2,n-3,0) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) ni(i) = n call zatom (ontyp(k),1.22d0,150.0d0,180.0d0, & n-1,n-2,n-3,0) cai(i) = n call zatom (hantyp(k),1.12d0,120.0d0,0.0d0,n-2,n-1,n-3,0) end if psi(i) = 180.0d0 c c build the first residue as an N-terminal acetyl group c else if (resname .eq. 'ACE') then if (m .eq. 1) then cai(i) = n call zatom (cantyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0) ci(i) = n call zatom (cntyp(k),1.51d0,0.0d0,0.0d0,n-1,0,0,0) call zatom (ontyp(k),1.22d0,122.5d0,0.0d0,n-1,n-2,0,0) else cai(i) = n call zatom (cantyp(k),30.0d0,150.0d0,180.0d0, & n-1,n-2,n-3,0) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) ci(i) = n call zatom (cntyp(k),1.51d0,150.0d0,180.0d0, & n-1,n-2,n-3,0) call zatom (ontyp(k),1.22d0,122.5d0,0.0d0, & n-1,n-2,n-3,0) end if ni(i) = n call zatom (hantyp(k),1.11d0,107.9d0,0.0d0,n-3,n-2,n-1,0) call zatom (hantyp(k),1.11d0,107.9d0,109.4d0,n-4,n-3,n-1,1) call zatom (hantyp(k),1.11d0,107.9d0,109.4d0,n-5,n-4,n-2,-1) psi(i) = 180.0d0 c c build the first residue as a proline c else if (resname .eq. 'PRO') then if (m .eq. 1) then ni(i) = n call zatom (nntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0) cai(i) = n call zatom (cantyp(k),1.50d0,0.0d0,0.0d0,ni(i),0,0,0) ci(i) = n if (single) then call zatom (cctyp(k),1.51d0,111.6d0,0.0d0, & cai(i),ni(i),0,0) else call zatom (cntyp(k),1.51d0,110.7d0,0.0d0, & cai(i),ni(i),0,0) end if else ni(i) = n call zatom (nntyp(k),30.0d0,150.0d0,180.0d0, & n-1,n-2,n-3,0) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) cai(i) = n call zatom (cantyp(k),1.50d0,150.0d0,180.0d0, & ni(i),n-2,n-3,0) ci(i) = n if (single) then call zatom (cctyp(k),1.51d0,111.6d0,180.0d0, & cai(i),ni(i),n-3,0) else call zatom (cntyp(k),1.51d0,110.7d0,180.0d0, & cai(i),ni(i),n-3,0) end if end if if (single) then call zatom (octyp(k),1.25d0,117.0d0,psi(1)-180.0d0, & ci(i),cai(i),ni(i),0) else call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0, & ci(i),cai(i),ni(i),0) end if call zatom (hnntyp(k),1.02d0,109.5d0,0.0d0, & ni(i),cai(i),ci(i),0) call zatom (hnntyp(k),1.02d0,109.5d0,-120.0d0, & ni(i),cai(i),ci(i),0) call zatom (hantyp(k),1.11d0,109.5d0,107.9d0, & cai(i),ni(i),ci(i),-chiral(i)) call proside (resname,i,cai(i),ni(i),ci(i)) c c build the first residue as a pyroglutamic acid c else if (resname .eq. 'PCA') then if (m .eq. 1) then ni(i) = n call zatom (nntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0) cai(i) = n call zatom (cantyp(k),1.50d0,0.0d0,0.0d0,ni(i),0,0,0) ci(i) = n if (single) then call zatom (cctyp(k),1.51d0,111.6d0,0.0d0, & cai(i),ni(i),0,0) else call zatom (cntyp(k),1.51d0,110.7d0,0.0d0, & cai(i),ni(i),0,0) end if else ni(i) = n call zatom (nntyp(k),30.0d0,150.0d0,180.0d0, & n-1,n-2,n-3,0) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) cai(i) = n call zatom (cantyp(k),1.50d0,150.0d0,180.0d0, & ni(i),n-2,n-3,0) ci(i) = n if (single) then call zatom (cctyp(k),1.51d0,111.6d0,180.0d0, & cai(i),ni(i),n-3,0) else call zatom (cntyp(k),1.51d0,110.7d0,180.0d0, & cai(i),ni(i),n-3,0) end if end if if (single) then call zatom (octyp(k),1.25d0,117.0d0,psi(1)-180.0d0, & ci(i),cai(i),ni(i),0) else call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0, & ci(i),cai(i),ni(i),0) end if call zatom (hnntyp(k),1.02d0,109.5d0,-60.0d0, & ni(i),cai(i),ci(i),0) call zatom (hantyp(k),1.11d0,109.5d0,107.9d0, & cai(i),ni(i),ci(i),-chiral(i)) call proside (resname,i,cai(i),ni(i),ci(i)) c c build the first residue for N-terminal deprotonated amino acids c else if (resname .eq. 'H2N') then i = i + 1 k = seqtyp(i) resname = amino(k) if (m .eq. 1) then ni(i) = n k = seqtyp(i-1) call zatom (nntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0) k = seqtyp(i) cai(i) = n call zatom (cantyp(k),1.50d0,0.0d0,0.0d0,ni(i),0,0,0) ci(i) = n if (single) then call zatom (cctyp(k),1.51d0,111.6d0,0.0d0, & cai(i),ni(i),0,0) else call zatom (cntyp(k),1.51d0,110.7d0,0.0d0, & cai(i),ni(i),0,0) end if else ni(i) = n k = seqtyp(i-1) call zatom (nntyp(k),30.0d0,150.0d0,180.0d0, & n-1,n-2,n-3,0) k = seqtyp(i) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) cai(i) = n call zatom (cantyp(k),1.50d0,150.0d0,180.0d0, & ni(i),n-2,n-3,0) ci(i) = n if (single) then call zatom (cctyp(k),1.51d0,111.6d0,180.0d0, & cai(i),ni(i),n-3,0) else call zatom (cntyp(k),1.51d0,110.7d0,180.0d0, & cai(i),ni(i),n-3,0) end if end if if (single) then call zatom (octyp(k),1.25d0,117.0d0,psi(1)-180.0d0, & ci(i),cai(i),ni(i),0) else call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0, & ci(i),cai(i),ni(i),0) end if k = seqtyp(i-1) if (resname .eq. 'PRO') then call zatom (hnntyp(k),1.02d0,124.5d0,phi(i), & ni(i),cai(i),ci(i),0) else call zatom (hnntyp(k),1.02d0,109.5d0,phi(i), & ni(i),cai(i),ci(i),0) call zatom (hnntyp(k),1.02d0,109.5d0,108.0d0, & ni(i),cai(i),n-1,1) end if k = seqtyp(i) call zatom (hantyp(k),1.11d0,109.5d0,107.9d0, & cai(i),ni(i),ci(i),-chiral(i)) call proside (resname,i,cai(i),ni(i),ci(i)) c c build the first residue for all other standard amino acids c else if (m .eq. 1) then ni(i) = n call zatom (nntyp(k),0.0d0,0.0d0,0.0d0,0,0,0,0) cai(i) = n call zatom (cantyp(k),1.50d0,0.0d0,0.0d0,ni(i),0,0,0) ci(i) = n if (single) then call zatom (cctyp(k),1.51d0,111.6d0,0.0d0, & cai(i),ni(i),0,0) else call zatom (cntyp(k),1.51d0,110.7d0,0.0d0, & cai(i),ni(i),0,0) end if else ni(i) = n call zatom (nntyp(k),30.0d0,150.0d0,180.0d0, & n-1,n-2,n-3,0) call zatom (-2,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) cai(i) = n call zatom (cantyp(k),1.50d0,150.0d0,180.0d0, & ni(i),n-2,n-3,0) ci(i) = n if (single) then call zatom (cctyp(k),1.51d0,111.6d0,180.0d0, & cai(i),ni(i),n-3,0) else call zatom (cntyp(k),1.51d0,110.7d0,180.0d0, & cai(i),ni(i),n-3,0) end if end if if (single) then call zatom (octyp(k),1.25d0,117.0d0,psi(1)-180.0d0, & ci(i),cai(i),ni(i),0) else call zatom (ontyp(k),1.22d0,122.5d0,psi(1)-180.0d0, & ci(i),cai(i),ni(i),0) end if call zatom (hnntyp(k),1.02d0,109.5d0,phi(i), & ni(i),cai(i),ci(i),0) call zatom (hnntyp(k),1.02d0,109.5d0,108.0d0, & ni(i),cai(i),n-1,1) call zatom (hnntyp(k),1.02d0,109.5d0,108.0d0, & ni(i),cai(i),n-2,-1) call zatom (hantyp(k),1.11d0,109.5d0,107.9d0, & cai(i),ni(i),ci(i),-chiral(i)) call proside (resname,i,cai(i),ni(i),ci(i)) end if c c build atoms for residues in the middle of the chain c do while (i .lt. ichain(2,m)-1) i = i + 1 k = seqtyp(i) resname = amino(k) ni(i) = n call zatom (ntyp(k),1.34d0,112.7d0,psi(i-1), & ci(i-1),cai(i-1),ni(i-1),0) cai(i) = n call zatom (catyp(k),1.46d0,121.0d0,omg(i-1), & ni(i),ci(i-1),cai(i-1),0) ci(i) = n call zatom (ctyp(k),1.51d0,111.6d0,phi(i), & cai(i),ni(i),ci(i-1),0) call zatom (otyp(k),1.22d0,122.5d0,psi(i)-180.0d0, & ci(i),cai(i),ni(i),0) call zatom (hntyp(k),1.02d0,121.0d0,phi(i)-180.0d0, & ni(i),cai(i),ci(i),0) call zatom (hatyp(k),1.11d0,109.5d0,107.9d0, & cai(i),ni(i),ci(i),-chiral(i)) call proside (resname,i,cai(i),ni(i),ci(i)) end do c c set the number and type of the last residue c i = ichain(2,m) k = seqtyp(i) resname = amino(k) c c build the last residue for a cyclic peptide c if (cyclic) then ni(i) = n call zatom (ntyp(k),1.34d0,112.7d0,psi(i-1), & ci(i-1),cai(i-1),ni(i-1),0) cai(i) = n call zatom (catyp(k),1.46d0,121.0d0,omg(i-1), & ni(i),ci(i-1),cai(i-1),0) ci(i) = n call zatom (ctyp(k),1.51d0,111.6d0,phi(i), & cai(i),ni(i),ci(i-1),0) call zatom (-1,0.0d0,0.0d0,0.0d0,ni(1),ci(i),0,0) call zatom (otyp(k),1.22d0,122.5d0,psi(i)-180.0d0, & ci(i),cai(i),ni(i),0) call zatom (hntyp(k),1.02d0,121.0d0,phi(i)-180.0d0, & ni(i),cai(i),ci(i),0) call zatom (hatyp(k),1.11d0,109.5d0,107.9d0, & cai(i),ni(i),ci(i),-chiral(i)) call proside (resname,i,cai(i),ni(i),ci(i)) c c build the last residue as a C-terminal amide c else if (resname .eq. 'NH2') then call zatom (nctyp(k),1.34d0,112.7d0,psi(i-1), & ci(i-1),cai(i-1),ni(i-1),0) call zatom (hnctyp(k),1.02d0,119.0d0,0.0d0, & n-1,ci(i-1),cai(i-1),0) call zatom (hnctyp(k),1.02d0,119.0d0,180.0d0, & n-2,ci(i-1),cai(i-1),0) c c build the last residue as a C-terminal N-methylamide c else if (resname .eq. 'NME') then call zatom (nctyp(k),1.34d0,112.7d0,psi(i-1), & ci(i-1),cai(i-1),ni(i-1),0) call zatom (cactyp(k),1.46d0,121.0d0,180.0d0, & n-1,ci(i-1),cai(i-1),0) call zatom (hnctyp(k),1.02d0,118.0d0,121.0d0, & n-2,ci(i-1),n-1,1) call zatom (hactyp(k),1.11d0,109.5d0,180.0d0, & n-2,n-3,ci(i-1),0) call zatom (hactyp(k),1.11d0,109.5d0,109.5d0, & n-3,n-4,n-1,1) call zatom (hactyp(k),1.11d0,109.5d0,109.5d0, & n-4,n-5,n-2,-1) c c build the last residue as a protonated C-terminal amino acid c else if (resname .eq. 'COH') then nsave = n n = ci(i-1) call zatom (cctyp(k),1.51d0,111.6d0,phi(i), & cai(i-1),ni(i-1),ci(i-2),0) call zatom (octyp(k),1.22d0,122.5d0,psi(i)-180.0d0, & ci(i-1),cai(i-1),ni(i-1),0) n = nsave call zatom (nctyp(k),1.35d0,112.7d0,psi(i-1), & ci(i-1),cai(i-1),ni(i-1),0) call zatom (hnctyp(k),0.98d0,108.7d0,180.0d0, & n-1,ci(i-1),cai(i-1),0) c c build the last residue for all other standard amino acids c else if (.not. single) then ni(i) = n call zatom (nctyp(k),1.34d0,112.7d0,psi(i-1), & ci(i-1),cai(i-1),ni(i-1),0) cai(i) = n call zatom (cactyp(k),1.46d0,121.0d0,omg(i-1), & ni(i),ci(i-1),cai(i-1),0) ci(i) = n call zatom (cctyp(k),1.51d0,111.6d0,phi(i), & cai(i),ni(i),ci(i-1),0) call zatom (octyp(k),1.25d0,117.0d0,psi(i)-180.0d0, & ci(i),cai(i),ni(i),0) call zatom (hnctyp(k),1.02d0,121.0d0,phi(i)-180.0d0, & ni(i),cai(i),ci(i),0) call zatom (hactyp(k),1.11d0,109.5d0,107.9d0, & cai(i),ni(i),ci(i),-chiral(i)) call proside (resname,i,cai(i),ni(i),ci(i)) end if call zatom (octyp(k),1.25d0,117.0d0,psi(i), & ci(i),cai(i),ni(i),0) end if end do c c finally, set the total number of atoms c n = n - 1 c c perform deallocation of some local arrays c deallocate (ni) deallocate (cai) deallocate (ci) return end c c c ########################################################### c ## ## c ## subroutine proside -- build amino acid side chain ## c ## ## c ########################################################### c c c "proside" builds the side chain for a single amino acid c residue in terms of internal coordinates c c resname 3-letter name of current amino acid residue c i number of the current amino acid residue c cai atom number of alpha carbon in residue i c ni atom number of amide nitrogen in residue i c ci atom number of carbonyl carbon in residue i c c note biotypes of CD and HD atoms for N-terminal proline c are set as absolute values, not relative to the CB atom c c subroutine proside (resname,i,cai,ni,ci) use atoms use phipsi use resdue use sequen implicit none integer i,k integer cai,ni,ci integer ntprocd integer ntprohd character*3 resname c c c set the CB atom as reference site c k = cbtyp(seqtyp(i)) c c set biotypes for CD and HD of N-terminal PRO residue c ntprocd = 469 ntprohd = 470 c c glycine residue (GLY) c if (resname .eq. 'GLY') then k = hatyp(seqtyp(i)) if (i .eq. 1) k = hantyp(seqtyp(i)) if (i .eq. nseq) k = hactyp(seqtyp(i)) call zatom (k,1.11d0,109.5d0,107.9d0,cai,ni,ci,chiral(i)) c c alanine residue (ALA) c else if (resname .eq. 'ALA') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+1,1.11d0,109.4d0,chi(1,i),n-1,cai,ni,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-2,cai,n-1,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-3,cai,n-2,-1) c c valine residue (VAL) c else if (resname .eq. 'VAL') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.54d0,109.5d0,109.5d0,n-2,cai,n-1,-1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-3,cai,n-2,1) call zatom (k+3,1.11d0,109.4d0,180.0d0,n-3,n-4,cai,0) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-4,n-5,n-1,1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-2,-1) call zatom (k+5,1.11d0,109.4d0,180.0d0,n-5,n-7,cai,0) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-6,n-8,n-1,1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-7,n-9,n-2,-1) c c leucine residue (LEU) c else if (resname .eq. 'LEU') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+6,1.54d0,109.5d0,109.4d0,n-2,n-3,n-1,-1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,1) call zatom (k+5,1.11d0,109.4d0,180.0d0,n-5,n-6,n-7,0) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-6,n-7,n-1,1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-7,n-8,n-2,-1) call zatom (k+7,1.11d0,109.4d0,180.0d0,n-7,n-9,n-10,0) call zatom (k+7,1.11d0,109.4d0,109.4d0,n-8,n-10,n-1,1) call zatom (k+7,1.11d0,109.4d0,109.4d0,n-9,n-11,n-2,-1) c c isoleucine residue (ILE) c else if (resname .eq. 'ILE') then call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.54d0,109.5d0,109.5d0,n-2,cai,n-1,1) call zatom (k+6,1.54d0,109.5d0,chi(2,i),n-2,n-3,cai,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,-1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-4,n-5,n-2,1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-3,-1) call zatom (k+5,1.11d0,110.0d0,180.0d0,n-5,n-7,n-6,0) call zatom (k+5,1.11d0,110.0d0,109.0d0,n-6,n-8,n-1,1) call zatom (k+5,1.11d0,110.0d0,109.0d0,n-7,n-9,n-2,-1) call zatom (k+7,1.11d0,110.0d0,180.0d0,n-7,n-9,n-10,0) call zatom (k+7,1.11d0,110.0d0,109.0d0,n-8,n-10,n-1,1) call zatom (k+7,1.11d0,110.0d0,109.0d0,n-9,n-11,n-2,-1) c c serine residue (SER) c else if (resname .eq. 'SER') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.41d0,107.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+1,1.11d0,109.4d0,106.7d0,n-2,cai,n-1,1) call zatom (k+1,1.11d0,109.4d0,106.7d0,n-3,cai,n-2,-1) call zatom (k+3,0.94d0,106.9d0,chi(2,i),n-3,n-4,cai,0) c c threonine residue (THR) c else if (resname .eq. 'THR') then call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.41d0,107.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.54d0,109.5d0,107.7d0,n-2,cai,n-1,1) call zatom (k+1,1.11d0,109.4d0,106.7d0,n-3,cai,n-2,-1) call zatom (k+3,0.94d0,106.9d0,chi(2,i),n-3,n-4,cai,0) call zatom (k+5,1.11d0,110.0d0,180.0d0,n-3,n-5,cai,0) call zatom (k+5,1.11d0,110.0d0,109.0d0,n-4,n-6,n-1,1) call zatom (k+5,1.11d0,110.0d0,109.0d0,n-5,n-7,n-2,-1) c c cysteine residue (CYS) c else if (resname .eq. 'CYS') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.82d0,109.0d0,chi(1,i),n-1,cai,ni,0) call zatom (k+1,1.11d0,109.4d0,112.0d0,n-2,cai,n-1,1) call zatom (k+1,1.11d0,109.4d0,112.0d0,n-3,cai,n-2,-1) call zatom (k+3,1.34d0,96.0d0,chi(2,i),n-3,n-4,cai,0) c c cystine residue (CYX) c else if (resname .eq. 'CYX') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.82d0,109.0d0,chi(1,i),n-1,cai,ni,0) call zatom (k+1,1.11d0,109.4d0,112.0d0,n-2,cai,n-1,1) call zatom (k+1,1.11d0,109.4d0,112.0d0,n-3,cai,n-2,-1) if (disulf(i) .gt. i) then disulf(i) = n - 3 else if (disulf(i) .lt. i) then call zatom (-1,0.0d0,0.0d0,0.0d0,disulf(disulf(i)),n-3,0,0) end if c c deprotonated cysteine residue (CYD) c else if (resname .eq. 'CYD') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.82d0,109.0d0,chi(1,i),n-1,cai,ni,0) call zatom (k+1,1.11d0,109.4d0,112.0d0,n-2,cai,n-1,1) call zatom (k+1,1.11d0,109.4d0,112.0d0,n-3,cai,n-2,-1) c c proline residue (PRO) c else if (resname .eq. 'PRO') then call zatom (k,1.54d0,107.0d0,109.5d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,107.0d0,chi(1,i),n-1,cai,ni,0) if (i .eq. 1) then call zatom (ntprocd,1.54d0,107.0d0,chi(2,i),n-1,n-2,cai,0) else call zatom (k+4,1.54d0,107.0d0,chi(2,i),n-1,n-2,cai,0) end if call zatom (-1,0.0d0,0.0d0,0.0d0,ni,n-1,0,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-3,cai,n-2,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,-1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-4,n-5,n-3,1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,-1) if (i .eq. 1) then call zatom (ntprohd,1.11d0,109.4d0,109.4d0,n-5,n-6,ni,1) call zatom (ntprohd,1.11d0,109.4d0,109.4d0,n-6,n-7,ni,-1) else call zatom (k+5,1.11d0,109.4d0,109.4d0,n-5,n-6,ni,1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-6,n-7,ni,-1) end if c c phenylalanine residue (PHE) c else if (resname .eq. 'PHE') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+3,1.39d0,120.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+3,1.39d0,120.0d0,120.0d0,n-2,n-3,n-1,1) call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-3,n-4,0) call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-4,n-5,0) call zatom (k+7,1.39d0,120.0d0,0.0d0,n-2,n-4,n-5,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,-1) call zatom (k+4,1.10d0,120.0d0,120.0d0,n-7,n-8,n-5,1) call zatom (k+4,1.10d0,120.0d0,120.0d0,n-7,n-9,n-5,1) call zatom (k+6,1.10d0,120.0d0,120.0d0,n-7,n-9,n-5,1) call zatom (k+6,1.10d0,120.0d0,120.0d0,n-7,n-9,n-6,1) call zatom (k+8,1.10d0,120.0d0,120.0d0,n-7,n-9,n-8,1) c c tyrosine residue (TYR) c else if (resname .eq. 'TYR') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+3,1.39d0,120.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+3,1.39d0,120.0d0,120.0d0,n-2,n-3,n-1,1) call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-3,n-4,0) call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-4,n-5,0) call zatom (k+7,1.39d0,120.0d0,0.0d0,n-2,n-4,n-5,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) call zatom (k+8,1.36d0,120.0d0,120.0d0,n-1,n-2,n-3,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-9,cai,n-8,-1) call zatom (k+4,1.10d0,120.0d0,120.0d0,n-8,n-9,n-6,1) call zatom (k+4,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1) call zatom (k+6,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1) call zatom (k+6,1.10d0,120.0d0,120.0d0,n-8,n-10,n-7,1) call zatom (k+9,0.97d0,108.0d0,0.0d0,n-7,n-8,n-9,0) c c deprotonated tyrosine residue (TYD) c else if (resname .eq. 'TYD') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+3,1.39d0,120.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+3,1.39d0,120.0d0,120.0d0,n-2,n-3,n-1,1) call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-3,n-4,0) call zatom (k+5,1.39d0,120.0d0,180.0d0,n-2,n-4,n-5,0) call zatom (k+7,1.39d0,120.0d0,0.0d0,n-2,n-4,n-5,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) call zatom (k+8,1.36d0,120.0d0,120.0d0,n-1,n-2,n-3,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-9,cai,n-8,-1) call zatom (k+4,1.10d0,120.0d0,120.0d0,n-8,n-9,n-6,1) call zatom (k+4,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1) call zatom (k+6,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1) call zatom (k+6,1.10d0,120.0d0,120.0d0,n-8,n-10,n-7,1) c c tryptophan residue (TRP) c else if (resname .eq. 'TRP') then call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+3,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+5,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1) call zatom (k+6,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0) call zatom (k+8,1.35d0,108.0d0,0.0d0,n-1,n-3,n-4,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-3,n-1,0,0) call zatom (k+9,1.35d0,120.0d0,180.0d0,n-3,n-1,n-2,0) call zatom (k+11,1.35d0,120.0d0,0.0d0,n-2,n-4,n-1,0) call zatom (k+13,1.35d0,120.0d0,0.0d0,n-2,n-5,n-3,0) call zatom (k+15,1.35d0,120.0d0,0.0d0,n-2,n-4,n-6,0) call zatom (-1,0.0d0,0.0d0,0.0d0,n-2,n-1,0,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-10,cai,n-9,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-11,cai,n-10,-1) call zatom (k+4,1.10d0,126.0d0,126.0d0,n-10,n-11,n-8,1) call zatom (k+7,1.05d0,126.0d0,126.0d0,n-9,n-11,n-8,1) call zatom (k+10,1.10d0,120.0d0,120.0d0,n-8,n-11,n-6,1) call zatom (k+12,1.10d0,120.0d0,120.0d0,n-8,n-10,n-6,1) call zatom (k+14,1.10d0,120.0d0,120.0d0,n-8,n-10,n-7,1) call zatom (k+16,1.10d0,120.0d0,120.0d0,n-8,n-10,n-9,1) c c histidine (HD and HE) residue (HIS) c else if (resname .eq. 'HIS') then call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+3,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+5,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1) call zatom (k+7,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0) call zatom (k+9,1.35d0,108.0d0,0.0d0,n-2,n-4,n-3,0) call zatom (-1,0.0d0,0.0d0,.00d0,n-2,n-1,0,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,-1) call zatom (k+4,1.02d0,126.0d0,0.0d0,n-6,n-7,n-8,0) call zatom (k+6,1.10d0,126.0d0,126.0d0,n-6,n-8,n-4,1) call zatom (k+8,1.10d0,126.0d0,126.0d0,n-6,n-8,n-5,1) call zatom (k+10,1.02d0,126.0d0,126.0d0,n-6,n-8,n-7,1) c c histidine (HD only) residue (HID) c else if (resname .eq. 'HID') then call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+3,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+5,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1) call zatom (k+7,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0) call zatom (k+9,1.35d0,108.0d0,0.0d0,n-2,n-4,n-3,0) call zatom (-1,0.0d0,0.0d0,.00d0,n-2,n-1,0,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,-1) call zatom (k+4,1.02d0,126.0d0,0.0d0,n-6,n-7,n-8,0) call zatom (k+6,1.10d0,126.0d0,126.0d0,n-6,n-8,n-4,1) call zatom (k+8,1.10d0,126.0d0,126.0d0,n-6,n-8,n-5,1) c c histidine (HE only) residue (HIE) c else if (resname .eq. 'HIE') then call zatom (k,1.54d0,109.5d0,109.5d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.50d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+3,1.35d0,126.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+4,1.35d0,126.0d0,108.0d0,n-2,n-3,n-1,1) call zatom (k+6,1.35d0,108.0d0,0.0d0,n-2,n-3,n-1,0) call zatom (k+8,1.35d0,108.0d0,0.0d0,n-2,n-4,n-3,0) call zatom (-1,0.0d0,0.0d0,.00d0,n-2,n-1,0,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,-1) call zatom (k+5,1.10d0,126.0d0,126.0d0,n-5,n-7,n-3,1) call zatom (k+7,1.10d0,126.0d0,126.0d0,n-5,n-7,n-4,1) call zatom (k+9,1.02d0,126.0d0,126.0d0,n-5,n-7,n-6,1) c c aspartic acid residue (ASP) c else if (resname .eq. 'ASP') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.51d0,107.8d0,chi(1,i),n-1,cai,ni,0) call zatom (k+3,1.25d0,117.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+3,1.25d0,117.0d0,126.0d0,n-2,n-3,n-1,1) call zatom (k+1,1.11d0,109.4d0,107.9d0,n-4,cai,n-3,1) call zatom (k+1,1.11d0,109.4d0,107.9d0,n-5,cai,n-4,-1) c c protonated aspartic acid residue (ASH) c else if (resname .eq. 'ASH') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.51d0,107.8d0,chi(1,i),n-1,cai,ni,0) call zatom (k+3,1.25d0,117.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+4,1.25d0,117.0d0,126.0d0,n-2,n-3,n-1,1) call zatom (k+1,1.11d0,109.4d0,107.9d0,n-4,cai,n-3,1) call zatom (k+1,1.11d0,109.4d0,107.9d0,n-5,cai,n-4,-1) call zatom (k+5,0.98d0,108.7d0,0.0d0,n-3,n-5,n-4,0) c c asparagine residue (ASN) c else if (resname .eq. 'ASN') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.51d0,107.8d0,chi(1,i),n-1,cai,ni,0) call zatom (k+3,1.22d0,122.5d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+4,1.34d0,112.7d0,124.0d0,n-2,n-3,n-1,1) call zatom (k+1,1.11d0,109.4d0,107.9d0,n-4,cai,n-3,1) call zatom (k+1,1.11d0,109.4d0,107.9d0,n-5,cai,n-4,-1) call zatom (k+5,1.02d0,119.0d0,0.0d0,n-3,n-5,n-6,0) call zatom (k+5,1.02d0,119.0d0,120.0d0,n-4,n-6,n-1,1) c c glutamic acid residue (GLU) c else if (resname .eq. 'GLU') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.51d0,107.8d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+5,1.25d0,117.0d0,chi(3,i),n-1,n-2,n-3,0) call zatom (k+5,1.25d0,117.0d0,126.0d0,n-2,n-3,n-1,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1) call zatom (k+3,1.11d0,109.4d0,107.9d0,n-6,n-7,n-5,1) call zatom (k+3,1.11d0,109.4d0,107.9d0,n-7,n-8,n-6,-1) c c protonated glutamic acid residue (GLH) c else if (resname .eq. 'GLH') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.51d0,107.8d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+5,1.25d0,117.0d0,chi(3,i),n-1,n-2,n-3,0) call zatom (k+6,1.25d0,117.0d0,126.0d0,n-2,n-3,n-1,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1) call zatom (k+3,1.11d0,109.4d0,107.9d0,n-6,n-7,n-5,1) call zatom (k+3,1.11d0,109.4d0,107.9d0,n-7,n-8,n-6,-1) call zatom (k+7,0.98d0,108.7d0,0.0d0,n-5,n-7,n-6,0) c c glutamine residue (GLN) c else if (resname .eq. 'GLN') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.51d0,107.8d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+5,1.22d0,122.5d0,chi(3,i),n-1,n-2,n-3,0) call zatom (k+6,1.34d0,112.7d0,124.0d0,n-2,n-3,n-1,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1) call zatom (k+3,1.11d0,109.4d0,107.9d0,n-6,n-7,n-5,1) call zatom (k+3,1.11d0,109.4d0,107.9d0,n-7,n-8,n-6,-1) call zatom (k+7,1.02d0,119.0d0,0.0d0,n-5,n-7,n-8,0) call zatom (k+7,1.02d0,119.0d0,120.0d0,n-6,n-8,n-1,1) c c methionine residue (MET) c else if (resname .eq. 'MET') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.82d0,109.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+5,1.82d0,96.3d0,chi(3,i),n-1,n-2,n-3,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1) call zatom (k+3,1.11d0,109.4d0,112.0d0,n-5,n-6,n-4,1) call zatom (k+3,1.11d0,109.4d0,112.0d0,n-6,n-7,n-5,-1) call zatom (k+6,1.11d0,112.0d0,180.0d0,n-5,n-6,n-7,0) call zatom (k+6,1.11d0,112.0d0,109.4d0,n-6,n-7,n-1,1) call zatom (k+6,1.11d0,112.0d0,109.4d0,n-7,n-8,n-2,-1) c c lysine residue (LYS) c else if (resname .eq. 'LYS') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+6,1.54d0,109.5d0,chi(3,i),n-1,n-2,n-3,0) call zatom (k+8,1.50d0,109.5d0,chi(4,i),n-1,n-2,n-3,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,-1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-8,n-9,n-7,-1) call zatom (k+7,1.11d0,109.4d0,108.8d0,n-8,n-9,n-7,1) call zatom (k+7,1.11d0,109.4d0,108.8d0,n-9,n-10,n-8,-1) call zatom (k+9,1.02d0,109.5d0,180.0d0,n-9,n-10,n-11,0) call zatom (k+9,1.02d0,109.5d0,109.5d0,n-10,n-11,n-1,1) call zatom (k+9,1.02d0,109.5d0,109.5d0,n-11,n-12,n-2,-1) c c deprotonated lysine residue (LYD) c else if (resname .eq. 'LYD') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+6,1.54d0,109.5d0,chi(3,i),n-1,n-2,n-3,0) call zatom (k+8,1.50d0,109.5d0,chi(4,i),n-1,n-2,n-3,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-5,-1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,-1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-8,n-9,n-7,-1) call zatom (k+7,1.11d0,109.4d0,108.8d0,n-8,n-9,n-7,1) call zatom (k+7,1.11d0,109.4d0,108.8d0,n-9,n-10,n-8,-1) call zatom (k+9,1.02d0,109.5d0,180.0d0,n-9,n-10,n-11,0) call zatom (k+9,1.02d0,109.5d0,109.5d0,n-10,n-11,n-1,1) c c arginine residue (ARG) c else if (resname .eq. 'ARG') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+6,1.45d0,109.5d0,chi(3,i),n-1,n-2,n-3,0) call zatom (k+8,1.35d0,120.0d0,chi(4,i),n-1,n-2,n-3,0) call zatom (k+9,1.35d0,120.0d0,180.0d0,n-1,n-2,n-3,0) call zatom (k+9,1.35d0,120.0d0,120.0d0,n-2,n-3,n-1,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-7,cai,n-6,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-8,cai,n-7,-1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-8,n-9,n-7,1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-9,n-10,n-8,-1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-9,n-10,n-8,1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-10,n-11,n-9,-1) call zatom (k+7,1.02d0,120.0d0,120.0d0,n-10,n-11,n-9,1) call zatom (k+10,1.02d0,120.0d0,180.0d0,n-9,n-10,n-11,0) call zatom (k+10,1.02d0,120.0d0,120.0d0,n-10,n-11,n-1,1) call zatom (k+10,1.02d0,120.0d0,180.0d0,n-10,n-12,n-13,0) call zatom (k+10,1.02d0,120.0d0,120.0d0,n-11,n-13,n-1,1) c c ornithine residue (ORN) c else if (resname .eq. 'ORN') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,109.5d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.54d0,109.5d0,chi(2,i),n-1,n-2,cai,0) call zatom (k+6,1.50d0,109.5d0,chi(3,i),n-1,n-2,n-3,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,-1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,1) call zatom (k+5,1.11d0,109.4d0,109.4d0,n-7,n-8,n-6,-1) call zatom (k+7,1.02d0,109.5d0,180.0d0,n-7,n-8,n-9,0) call zatom (k+7,1.02d0,109.5d0,109.5d0,n-8,n-9,n-1,1) call zatom (k+7,1.02d0,109.5d0,109.5d0,n-9,n-10,n-2,-1) c c methylalanine residue (AIB) c else if (resname .eq. 'AIB') then call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,-chiral(i)) call zatom (k,1.54d0,109.5d0,107.8d0,cai,ni,ci,chiral(i)) call zatom (k+1,1.11d0,109.4d0,chi(1,i),n-2,cai,ni,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-3,cai,n-1,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-2,-1) call zatom (k+1,1.11d0,109.4d0,chi(1,i),n-4,cai,ni,0) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-1,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-6,cai,n-2,-1) c c pyroglutamic acid residue (PCA) c else if (resname .eq. 'PCA') then call zatom (k,1.54d0,107.0d0,109.5d0,cai,ni,ci,chiral(i)) call zatom (k+2,1.54d0,107.0d0,chi(1,i),n-1,cai,ni,0) call zatom (k+4,1.54d0,107.0d0,chi(2,i),n-1,n-2,cai,0) call zatom (-1,0.0d0,0.0d0,0.0d0,ni,n-1,0,0) call zatom (k+5,1.22d0,126.0d0,126.0d0,n-1,ni,n-2,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-4,cai,n-3,1) call zatom (k+1,1.11d0,109.4d0,109.4d0,n-5,cai,n-4,-1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-5,n-6,n-4,1) call zatom (k+3,1.11d0,109.4d0,109.4d0,n-6,n-7,n-5,-1) c c unknown residue (UNK) c else if (resname .eq. 'UNK') then k = hatyp(seqtyp(i)) if (i .eq. 1) k = hantyp(seqtyp(i)) if (i .eq. nseq) k = hactyp(seqtyp(i)) call zatom (k,1.11d0,109.5d0,107.9d0,cai,ni,ci,chiral(i)) end if return end c c c ################################################################ c ## ## c ## subroutine pauling -- pack multiple polypeptide chains ## c ## ## c ################################################################ c c c "pauling" uses a rigid body optimization to approximately c pack multiple polypeptide chains c c subroutine pauling use atomid use atoms use couple use group use inform use katoms use molcul use output use potent use restrn use rigid use usage implicit none integer i,j,k,nvar real*8 minimum,grdmin real*8 pauling1 real*8, allocatable :: xx(:) external pauling1,optsave c c c perform dynamic allocation of some global arrays c if (.not. allocated(iuse)) allocate (iuse(n)) if (.not. allocated(use)) allocate (use(0:n)) c c set all atoms to be active during energy evaluations c nuse = n do i = 1, n use(i) = .true. end do c c only geometric restraints will by used in optimization c call potoff use_geom = .true. c c set the default values for the restraint variables c npfix = 0 ndfix = 0 ntfix = 0 ngfix = 0 nchir = 0 use_basin = .true. depth = 3.0d0 width = 1.5d0 use_wall = .false. c c enable use of groups based on number of molecules c use_group = .true. ngrp = nmol c c perform dynamic allocation of some global arrays c if (.not. allocated(kgrp)) allocate (kgrp(n)) if (.not. allocated(grplist)) allocate (grplist(n)) if (.not. allocated(igrp)) allocate (igrp(2,0:ngrp)) if (.not. allocated(grpmass)) allocate (grpmass(0:ngrp)) if (.not. allocated(wgrp)) allocate (wgrp(0:ngrp,0:ngrp)) c c assign each chain to a separate molecule-based group c do i = 1, ngrp igrp(1,i) = imol(1,i) igrp(2,i) = imol(2,i) do j = igrp(1,i), igrp(2,i) kgrp(j) = kmol(j) grplist(kgrp(j)) = i end do end do do i = 0, ngrp do j = 0, ngrp wgrp(j,i) = 1.0d0 end do wgrp(i,i) = 1.0d0 end do c c assume unit mass for each atom and set group masses c do i = 1, n mass(i) = 1.0d0 end do do i = 1, ngrp grpmass(i) = dble(igrp(2,i)-igrp(1,i)+1) end do c c perform dynamic allocation of some global arrays c maxfix = max(n,ngrp*ngrp) if (allocated(ipfix)) deallocate(ipfix) if (allocated(kpfix)) deallocate(kpfix) if (allocated(xpfix)) deallocate(xpfix) if (allocated(ypfix)) deallocate(ypfix) if (allocated(zpfix)) deallocate(zpfix) if (allocated(pfix)) deallocate(pfix) if (allocated(igfix)) deallocate(igfix) if (allocated(gfix)) deallocate(gfix) allocate (ipfix(maxfix)) allocate (kpfix(3,maxfix)) allocate (xpfix(maxfix)) allocate (ypfix(maxfix)) allocate (zpfix(maxfix)) allocate (pfix(2,maxfix)) allocate (igfix(2,maxfix)) allocate (gfix(3,maxfix)) c c set position restraints on alpha carbons of each chain c do i = 1, n if (atmnum(type(i)) .eq. 6) then do j = 1, n12(i) if (atmnum(type(i12(j,i))) .eq. 7) then do k = 1, n13(i) if (atmnum(type(i13(k,i))) .eq. 8) then npfix = npfix + 1 ipfix(npfix) = i kpfix(1,npfix) = 1 kpfix(2,npfix) = 1 kpfix(3,npfix) = 0 xpfix(npfix) = 11.0d0 * dble(grplist(i)-1) ypfix(npfix) = 0.0d0 zpfix(npfix) = 0.0d0 pfix(1,npfix) = 1.0d0 pfix(2,npfix) = 0.0d0 goto 10 end if end do end if end do end if 10 continue end do c c set pairwise restraints between the centers of chains c do i = 1, ngrp-1 do j = i+1, ngrp ngfix = ngfix + 1 igfix(1,ngfix) = i igfix(2,ngfix) = j gfix(1,ngfix) = 1.0d0 gfix(2,ngfix) = 11.0d0 * dble(j-i) gfix(3,ngfix) = 11.0d0 * dble(j-i) end do end do c c get rigid body reference coordinates for each chain c call orient c c perform dynamic allocation of some local arrays c allocate (xx(6*ngrp)) c c convert rigid body coordinates to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 xx(nvar) = rbc(j,i) end do end do c c make the call to the optimization routine c iprint = 0 iwrite = 0 grdmin = 0.1d0 coordtype = 'NONE' call ocvm (nvar,xx,minimum,grdmin,pauling1,optsave) c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c perform deallocation of some local arrays c deallocate (xx) c c convert from rigid body to Cartesian coordinates c call rigidxyz return end c c c ############################################################## c ## ## c ## function pauling1 -- energy and gradient for pauling ## c ## ## c ############################################################## c c c "pauling1" is a service routine that computes the energy c and gradient for optimally conditioned variable metric c optimization of rigid bodies c c function pauling1 (xx,g) use group use math use rigid implicit none integer i,j,nvar real*8 pauling1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) c c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c perform dynamic allocation of some local arrays c allocate (derivs(6,ngrp)) c c compute and store the energy and gradient c call rigidxyz call gradrgd (e,derivs) pauling1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 g(nvar) = derivs(j,i) end do end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ################################################### c ## COPYRIGHT (C) 2022 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine prtarc -- output of a coordinates archive ## c ## ## c ############################################################## c c c "prtarc" writes a Cartesian coordinates archive as either c a formatted or binary disk file c c subroutine prtarc (iarc,first) use output implicit none integer iarc logical first c c c write archive file as either formatted or binary file c if (archive) then call prtarcf (iarc) else if (binary) then call prtarcb (iarc,first) end if return end c c c ############################################################# c ## ## c ## subroutine prtarcf -- output of Tinker archive file ## c ## ## c ############################################################# c c c "prtarcf" writes out a set of Cartesian coordinates for c all active atoms in the Tinker XYZ archive format c c subroutine prtarcf (iarc) use atomid use atoms use bound use boxes use couple use files use inform use titles use usage implicit none integer i,j,k,iarc integer size,crdsiz real*8 crdmin,crdmax logical opened character*2 atmc character*2 crdc character*2 digc character*25 fstr character*240 arcfile c c c open output unit if not already done c inquire (unit=iarc,opened=opened) if (.not. opened) then arcfile = filename(1:leng)//'.arc' call version (arcfile,'new') open (unit=iarc,file=arcfile,status='new') end if c c check for large systems needing extended formatting c atmc = 'i6' if (n .ge. 100000) atmc = 'i7' if (n .ge. 1000000) atmc = 'i8' crdmin = 0.0d0 crdmax = 0.0d0 do i = 1, n crdmin = min(crdmin,x(i),y(i),z(i)) crdmax = max(crdmax,x(i),y(i),z(i)) end do crdsiz = 6 if (crdmin .le. -1000.0d0) crdsiz = 7 if (crdmax .ge. 10000.0d0) crdsiz = 7 if (crdmin .le. -10000.0d0) crdsiz = 8 if (crdmax .ge. 100000.0d0) crdsiz = 8 crdsiz = crdsiz + max(6,digits) size = 0 call numeral (crdsiz,crdc,size) if (digits .le. 6) then digc = '6 ' else if (digits .le. 8) then digc = '8' else digc = '10' end if c c write out the number of atoms and the title c if (ltitle .eq. 0) then fstr = '('//atmc//')' write (iarc,fstr(1:4)) nuse else fstr = '('//atmc//',2x,a)' write (iarc,fstr(1:9)) nuse,title(1:ltitle) end if c c write out the periodic cell lengths and angles c if (use_bounds) then fstr = '(1x,6f'//crdc//'.'//digc//')' write (iarc,fstr) xbox,ybox,zbox,alpha,beta,gamma end if c c write out the coordinate line for each atom c fstr = '('//atmc//',2x,a3,3f'//crdc// & '.'//digc//',i6,8'//atmc//')' do i = 1, n if (use(i)) then k = n12(i) if (k .eq. 0) then write (iarc,fstr) iuse(i),name(i),x(i),y(i),z(i), & type(i) else write (iarc,fstr) iuse(i),name(i),x(i),y(i),z(i), & type(i),(iuse(i12(j,i)),j=1,k) end if end if end do c c close the output unit if opened by this routine c if (.not. opened) close (unit=iarc) return end c c c ################################################################# c ## ## c ## subroutine prtarcb -- output binary-format archive file ## c ## ## c ################################################################# c c c "prtarcb" writes out a set of Cartesian coordinates for all c active atoms in the CHARMM DCD binary format c c note the format used is based on the "dcdplugin.c" code from c the NAMD and VMD programs, and tutorial 4.1 from the software c package GENESIS: Generalized-Ensemble Simulation System c c variables and parameters: c c header type of data (CORD=coordinates, VELD=velocities) c nframe number of frames stored in the DCD file c nprev number of previous integration steps c ncrdsav frequency in steps for saving coordinate frames c nstep number of integration steps in the total run c nvelsav frequency of coordinate saves with velocity data c ndfree number of degrees of freedom for the system c nfixat number of fixed atoms for the system c usebox flag for periodic boundaries (1=true, 0=false) c use4d flag for 4D trajectory (1=true, 0=false) c usefq flag for fluctuating charges (1=true, 0=false) c merged result of merge without checks (1=true, 0=false) c vcharmm version of CHARMM software for compatibility c c in general a value of zero for any of the above indicates that c the particular feature is unused c c subroutine prtarcb (idcd,first) use atoms use bound use boxes use files use titles use usage implicit none integer i,k,idcd integer zero,one integer nframe,nprev integer ncrdsav,nstep integer nvelsav,ndfree integer nfixat,usebox integer use4d,usefq integer merged,vcharmm integer ntitle real*4 tdelta logical opened,first character*4 header character*240 dcdfile c c c open the output unit if not already done c inquire (unit=idcd,opened=opened) if (.not. opened) then dcdfile = filename(1:leng)//'.dcd' call version (dcdfile,'new') open (unit=idcd,file=dcdfile,form='unformatted',status='new') end if c c write header info along with title and number of atoms c if (first) then first = .false. zero = 0 one = 1 header = 'CORD' nframe = zero nprev = zero ncrdsav = one nstep = zero nvelsav = zero ndfree = zero nfixat = zero tdelta = 0.0 usebox = zero if (use_bounds) usebox = one use4d = zero usefq = zero merged = zero vcharmm = 24 ntitle = one write (idcd) header,nframe,nprev,ncrdsav,nstep, & nvelsav,zero,zero,ndfree,nfixat, & tdelta,usebox,use4d,usefq,merged, & zero,zero,zero,zero,zero,vcharmm write (idcd) ntitle,title(1:80) write (idcd) nuse end if c c append the lattice values based on header flag value c if (use_bounds) then write (idcd) xbox,gamma_cos,ybox,beta_cos,alpha_cos,zbox end if c c remove unused atoms from the coordinates to be output c if (nuse .ne. n) then k = 0 do i = 1, n if (use(i)) then k = k + 1 x(k) = x(i) y(k) = y(i) z(k) = z(i) end if end do end if c c append the atomic coordinates along each axis in turn c write (idcd) (real(x(i)),i=1,nuse) write (idcd) (real(y(i)),i=1,nuse) write (idcd) (real(z(i)),i=1,nuse) c c close the output unit if opened by this routine c if (.not. opened) close (unit=idcd) return end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine prtdyn -- output of MD restart information ## c ## ## c ############################################################### c c c "prtdyn" writes out the information needed to restart a c molecular dynamics trajectory to an external disk file c c subroutine prtdyn use atoms use boxes use files use group use mdstuf use moldyn use rgddyn use titles implicit none integer i,idyn integer freeunit logical exist character*2 atmc character*39 fstr character*240 dynfile c c c update an existing restart file or open a new one c idyn = freeunit () dynfile = filename(1:leng)//'.dyn' inquire (file=dynfile,exist=exist) if (exist) then open (unit=idyn,file=dynfile,status='old') rewind (unit=idyn) else open (unit=idyn,file=dynfile,status='new') end if c c save the number of atoms and the title string c fstr = '('' Number of Atoms and Title :'')' write (idyn,fstr(1:32)) atmc = 'i6' if (n .ge. 100000) atmc = 'i7' if (n .ge. 1000000) atmc = 'i8' if (ltitle .eq. 0) then fstr = '('//atmc//')' write (idyn,fstr(1:4)) n else fstr = '('//atmc//',2x,a)' write (idyn,fstr(1:9)) n,title(1:ltitle) end if c c save the periodic box edge lengths and angles c fstr = '('' Periodic Box Dimensions :'')' write (idyn,fstr(1:30)) fstr = '(3d26.16)' write (idyn,fstr(1:9)) xbox,ybox,zbox write (idyn,fstr(1:9)) alpha,beta,gamma c c save rigid body positions, translational and angular velocities c if (integrate .eq. 'RIGIDBODY') then fstr = '('' Current Atomic Positions :'')' write (idyn,fstr(1:31)) fstr = '(3d26.16)' do i = 1, n write (idyn,fstr(1:9)) x(i),y(i),z(i) end do fstr = '('' Current Translational Velocities :'')' write (idyn,fstr(1:39)) fstr = '(3d26.16)' do i = 1, ngrp write (idyn,fstr(1:9)) vcm(1,i),vcm(2,i),vcm(3,i) end do fstr = '('' Current Angular Velocities :'')' write (idyn,fstr(1:33)) fstr = '(3d26.16)' do i = 1, ngrp write (idyn,fstr(1:9)) wcm(1,i),wcm(2,i),wcm(3,i) end do fstr = '('' Current Angular Momenta :'')' write (idyn,fstr(1:30)) fstr = '(3d26.16)' do i = 1, ngrp write (idyn,fstr(1:9)) lm(1,i),lm(2,i),lm(3,i) end do c c save the atomic positions, velocities and accelerations c else fstr = '('' Current Atomic Positions :'')' write (idyn,fstr(1:31)) fstr = '(3d26.16)' do i = 1, n write (idyn,fstr(1:9)) x(i),y(i),z(i) end do fstr = '('' Current Atomic Velocities :'')' write (idyn,fstr(1:32)) fstr = '(3d26.16)' do i = 1, n write (idyn,fstr(1:9)) v(1,i),v(2,i),v(3,i) end do fstr = '('' Current Atomic Accelerations :'')' write (idyn,fstr(1:36)) fstr = '(3d26.16)' do i = 1, n write (idyn,fstr(1:9)) a(1,i),a(2,i),a(3,i) end do fstr = '('' Alternate Atomic Accelerations :'')' write (idyn,fstr(1:38)) fstr = '(3d26.16)' if (integrate .eq. 'VERLET') then do i = 1, n write (idyn,fstr(1:9)) a(1,i),a(2,i),a(3,i) end do else do i = 1, n write (idyn,fstr(1:9)) aalt(1,i),aalt(2,i),aalt(3,i) end do end if end if c c close the dynamics trajectory restart file c close (unit=idyn) return end c c c ################################################### c ## COPYRIGHT (C) 1995 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine prterr -- output coordinates upon error ## c ## ## c ############################################################ c c c "prterr" writes out a set of coordinates to a disk c file prior to aborting on a serious error c c subroutine prterr use files use output implicit none integer ierr,freeunit character*240 errorfile c c c write the current coordinates to a file after an error c ierr = freeunit () errorfile = filename(1:leng)//'.err' call version (errorfile,'new') open (unit=ierr,file=errorfile,status='new') if (coordtype .eq. 'CARTESIAN') then call prtxyz (ierr) else if (coordtype .eq. 'INTERNAL') then call prtint (ierr) else if (coordtype .eq. 'RIGIDBODY') then call prtxyz (ierr) end if close (unit=ierr) return end c c c ################################################### c ## COPYRIGHT (C) 2023 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine prtfrc -- output of atom force components ## c ## ## c ############################################################## c c c "prtfrc" writes out a set of atom force components c to an external disk file in Tinker XYZ format c c subroutine prtfrc (ifrc) use atomid use atoms use bound use boxes use couple use deriv use files use inform use titles implicit none integer i,j,k,ifrc integer size,crdsiz real*8 crdmin,crdmax logical opened character*2 atmc character*2 crdc character*2 digc character*25 fstr character*240 frcfile c c c open the output unit if not already done c inquire (unit=ifrc,opened=opened) if (.not. opened) then frcfile = filename(1:leng)//'.frc' call version (frcfile,'new') open (unit=ifrc,file=frcfile,status='new') end if c c check for large systems needing extended formatting c atmc = 'i6' if (n .ge. 100000) atmc = 'i7' if (n .ge. 1000000) atmc = 'i8' crdmin = 0.0d0 crdmax = 0.0d0 do i = 1, n crdmin = min(crdmin,x(i),y(i),z(i)) crdmax = max(crdmax,x(i),y(i),z(i)) end do crdsiz = 6 if (crdmin .le. -1000.0d0) crdsiz = 7 if (crdmax .ge. 10000.0d0) crdsiz = 7 if (crdmin .le. -10000.0d0) crdsiz = 8 if (crdmax .ge. 100000.0d0) crdsiz = 8 crdsiz = crdsiz + max(6,digits) size = 0 call numeral (crdsiz,crdc,size) if (digits .le. 6) then digc = '6 ' else if (digits .le. 8) then digc = '8' else digc = '10' end if c c write out the number of atoms and the title c if (ltitle .eq. 0) then fstr = '('//atmc//')' write (ifrc,fstr(1:4)) n else fstr = '('//atmc//',2x,a)' write (ifrc,fstr(1:9)) n,title(1:ltitle) end if c c write out the periodic cell lengths and angles c if (use_bounds) then fstr = '(1x,6f'//crdc//'.'//digc//')' write (ifrc,fstr) xbox,ybox,zbox,alpha,beta,gamma end if c c write out the atom force components for each atom c fstr = '('//atmc//',2x,a3,3f'//crdc// & '.'//digc//',i6,8'//atmc//')' do i = 1, n k = n12(i) if (k .eq. 0) then write (ifrc,fstr) i,name(i),(-desum(j,i),j=1,3),type(i) else write (ifrc,fstr) i,name(i),(-desum(j,i),j=1,3),type(i), & (i12(j,i),j=1,k) end if end do c c close the output unit if opened by this routine c if (.not. opened) close (unit=ifrc) return end c c c ############################################################## c ## ## c ## subroutine prtdcdf -- output of DCD force components ## c ## ## c ############################################################## c c c "prtdcdf" writes out a set of atomic force components to c a file in CHARMM DCD binary format compatible with the VMD c visualization software and other packages c c note the format used is based on the "dcdplugin.c" code from c the NAMD and VMD programs, and tutorial 4.1 from the software c package GENESIS: Generalized-Ensemble Simulation System c c variables and parameters: c c header type of data (CORD=coordinates, VELD=velocities) c nframe number of frames stored in the DCD file c nprev number of previous integration steps c ncrdsav frequency in steps for saving coordinate frames c nstep number of integration steps in the total run c nvelsav frequency of coordinate saves with velocity data c ndfree number of degrees of freedom for the system c nfixat number of fixed atoms for the system c usebox flag for periodic boundaries (1=true, 0=false) c use4d flag for 4D trajectory (1=true, 0=false) c usefq flag for fluctuating charges (1=true, 0=false) c merged result of merge without checks (1=true, 0=false) c vcharmm version of CHARMM software for compatibility c c in general a value of zero for any of the above indicates that c the particular feature is unused c c subroutine prtdcdf (idcd,first) use atoms use bound use boxes use deriv use files use titles implicit none integer i,idcd integer zero,one integer nframe,nprev integer ncrdsav,nstep integer nvelsav,ndfree integer nfixat,usebox integer use4d,usefq integer merged,vcharmm integer ntitle real*4 tdelta logical opened,first character*4 header character*240 dcdfile c c c open the output unit if not already done c inquire (unit=idcd,opened=opened) if (.not. opened) then dcdfile = filename(1:leng)//'.dcdf' call version (dcdfile,'new') open (unit=idcd,file=dcdfile,form='unformatted',status='new') end if c c write header info along with title and number of atoms c if (first) then first = .false. zero = 0 one = 1 header = 'CORD' nframe = zero nprev = zero ncrdsav = one nstep = zero nvelsav = zero ndfree = zero nfixat = zero tdelta = 0.0 usebox = zero if (use_bounds) usebox = one use4d = zero usefq = zero merged = zero vcharmm = 24 ntitle = one write (idcd) header,nframe,nprev,ncrdsav,nstep, & nvelsav,zero,zero,ndfree,nfixat, & tdelta,usebox,use4d,usefq,merged, & zero,zero,zero,zero,zero,vcharmm write (idcd) ntitle,title(1:80) write (idcd) n end if c c append the lattice values based on header flag value c if (use_bounds) then write (idcd) xbox,gamma_cos,ybox,beta_cos,alpha_cos,zbox end if c c append the force components along each axis in turn c write (idcd) (real(-desum(1,i)),i=1,n) write (idcd) (real(-desum(2,i)),i=1,n) write (idcd) (real(-desum(3,i)),i=1,n) c c close the output unit if opened by this routine c if (.not. opened) close (unit=idcd) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine prtint -- output of internal coordinates ## c ## ## c ############################################################# c c c "prtint" writes out a set of Z-matrix internal coordinates c to an external disk file in Tinker INT format c c subroutine prtint (izmt) use atomid use atoms use files use inform use titles use zclose use zcoord implicit none integer i,k,izmt logical opened character*2 atmc character*5 bndc,angc character*43 fstr character*240 zmtfile c c c open the output unit if not already done c inquire (unit=izmt,opened=opened) if (.not. opened) then zmtfile = filename(1:leng)//'.int' call version (zmtfile,'new') open (unit=izmt,file=zmtfile,status='new') end if c c check for large systems needing extended formatting c atmc = 'i6' if (n .ge. 100000) atmc = 'i7' if (n .ge. 1000000) atmc = 'i8' if (digits .le. 6) then bndc = 'f10.5' angc = 'f10.4' else if (digits .le. 8) then bndc = 'f12.7' angc = 'f12.6' else bndc = 'f14.9' angc = 'f14.8' end if c c write out the number of atoms and the title c if (ltitle .eq. 0) then fstr = '('//atmc//')' write (izmt,fstr(1:4)) n else fstr = '('//atmc//',2x,a)' write (izmt,fstr(1:9)) n,title(1:ltitle) end if c c output of first three atoms is handled separately c fstr = '('//atmc//',2x,a3,i6,'//atmc//','//bndc//','//atmc// & ','//angc//','//atmc//','//angc//','//'i6)' if (n .ge. 1) & write (izmt,fstr) 1,name(1),type(1) if (n .ge. 2) & write (izmt,fstr) 2,name(2),type(2),iz(1,2),zbond(2) if (n .ge. 3) & write (izmt,fstr) 3,name(3),type(3),iz(1,3),zbond(3), & iz(2,3),zang(3) c c convert torsional angles to lie in standard range c do i = 4, n if (iz(4,i) .eq. 0) then do while (ztors(i) .lt. -180.0d0) ztors(i) = ztors(i) + 360.0d0 end do do while (ztors(i) .gt. 180.0d0) ztors(i) = ztors(i) - 360.0d0 end do end if end do c c output the fourth through final atoms c do i = 4, n write (izmt,fstr) i,name(i),type(i),iz(1,i),zbond(i), & iz(2,i),zang(i),iz(3,i),ztors(i),iz(4,i) end do c c addition and deletion of bonds as required c if (nadd.ne.0 .or. ndel.ne.0) then fstr = '(2'//atmc//')' write (izmt,'()') do i = 1, nadd write (izmt,fstr(1:5)) (iadd(k,i),k=1,2) end do if (ndel .ne. 0) write (izmt,'()') do i = 1, ndel write (izmt,fstr(1:5)) (idel(k,i),k=1,2) end do end if c c close the output unit if opened by this routine c if (.not. opened) close (unit=izmt) return end c c c ################################################### c ## COPYRIGHT (C) 1995 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## program prtmol2 -- output Tripos MOL2 structure file ## c ## ## c ############################################################## c c c "prtmol2" writes out a set of coordinates in Tripos MOL2 c format to an external disk file c c subroutine prtmol2 (imol2) use atoms use bndstr use files use iounit use titles implicit none integer i,j,imol2 integer substr integer trimtext real*8, allocatable :: atmchg(:) logical opened character*2, allocatable :: bndtyp(:) character*3 subnam character*5, allocatable :: atmtyp(:) character*8, allocatable :: atmnam(:) character*240 mol2file c c c open output unit if not already done c inquire (unit=imol2,opened=opened) if (.not. opened) then mol2file = filename(1:leng)//'.mol2' call version (mol2file,'new') open (unit=imol2,file=mol2file,status='new') end if c c perform dynamic allocation of some local arrays c allocate (atmnam(n)) allocate (atmtyp(n)) allocate (atmchg(n)) allocate (bndtyp(nbond)) c c write the MOLECULE record type indicator c write (imol2,10) 10 format ('@MOLECULE') if (ltitle .eq. 0) then write (imol2,20) 20 format ('****') else write (imol2,30) title(1:ltitle) 30 format (a) end if substr = 1 write (imol2,40) n,nbond,substr 40 format (3i7) write (imol2,50) 50 format ('SMALL') write (imol2,60) 60 format ('USER_CHARGES') c c determine MOL2 atom names/types and bond types c call setmol2 (atmnam,atmtyp,atmchg,bndtyp) c c write the ATOM record type indicator c write (imol2,70) 70 format (/,'@ATOM') do i = 1, n substr = 1 subnam = '<1>' write (imol2,80) i,atmnam(i),x(i),y(i),z(i),atmtyp(i), & substr,subnam,atmchg(i) 80 format (i7,2x,a8,3f12.6,2x,a5,i4,2x,a3,f7.2) end do c c write the BOND record type indicator c write (imol2,90) 90 format (/,'@BOND') do i = 1, nbond write (imol2,100) i,(ibnd(j,i),j=1,2), & bndtyp(i)(1:trimtext(bndtyp(i))) 100 format (3i7,2x,a) end do c c write the SUBSTRUCTURE record type indicator c write (imol2,110) 110 format (/,'@SUBSTRUCTURE') write (imol2,120) 1,'****',1,'TEMP',0,'****','****',0,'ROOT' 120 format (i7,2x,a4,i7,2x,a4,i7,2x,a4,2x,a4,i7,2x,a4) c c perform deallocation of some local arrays c deallocate (atmnam) deallocate (atmtyp) deallocate (bndtyp) c c close the output unit if opened by this routine c if (.not. opened) close (unit=imol2) return end c c c ################################################################ c ## ## c ## program setmol2 -- set MOL2 atom, charge & bond values ## c ## ## c ################################################################ c c c "setmol2" assigns MOL2 atom names/types/charges and bond types c based upon atomic numbers and connectivity c c subroutine setmol2 (atmnam,atmtyp,atmchg,bndtyp) use angbnd use atmlst use atomid use atoms use bndstr use couple use ptable use ring use tors implicit none integer i,j,k,m integer ia,ib,ic,id integer ka,kb,kc integer leng,size integer atmnum integer it,nlist integer trimtext integer list(12) real*8 atmchg(*) logical aromat logical done,proceed logical terma,termd character*1 ta,tb,tc,td character*1 digit(0:9) character*2 bndtyp(*) character*3 element character*5 atmtyp(*) character*8 number character*8 atmnam(*) data digit / '0','1','2','3','4','5','6','7','8','9' / c c c initialize atom_names, atom_types, charges and bond_types c do i = 1, n atmnam(i) = ' ' atmtyp(i) = ' ' atmchg(i) = 0.0d0 bndtyp(i) = ' ' end do c c determine the element types based upon atom names c do i = 1, n it = n12(i) atomic(i) = 0 call upcase (name(i)) if (name(i)(1:1) .eq. 'H') atomic(i) = 1 if (name(i)(1:2).eq.'LI' .and. it.eq.0) atomic(i) = 3 if (name(i).eq.'F ' .or. name(i).eq.'F- ') atomic(i) = 9 if (name(i)(1:2).eq.'NA' .and. it.eq.0) atomic(i) = 11 if (name(i)(1:2).eq.'MG' .and. it.eq.0) atomic(i) = 12 if (name(i)(1:2).eq.'AL' .and. it.eq.0) atomic(i) = 13 if (name(i)(1:2) .eq. 'SI') atomic(i) = 14 if (name(i).eq.'CL ' .or. name(i).eq.'CL-') atomic(i) = 17 if (name(i)(1:1).eq.'K' .and. it.eq.0) atomic(i) = 19 if (name(i)(1:2).eq.'CA' .and. it.eq.0) atomic(i) = 20 if (name(i)(1:2).eq.'CR' .and. it.eq.0) atomic(i) = 24 if (name(i)(1:2) .eq. 'MN') atomic(i) = 25 if (name(i)(1:2) .eq. 'FE') atomic(i) = 26 if (name(i)(1:2).eq.'CO' .and. ic.eq.0) atomic(i) = 27 if (name(i)(1:2) .eq. 'CU') atomic(i) = 29 if (name(i)(1:2) .eq. 'ZN') atomic(i) = 30 if (name(i)(1:2) .eq. 'SE') atomic(i) = 34 if (name(i).eq.'BR ' .or. name(i).eq.'BR-') atomic(i) = 35 if (name(i)(1:2) .eq. 'MO') atomic(i) = 42 if (name(i)(1:2) .eq. 'SN') atomic(i) = 50 if (name(i).eq.'I ' .or. name(i).eq.'I- ') atomic(i) = 53 if (atomic(i) .eq. 0) then if (name(i)(1:1) .eq. 'C') atomic(i) = 6 if (name(i)(1:1) .eq. 'N') atomic(i) = 7 if (name(i)(1:1) .eq. 'O') atomic(i) = 8 if (name(i)(1:1) .eq. 'S') atomic(i) = 16 end if end do c c construct the generic MOL2 atom_name for each atom c do i = 1, n size = 1 call numeral (i,number,size) if (atomic(i) .eq. 0) then atmnam(i) = 'X'//number(1:size) else element = elemnt(atomic(i)) leng = trimtext (element) atmnam(i) = element(1:leng)//number(1:size) end if end do c c assign the generic MOL2 atom_type for each atom c do i = 1, n it = 0 do k = 1, n12(i) if (atomic(i12(k,i)) .ne. 0) it = it + 1 end do atmnum = atomic(i) if (atmnum .eq. 0) then if (name(i) .eq. 'LP ') atmtyp(i) = 'LP ' if (name(i) .eq. 'DU ') atmtyp(i) = 'Du ' else if (atmnum .eq. 1) then atmtyp(i) = 'H ' else if (atmnum .eq. 3) then atmtyp(i) = 'Li ' else if (atmnum .eq. 6) then if (it .eq. 4) atmtyp(i) = 'C.3 ' if (it .eq. 3) atmtyp(i) = 'C.2 ' if (it .eq. 2) atmtyp(i) = 'C.1 ' else if (atmnum .eq. 7) then if (it .eq. 4) atmtyp(i) = 'N.4 ' if (it .eq. 3) atmtyp(i) = 'N.3 ' if (it .eq. 2) atmtyp(i) = 'N.2 ' if (it .eq. 1) atmtyp(i) = 'N.1 ' else if (atmnum .eq. 8) then if (it .ge. 2) atmtyp(i) = 'O.3 ' if (it .eq. 1) atmtyp(i) = 'O.2 ' else if (atmnum .eq. 9) then atmtyp(i) = 'F ' else if (atmnum .eq. 11) then atmtyp(i) = 'Na ' else if (atmnum .eq. 12) then atmtyp(i) = 'Mg ' else if (atmnum .eq. 13) then atmtyp(i) = 'Al ' else if (atmnum .eq. 14) then atmtyp(i) = 'Si ' else if (atmnum .eq. 15) then atmtyp(i) = 'P.3 ' else if (atmnum .eq. 16) then if (it .ge. 2) atmtyp(i) = 'S.3 ' if (it .le. 1) atmtyp(i) = 'S.2 ' else if (atmnum .eq. 17) then atmtyp(i) = 'Cl ' else if (atmnum .eq. 19) then atmtyp(i) = 'K ' else if (atmnum .eq. 20) then atmtyp(i) = 'Ca ' else if (atmnum .eq. 24) then atmtyp(i) = 'Cr.oh' else if (atmnum .eq. 25) then atmtyp(i) = 'Mn ' else if (atmnum .eq. 26) then atmtyp(i) = 'Fe ' else if (atmnum .eq. 27) then atmtyp(i) = 'Co.oh' else if (atmnum .eq. 29) then atmtyp(i) = 'Cu ' else if (atmnum .eq. 30) then atmtyp(i) = 'Zn ' else if (atmnum .eq. 35) then atmtyp(i) = 'Br ' else if (atmnum .eq. 42) then atmtyp(i) = 'Mo ' else if (atmnum .eq. 50) then atmtyp(i) = 'Sn ' else if (atmnum .eq. 53) then atmtyp(i) = 'I ' end if end do c c handle 5-membered rings for MOL2 atom_type assignment c do i = 1, nring5 aromat = .true. do j = 1, 5 k = iring5(j,i) if (atomic(k).ne.6 .and. atomic(k).ne.7) aromat = .false. if (atomic(k).eq.6 .and. n12(k).ne.3) aromat = .false. if (atomic(k).eq.7 .and. n12(k).eq.4) aromat = .false. if (atomic(k).eq.6 .and. n12(i).eq.3) then do m = 1, n12(k) kc = i12(m,k) if (atomic(kc).eq.8 .and. n12(kc).eq.1) then aromat = .false. end if end do end if end do if (aromat) then do j = 1, 5 k = iring5(j,i) c atmtyp(k) = atmtyp(k)(1:1)//'.ar ' if (atomic(k).eq.7 .and. n12(k).eq.3) & atmtyp(k) = 'N.pl3' end do end if end do c c handle 6-membered rings for MOL2 atom_type assignment c do i = 1, nring6 aromat = .true. do j = 1, 6 k = iring6(j,i) if (atomic(k).ne.6 .and. atomic(k).ne.7) aromat = .false. if (atomic(k).eq.6 .and. n12(k).ne.3) aromat = .false. if (atomic(k).eq.7 .and. n12(k).eq.4) aromat = .false. if (atomic(k).eq.6 .and. n12(i).eq.3) then do m = 1, n12(k) kc = i12(m,k) if (atomic(kc).eq.8 .and. n12(kc).eq.1) then aromat = .false. end if end do end if end do if (aromat) then do j = 1, 6 k = iring6(j,i) atmtyp(k) = atmtyp(k)(1:1)//'.ar ' end do end if end do c c handle 7-membered rings for MOL2 atom_type assignment c do i = 1, nring7 aromat = .true. do j = 1, 7 m = iring7(j,i) if (atomic(m).ne.6 .or. n12(m).ne.3) aromat = .false. end do if (aromat) then do j = 1, 7 list(j) = iring7(j,i) end do do k = 1, nring5 do j = 1, 5 list(j+7) = iring5(j,k) end do nlist = 12 call sort8 (nlist,list) if (nlist .eq. 10) then aromat = .true. do j = 1, 5 m = iring5(j,i) if (atomic(m).ne.6 .or. n12(m).ne.3) & aromat = .false. end do if (aromat) then do j = 1, 7 atmtyp(iring7(j,i)) = 'C.ar ' end do do j = 1, 5 atmtyp(iring5(j,k)) = 'C.ar ' end do end if end if end do end if end do c c handle amide nitrogens for MOL2 atom_type assignment c do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) if (atomic(ib).eq.6 .and. n12(ib).eq.3) then if (atomic(ia).eq.8 .and. n12(ia).eq.1 .and. & atomic(ic).eq.7 .and. n12(ic).eq.3) then atmtyp(ic) = 'N.am ' end if if (atomic(ic).eq.8 .and. n12(ic).eq.1 .and. & atomic(ia).eq.7 .and. n12(ia).eq.3) then atmtyp(ia) = 'N.am ' end if end if end do c c handle guanidinium carbons for MOL2 atom_type assignment c do i = 1, n if (atomic(i).eq.6 .and. n12(i).eq.3) then k = 0 do m = 1, n12(i) kc = i12(m,i) if (atomic(kc).eq.7 .and. n12(kc).eq.3) k = k + 1 end do if (k .eq. 3) atmtyp(i) = 'C.cat' end if end do c c handle carboxylate oxygens for MOL2 atom_type assignment c do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) if ((atomic(ia).eq.8.and.n12(ia).eq.1) .and. & (atomic(ic).eq.8.and.n12(ic).eq.1)) then if (atomic(ib).eq.6.and.n12(ib).eq.3) then atmtyp(ia) = 'O.co2' atmtyp(ic) = 'O.co2' end if end if end do c c handle phosphate oxygens for MOL2 atom_type assignment c do i = 1, n if (atomic(i).eq.8 .and. n12(i).eq.1) then if (atomic(i12(1,i)) .eq. 15) atmtyp(i) = 'O.co2' end if end do c c handle sulfoxide sulfurs for MOL2 atom_type assignment c do i = 1, n if (atomic(i).eq.16 .and. n12(i).eq.3) then k = 0 do m = 1, n12(i) kc = i12(m,i) if (atomic(kc).eq.8 .and. n12(kc).eq.1) k = k + 1 end do if (k .eq. 1) atmtyp(i) = 'S.o ' end if end do c c handle sulfone sulfurs for MOL2 atom_type assignment c do i = 1, n if (atomic(i).eq.16 .and. n12(i).eq.4) then k = 0 do m = 1, n12(i) kc = i12(m,i) if (atomic(kc).eq.8 .and. n12(kc).eq.1) k = k + 1 end do if (k .ge. 2) atmtyp(i) = 'S.o2 ' end if end do c c assign the generic MOL2 bond_type for each bond c do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) bndtyp(i) = '1 ' if (atmtyp(ia)(3:3).eq.'2' .and. & atmtyp(ib)(3:3).eq.'2') then bndtyp(i) = '2 ' end if if (atmtyp(ia)(3:3).eq.'2' .and. & atmtyp(ib)(3:3).eq.'1') then bndtyp(i) = '2 ' end if if (atmtyp(ia)(3:3).eq.'1' .and. & atmtyp(ib)(3:3).eq.'2') then bndtyp(i) = '2 ' end if if (atmtyp(ia)(3:3).eq.'1' .and. & atmtyp(ib)(3:3).eq.'1') then bndtyp(i) = '3 ' end if end do c c handle aromaticity for MOL2 bond_type assignment c do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (atmtyp(ia)(3:4).eq.'ar' .and. & atmtyp(ib)(3:4).eq.'ar') then do k = 1, nring5 m = 0 do j = 1, 5 kc = iring5(j,k) if (kc.eq.ia .or. kc.eq.ib) m = m + 1 end do if (m .eq. 2) bndtyp(i) = 'ar' end do do k = 1, nring6 m = 0 do j = 1, 6 kc = iring6(j,k) if (kc.eq.ia .or. kc.eq.ib) m = m + 1 end do if (m .eq. 2) bndtyp(i) = 'ar' end do do k = 1, nring7 m = 0 do j = 1, 7 kc = iring7(j,k) if (kc.eq.ia .or. kc.eq.ib) m = m + 1 end do if (m .eq. 2) bndtyp(i) = 'ar' end do end if end do c c handle conjugation for MOL2 bond_type assignment c done = .false. do while (.not. done) done = .true. do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) proceed = .false. do k = 1, n12(ib) j = bndlist(k,ib) ka = ibnd(1,j) kb = ibnd(2,j) if (ka.eq.ic .or. kb.eq.ic) then if (bndtyp(j).eq.'2 ' .or. & bndtyp(j).eq.'3 ') then m = j proceed = .true. end if end if end do if (proceed) then ta = atmtyp(ia)(3:3) tb = atmtyp(ib)(3:3) tc = atmtyp(ic)(3:3) td = atmtyp(id)(3:3) if (atmtyp(ia) .eq. 'O.co2') ta = '2' if (atmtyp(id) .eq. 'O.co2') td = '2' if ((ta.eq.'2' .or. ta.eq.'1') .and. & (tb.eq.'2' .or. tb.eq.'1') .and. & (tc.eq.'2' .or. tc.eq.'1') .and. & (td.eq.'2' .or. td.eq.'1')) then terma = .true. do k = 1, n12(ia) j = bndlist(k,ia) ka = ibnd(1,j) kb = ibnd(2,j) if (ka.ne.ib .and. kb.ne.ib) then if (bndtyp(j).eq.'2 ' .or. & bndtyp(j).eq.'3 ') then terma = .false. end if end if end do termd = .true. do k = 1, n12(id) j = bndlist(k,id) ka = ibnd(1,j) kb = ibnd(2,j) if (ka.ne.ic .and. kb.ne.ic) then if (bndtyp(j).eq.'2 ' .or. & bndtyp(j).eq.'3 ') then termd = .false. end if end if end do if (terma .or. termd) then bndtyp(m) = '1 ' done = .false. end if end if end if end do end do c c assign the generic MOL2 charge for each atom c do i = 1, n it = 0 do k = 1, n12(i) if (atomic(i12(k,i)) .ne. 0) it = it + 1 end do atmnum = atomic(i) if (atmnum.eq.3 .and. it.eq.0) atmchg(i) = 1.0d0 if (atmnum.eq.9 .and. it.eq.0) atmchg(i) = -1.0d0 if (atmnum.eq.11 .and. it.eq.0) atmchg(i) = 1.0d0 if (atmnum.eq.12 .and. it.eq.0) atmchg(i) = 2.0d0 if (atmnum.eq.13 .and. it.eq.0) atmchg(i) = 3.0d0 if (atmnum.eq.17 .and. it.eq.0) atmchg(i) = -1.0d0 if (atmnum.eq.19 .and. it.eq.0) atmchg(i) = 1.0d0 if (atmnum.eq.20 .and. it.eq.0) atmchg(i) = 2.0d0 if (atmnum.eq.24 .and. it.eq.0) atmchg(i) = 3.0d0 if (atmnum.eq.25 .and. it.eq.0) atmchg(i) = 2.0d0 if (atmnum.eq.26 .and. it.eq.0) atmchg(i) = 3.0d0 if (atmnum.eq.27 .and. it.eq.0) atmchg(i) = 2.0d0 if (atmnum.eq.29 .and. it.eq.0) atmchg(i) = 2.0d0 if (atmnum.eq.30 .and. it.eq.0) atmchg(i) = 2.0d0 if (atmnum.eq.35 .and. it.eq.0) atmchg(i) = -1.0d0 if (atmnum.eq.42 .and. it.eq.0) atmchg(i) = 4.0d0 if (atmnum.eq.53 .and. it.eq.0) atmchg(i) = -1.0d0 c c handle ammonium nitrogens for MOL2 charge assignment c if (atmtyp(i) .eq. 'N.4 ') then atmchg(i) = 1.0d0 end if c c handle pyridinium nitrogens for MOL2 charge assignment c if (atmtyp(i).eq.'N.ar ' .and. it.eq.3) then atmchg(i) = 1.0d0 end if c c handle carboxylate oxygens for MOL2 charge assignment c if (atmtyp(i) .eq. 'O.co2') then kc = i12(1,i) if (atomic(kc) .eq. 6) then atmchg(i) = -1.0d0 atmchg(kc) = 1.0d0 end if end if c c handle phosphate groups for MOL2 charge assignment c if (atmtyp(i) .eq. 'P.3 ') then atmchg(i) = 1.0d0 do m = 1, n12(i) kc = i12(m,i) if (atmtyp(kc) .eq. 'O.co2') then atmchg(kc) = -1.0d0 end if end do end if c c handle sulfonate groups for MOL2 charge assignment c if (atmtyp(i) .eq. 'S.o2 ') then k = 0 do m = 1, n12(i) kc = i12(m,i) if (atmtyp(kc) .eq. 'O.2 ') k = k + 1 end do if (k .ge. 3) then if (k .eq. 3) atmchg(i) = 0.5d0 do m = 1, n12(i) kc = i12(m,i) if (atmtyp(kc) .eq. 'O.2 ') then atmchg(kc) = -0.5d0 end if end do 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 prtpdb -- output of Protein Data Bank file ## c ## ## c ############################################################### c c c "prtpdb" writes out a set of Protein Data Bank coordinates c to an external disk file c c subroutine prtpdb (ipdb,imdl) use bound use boxes use files use pdb use sequen use titles implicit none integer i,k integer ipdb,imdl integer start,stop integer resmax,resnumb integer, allocatable :: resid(:) real*8 crdmin,crdmax logical opened logical rename logical reformat character*1 chnname character*1, allocatable :: chain(:) character*2 atmc,resc character*3 resname character*6 crdc character*38 fstr character*240 pdbfile c c c set flags for residue naming and large value formatting c rename = .false. reformat = .true. c c open the output unit if not already done c inquire (unit=ipdb,opened=opened) if (.not. opened) then pdbfile = filename(1:leng)//'.pdb' call version (pdbfile,'new') open (unit=ipdb,file=pdbfile,status='new') end if c c write out the header lines and the title c if (ltitle .eq. 0) then fstr = '(''HEADER'',/,''COMPND'',/,''SOURCE'')' write (ipdb,fstr(1:32)) else fstr = '(''HEADER'',4x,a,/,''COMPND'',/,''SOURCE'')' write (ipdb,fstr(1:37)) title(1:ltitle) end if c c include any lattice parameters in the header c if (use_bounds) then fstr = '(''CRYST1'',3f9.3,3f7.2)' write (ipdb,fstr(1:22)) xbox,ybox,zbox,alpha,beta,gamma end if c c write record to initiate the current PDB model c if (imdl .ne. 0) then fstr = '(''MODEL '',i8)' write (ipdb,fstr(1:13)) imdl end if c c perform dynamic allocation of some local arrays c allocate (resid(maxres)) allocate (chain(maxres)) c c find the chain name and chain position for each residue c do i = 1, nchain start = ichain(1,i) stop = ichain(2,i) do k = start, stop resid(k) = k - start + 1 chain(k) = chnnam(i) end do end do c c change some Tinker residue names to match PDB standards c if (rename) then do i = 1, npdb if (pdbres(i) .eq. 'CYX') pdbres(i) = 'CYS' if (pdbres(i) .eq. 'CYD') pdbres(i) = 'CYS' if (pdbres(i) .eq. 'TYD') pdbres(i) = 'TYR' if (pdbres(i) .eq. 'HID') pdbres(i) = 'HIS' if (pdbres(i) .eq. 'HIE') pdbres(i) = 'HIS' if (pdbres(i) .eq. 'HIP') pdbres(i) = 'HIS' if (pdbres(i) .eq. 'ASH') pdbres(i) = 'ASP' if (pdbres(i) .eq. 'GLH') pdbres(i) = 'GLU' if (pdbres(i) .eq. 'LYD') pdbres(i) = 'LYS' end do end if c c set formatting to match the PDB fixed format standard c atmc = 'i5' resc = 'i4' crdc = '3f8.3 ' c c check for large values requiring extended formatting c if (reformat) then resmax = 0 crdmin = 0.0d0 crdmax = 0.0d0 do i = 1, npdb if (pdbtyp(i) .eq. 'ATOM ') then resmax = max(resmax,resid(resnum(i))) else resmax = max(resmax,resnum(i)) end if crdmin = min(crdmin,xpdb(i),ypdb(i),zpdb(i)) crdmax = max(crdmax,xpdb(i),ypdb(i),zpdb(i)) end do if (npdb .ge. 100000) atmc = 'i6' if (npdb .ge. 1000000) atmc = 'i7' if (resmax .ge. 10000) resc = 'i5' if (resmax .ge. 100000) resc = 'i6' if (resmax .ge. 1000000) resc = 'i7' if (crdmin .le. -100.0d0) crdc = '3f9.3 ' if (crdmax .ge. 1000.0d0) crdc = '3f9.3 ' if (crdmin .le. -1000.0d0) crdc = '3f10.3' if (crdmax .ge. 10000.0d0) crdc = '3f10.3' end if c c write info and coordinates for each PDB atom c fstr = '(a6,'//atmc//',1x,a4,1x,a3,1x,a1,'//resc// & ',4x,'//crdc//')' do i = 1, npdb resname = pdbres(i) if (resname(2:3) .eq. ' ') resname = ' '//resname(1:1) if (resname(3:3) .eq. ' ') resname = ' '//resname(1:2) if (pdbtyp(i) .eq. 'ATOM ') then resnumb = resid(resnum(i)) chnname = chain(resnum(i)) else resnumb = resnum(i) chnname = ' ' end if write (ipdb,fstr) pdbtyp(i),i,pdbatm(i),resname,chnname, & resnumb,xpdb(i),ypdb(i),zpdb(i) end do c c perform deallocation of some local arrays c deallocate (resid) deallocate (chain) c c check for large values requiring extended formatting c if (reformat) then if (npdb .ge. 10000) atmc = 'i6' if (npdb .ge. 100000) atmc = 'i7' if (npdb .ge. 1000000) atmc = 'i8' end if c c write any connectivity records for PDB atoms c fstr = '(''CONECT'',9'//atmc//')' do i = 1, npdb if (npdb12(i) .ne. 0) then write (ipdb,fstr(1:14)) i,(ipdb12(k,i),k=1,npdb12(i)) end if end do c c write record to close the current PDB model c if (imdl .ne. 0) then fstr = '(''ENDMDL'')' write (ipdb,fstr(1:10)) end if c c close the output unit if opened by this routine c c if (.not. opened) close (unit=ipdb) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine prtprm -- output of force field parameters ## c ## ## c ############################################################### c c c "prtprm" writes out a formatted listing of the default c set of potential energy parameters for a force field c c subroutine prtprm (itxt) use angpot use bndpot use chgpot use fields use kanang use kangs use kantor use katoms use kbonds use kcflux use kchrge use kcpen use kctrn use kdipol use kdsp use kexpl use khbond use kiprop use kitors use kmulti use kopbnd use kopdst use korbs use kpitor use kpolpr use kpolr use krepl use ksolut use kstbnd use ksttor use ktorsn use ktrtor use kurybr use kvdws use kvdwpr use mplpot use polpot use sizes use urypot use vdwpot implicit none integer i,j,k,itxt integer number,npg integer k1,k2,k3 integer k4,k5 integer fold(6) real*8 ampli(6) real*8 phase(6) logical exist character*1 formfeed character*3 blank3 character*8 blank8 character*12 blank12 character*16 blank16 character*20 blank20 c c c define blank character strings of various lengths c blank3 = ' ' blank8 = ' ' blank12 = ' ' blank16 = ' ' blank20 = ' ' c c set the string value of the formfeed character (Ctrl-L) c formfeed = char(12) c c force field atom type definitions c exist = .false. do i = 1, maxtyp if (symbol(i) .ne. blank3) exist = .true. end do if (exist) then write (itxt,10) forcefield 10 format (//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,20) 20 format (//,15x,'Force Field Atom Definitions', & //,54x,'Atomic',4x,'Atomic', & /,5x,'Type',3x,'Class',3x,'Symbol',3x,'Description', & 14x,'Number',4x,'Weight',3x,'Valence',/) do i = 1, maxtyp if (symbol(i) .ne. blank3) then write (itxt,30) i,atmcls(i),symbol(i),describe(i), & atmnum(i),weight(i),ligand(i) 30 format (3x,i5,3x,i5,5x,a3,5x,a24,i5,f12.3,i7) end if end do end if c c bond stretching parameters c if (kb(1) .ne. blank8) then write (itxt,40) formfeed,forcefield 40 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,50) 50 format (//,15x,'Bond Stretching Parameters', & ///,22x,'Classes',15x,'KS',7x,'Length',/) do i = 1, maxnb if (kb(i) .eq. blank8) goto 70 k1 = number(kb(i)(1:4)) k2 = number(kb(i)(5:8)) write (itxt,60) i,k1,k2,bcon(i),blen(i) 60 format (8x,i7,5x,i4,'-',i4,6x,f12.3,f12.4) end do 70 continue end if c c bond stretching parameters for 5-membered rings c if (kb5(1) .ne. blank8) then write (itxt,80) 80 format (//,15x,'5-Membered Ring Stretch Parameters', & ///,22x,'Classes',15x,'KS',7x,'Length',/) do i = 1, maxnb5 if (kb5(i) .eq. blank8) goto 100 k1 = number(kb5(i)(1:4)) k2 = number(kb5(i)(5:8)) write (itxt,90) i,k1,k2,bcon5(i),blen5(i) 90 format (8x,i7,5x,i4,'-',i4,6x,f12.3,f12.4) end do 100 continue end if c c bond stretching parameters for 4-membered rings c if (kb4(1) .ne. blank8) then write (itxt,110) 110 format (//,15x,'4-Membered Ring Stretch Parameters', & ///,22x,'Classes',15x,'KS',7x,'Length',/) do i = 1, maxnb4 if (kb4(i) .eq. blank8) goto 130 k1 = number(kb4(i)(1:4)) k2 = number(kb4(i)(5:8)) write (itxt,120) i,k1,k2,bcon4(i),blen4(i) 120 format (8x,i7,5x,i4,'-',i4,6x,f12.3,f12.4) end do 130 continue end if c c bond stretching parameters for 3-membered rings c if (kb3(1) .ne. blank8) then write (itxt,140) 140 format (//,15x,'3-Membered Ring Stretch Parameters', & ///,22x,'Classes',15x,'KS',7x,'Length',/) do i = 1, maxnb3 if (kb3(i) .eq. blank8) goto 160 k1 = number(kb3(i)(1:4)) k2 = number(kb3(i)(5:8)) write (itxt,150) i,k1,k2,bcon3(i),blen3(i) 150 format (8x,i7,5x,i4,'-',i4,6x,f12.3,f12.4) end do 160 continue end if c c cubic and quartic bond stretching parameters c if (cbnd.ne.0.0d0 .or. qbnd.ne.0.0d0) then write (itxt,170) cbnd,qbnd 170 format (//,15x,'Higher Order Stretching Constants', & ///,20x,'Cubic',f17.3,/,20x,'Quartic',f15.3) end if c c electronegativity bond length correction parameters c if (kel(1) .ne. blank12) then write (itxt,180) 180 format (//,15x,'Electronegativity Bond Length Parameters', & ///,25x,'Classes',21x,'dLength',/) do i = 1, maxnel if (kel(i) .eq. blank12) goto 200 k1 = number(kel(i)(1:4)) k2 = number(kel(i)(5:8)) k3 = number(kel(i)(9:12)) write (itxt,190) i,k1,k2,k3,dlen(i) 190 format (8x,i7,5x,i4,'-',i4,'-',i4,14x,f12.4) end do 200 continue end if c c bond angle bending parameters c if (ka(1) .ne. blank12) then write (itxt,210) formfeed,forcefield 210 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,220) 220 format (//,15x,'Angle Bending Parameters', & ///,18x,'Classes',11x,'KB',6x,'Value 1', & 5x,'Value 2',5x,'Value 3', & /,44x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/) do i = 1, maxna if (ka(i) .eq. blank12) goto 250 k1 = number(ka(i)(1:4)) k2 = number(ka(i)(5:8)) k3 = number(ka(i)(9:12)) if (ang(2,i).eq.0.0d0 .and. ang(3,i).eq.0.0d0) then write (itxt,230) i,k1,k2,k3,acon(i),ang(1,i) 230 format (3x,i5,5x,i4,'-',i4,'-',i4,2f12.3) else write (itxt,240) i,k1,k2,k3,acon(i),(ang(j,i),j=1,3) 240 format (3x,i5,5x,i4,'-',i4,'-',i4,4f12.3) end if end do 250 continue end if c c angle bending parameters for 5-membered rings c if (ka5(1) .ne. blank12) then write (itxt,260) 260 format (//,17x,'5-Membered Ring Bend Parameters', & ///,18x,'Classes',11x,'KB',6x,'Value 1', & 5x,'Value 2',5x,'Value 3', & /,44x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/) do i = 1, maxna5 if (ka5(i) .eq. blank12) goto 290 k1 = number(ka5(i)(1:4)) k2 = number(ka5(i)(5:8)) k3 = number(ka5(i)(9:12)) if (ang5(2,i).eq.0.0d0 .and. ang5(3,i).eq.0.0d0) then write (itxt,270) i,k1,k2,k3,acon5(i),ang5(1,i) 270 format (3x,i5,5x,i4,'-',i4,'-',i4,2f12.3) else write (itxt,280) i,k1,k2,k3,acon5(i),(ang5(j,i),j=1,3) 280 format (3x,i5,5x,i4,'-',i4,'-',i4,4f12.3) end if end do 290 continue end if c c angle bending parameters for 4-membered rings c if (ka4(1) .ne. blank12) then write (itxt,300) 300 format (//,15x,'4-Membered Ring Bend Parameters', & ///,18x,'Classes',11x,'KB',6x,'Value 1', & 5x,'Value 2',5x,'Value 3', & /,44x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/) do i = 1, maxna4 if (ka4(i) .eq. blank12) goto 330 k1 = number(ka4(i)(1:4)) k2 = number(ka4(i)(5:8)) k3 = number(ka4(i)(9:12)) if (ang4(2,i).eq.0.0d0 .and. ang4(3,i).eq.0.0d0) then write (itxt,310) i,k1,k2,k3,acon4(i),ang4(1,i) 310 format (3x,i5,5x,i4,'-',i4,'-',i4,2f12.3) else write (itxt,320) i,k1,k2,k3,acon4(i),(ang4(j,i),j=1,3) 320 format (3x,i5,5x,i4,'-',i4,'-',i4,4f12.3) end if end do 330 continue end if c c angle bending parameters for 3-membered rings c if (ka3(1) .ne. blank12) then write (itxt,340) 340 format (//,15x,'3-Membered Ring Bend Parameters', & ///,18x,'Classes',11x,'KB',6x,'Value 1', & 5x,'Value 2',5x,'Value 3', & /,44x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/) do i = 1, maxna3 if (ka3(i) .eq. blank12) goto 370 k1 = number(ka3(i)(1:4)) k2 = number(ka3(i)(5:8)) k3 = number(ka3(i)(9:12)) if (ang3(2,i).eq.0.0d0 .and. ang3(3,i).eq.0.0d0) then write (itxt,350) i,k1,k2,k3,acon3(i),ang3(1,i) 350 format (3x,i5,5x,i4,'-',i4,'-',i4,2f12.3) else write (itxt,360) i,k1,k2,k3,acon3(i),(ang3(j,i),j=1,3) 360 format (3x,i5,5x,i4,'-',i4,'-',i4,4f12.3) end if end do 370 continue end if c c in-plane projected angle bending parameters c if (kap(1) .ne. blank12) then write (itxt,380) 380 format (//,15x,'In-Plane Angle Bending Parameters', & ///,18x,'Classes',11x,'KB',6x,'Value 1',5x,'Value 2', & /,45x,'(X-R)',7x,'(X-H)'/) do i = 1, maxnap if (kap(i) .eq. blank12) goto 400 k1 = number(kap(i)(1:4)) k2 = number(kap(i)(5:8)) k3 = number(kap(i)(9:12)) write (itxt,390) i,k1,k2,k3,aconp(i),(angp(j,i),j=1,2) 390 format (3x,i5,5x,i4,'-',i4,'-',i4,3f12.3) end do 400 continue end if c c Fourier bond angle bending parameters c if (kaf(1) .ne. blank12) then write (itxt,410) 410 format (//,15x,'Fourier Angle Bending Parameters', & ///,18x,'Classes',11x,'KB',8x,'Shift',6x,'Period',/) do i = 1, maxnaf if (kaf(i) .eq. blank12) goto 430 k1 = number(kaf(i)(1:4)) k2 = number(kaf(i)(5:8)) k3 = number(kaf(i)(9:12)) write (itxt,420) i,k1,k2,k3,aconf(i),(angf(j,i),j=1,2) 420 format (3x,i5,5x,i4,'-',i4,'-',i4,3f12.3) end do 430 continue end if c c cubic through sextic bond angle bending parameters c if (cang.ne.0.0d0 .or. qang.ne.0.0d0 .or. & pang.ne.0.0d0 .or. sang.ne.0.0d0) then write (itxt,440) cang,qang,pang,sang 440 format (//,15x,'Higher Order Bending Constants', & ///,20x,'Cubic',d17.3,/,20x,'Quartic',d15.3, & /,20x,'Pentic',d16.3,/,20x,'Sextic',d16.3) end if c c stretch-bend parameters c if (ksb(1) .ne. blank12) then write (itxt,450) formfeed,forcefield 450 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,460) 460 format (//,15x,'Stretch-Bend Parameters', & ///,18x,'Classes',18x,'KSB1',8x,'KSB2',/) do i = 1, maxnsb if (ksb(i) .eq. blank12) goto 480 k1 = number(ksb(i)(1:4)) k2 = number(ksb(i)(5:8)) k3 = number(ksb(i)(9:12)) write (itxt,470) i,k1,k2,k3,stbn(1,i),stbn(2,i) 470 format (3x,i5,5x,i4,'-',i4,'-',i4,8x,2f12.3) end do 480 continue end if c c Urey-Bradley parameters c if (ku(1) .ne. blank12) then write (itxt,490) formfeed,forcefield 490 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,500) 500 format (//,15x,'Urey-Bradley Parameters', & ///,18x,'Classes',19x,'KB',6x,'Distance',/) do i = 1, maxnu if (ku(i) .eq. blank12) goto 520 k1 = number(ku(i)(1:4)) k2 = number(ku(i)(5:8)) k3 = number(ku(i)(9:12)) write (itxt,510) i,k1,k2,k3,ucon(i),dst13(i) 510 format (3x,i5,5x,i4,'-',i4,'-',i4,8x,f12.3,f12.4) end do 520 continue end if c c cubic and quartic Urey-Bradley parameters c if (cury.ne.0.0d0 .or. qury.ne.0.0d0) then write (itxt,530) cury,qury 530 format (//,15x,'Higher Order Urey-Bradley Constants', & ///,20x,'Cubic',f17.3,/,20x,'Quartic',f15.3) end if c c angle-angle parameters c exist = .false. do i = 1, maxclass do k = 1, 3 if (anan(k,i) .ne. 0.0d0) exist = .true. end do end do if (exist) then write (itxt,540) formfeed,forcefield 540 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,550) 550 format (//,15x,'Angle-Angle Parameters', & ///,20x,'Class',9x,'KAA 1',7x,'KAA 2',7x,'KAA 3', & /,33x,'(R-X-R)',5x,'(R-X-H)',5x,'(H-X-H)',/) k = 0 do i = 1, maxclass if (anan(1,i).ne.0.0d0 .or. anan(2,i).ne.0.0d0 & .or. anan(3,i).ne.0.0d0) then k = k + 1 write (itxt,560) k,i,(anan(j,i),j=1,3) 560 format (6x,i7,4x,i7,3x,3f12.3) end if end do end if c c out-of-plane bending parameters c if (kopb(1) .ne. blank16) then write (itxt,570) formfeed,forcefield 570 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,580) 580 format (//,15x,'Out-of-Plane Bend Parameters', & ///,26x,'Classes',11x,'KOPB',/) do i = 1, maxnopb if (kopb(i) .eq. blank16) goto 600 k1 = number(kopb(i)(1:4)) k2 = number(kopb(i)(5:8)) k3 = number(kopb(i)(9:12)) k4 = number(kopb(i)(13:16)) write (itxt,590) i,k1,k2,k3,k4,opbn(i) 590 format (6x,i7,5x,i4,'-',i4,'-',i4,'-',i4,f12.3) end do 600 continue end if c c out-of-plane distance parameters c if (kopd(1) .ne. blank16) then write (itxt,610) formfeed,forcefield 610 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,620) 620 format (//,15x,'Out-of-Plane Distance Parameters', & ///,26x,'Classes',11x,'KOPD',/) do i = 1, maxnopd if (kopd(i) .eq. blank16) goto 640 k1 = number(kopd(i)(1:4)) k2 = number(kopd(i)(5:8)) k3 = number(kopd(i)(9:12)) k4 = number(kopd(i)(13:16)) write (itxt,630) i,k1,k2,k3,k4,opds(i) 630 format (6x,i7,5x,i4,'-',i4,'-',i4,'-',i4,f12.3) end do 640 continue end if c c improper dihedral parameters c if (kdi(1) .ne. blank16) then write (itxt,650) formfeed,forcefield 650 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,660) 660 format (//,15x,'Improper Dihedral Parameters', & ///,20x,'Classes',12x,'KID',7x,'Target',/) do i = 1, maxndi if (kdi(i) .eq. blank16) goto 680 k1 = number(kdi(i)(1:4)) k2 = number(kdi(i)(5:8)) k3 = number(kdi(i)(9:12)) k4 = number(kdi(i)(13:16)) write (itxt,670) i,k1,k2,k3,k4,dcon(i),tdi(i) 670 format (2x,i5,5x,i4,'-',i4,'-',i4,'-',i4,f12.3,f12.4) end do 680 continue end if c c improper torsional parameters c if (kti(1) .ne. blank16) then write (itxt,690) formfeed,forcefield 690 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,700) 700 format (//,15x,'Improper Torsion Parameters', & ///,17x,'Classes',15x,'KTI Values',/) do i = 1, maxnti if (kti(i) .eq. blank16) goto 720 k1 = number(kti(i)(1:4)) k2 = number(kti(i)(5:8)) k3 = number(kti(i)(9:12)) k4 = number(kti(i)(13:16)) j = 0 if (ti1(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 1 ampli(j) = ti1(1,i) phase(j) = ti1(2,i) end if if (ti2(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 2 ampli(j) = ti2(1,i) phase(j) = ti2(2,i) end if if (ti3(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 3 ampli(j) = ti3(1,i) phase(j) = ti3(2,i) end if write (itxt,710) i,k1,k2,k3,k4,(ampli(k), & phase(k),fold(k),k=1,j) 710 format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,2x,3(f8.3,f6.1,i2)) end do 720 continue end if c c torsional angle parameters c if (kt(1) .ne. blank16) then write (itxt,730) formfeed,forcefield 730 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,740) 740 format (//,15x,'Torsional Parameters', & ///,17x,'Classes',15x,'KT Values',/) do i = 1, maxnt if (kt(i) .eq. blank16) goto 760 k1 = number(kt(i)(1:4)) k2 = number(kt(i)(5:8)) k3 = number(kt(i)(9:12)) k4 = number(kt(i)(13:16)) j = 0 if (t1(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 1 ampli(j) = t1(1,i) phase(j) = t1(2,i) end if if (t2(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 2 ampli(j) = t2(1,i) phase(j) = t2(2,i) end if if (t3(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 3 ampli(j) = t3(1,i) phase(j) = t3(2,i) end if if (t4(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 4 ampli(j) = t4(1,i) phase(j) = t4(2,i) end if if (t5(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 5 ampli(j) = t5(1,i) phase(j) = t5(2,i) end if if (t6(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 6 ampli(j) = t6(1,i) phase(j) = t6(2,i) end if write (itxt,750) i,k1,k2,k3,k4,(ampli(k), & phase(k),fold(k),k=1,j) 750 format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,2x,6(f8.3,f6.1,i2)) end do 760 continue end if c c torsional angle parameters for 5-membered rings c if (kt5(1) .ne. blank16) then write (itxt,770) 770 format (//,15x,'5-Membered Ring Torsion Parameters', & ///,17x,'Classes',15x,'KT Values',/) do i = 1, maxnt5 if (kt5(i) .eq. blank16) goto 790 k1 = number(kt5(i)(1:4)) k2 = number(kt5(i)(5:8)) k3 = number(kt5(i)(9:12)) k4 = number(kt5(i)(13:16)) j = 0 if (t15(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 1 ampli(j) = t15(1,i) phase(j) = t15(2,i) end if if (t25(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 2 ampli(j) = t25(1,i) phase(j) = t25(2,i) end if if (t35(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 3 ampli(j) = t35(1,i) phase(j) = t35(2,i) end if if (t45(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 4 ampli(j) = t45(1,i) phase(j) = t45(2,i) end if if (t55(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 5 ampli(j) = t55(1,i) phase(j) = t55(2,i) end if if (t65(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 6 ampli(j) = t65(1,i) phase(j) = t65(2,i) end if write (itxt,780) i,k1,k2,k3,k4,(ampli(k), & phase(k),fold(k),k=1,j) 780 format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,2x,6(f8.3,f6.1,i2)) end do 790 continue end if c c torsional angle parameters for 4-membered rings c if (kt4(1) .ne. blank16) then write (itxt,800) 800 format (//,15x,'4-Membered Ring Torsion Parameters', & ///,17x,'Classes',15x,'KT Values',/) do i = 1, maxnt4 if (kt4(i) .eq. blank16) goto 820 k1 = number(kt4(i)(1:4)) k2 = number(kt4(i)(5:8)) k3 = number(kt4(i)(9:12)) k4 = number(kt4(i)(13:16)) j = 0 if (t14(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 1 ampli(j) = t14(1,i) phase(j) = t14(2,i) end if if (t24(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 2 ampli(j) = t24(1,i) phase(j) = t24(2,i) end if if (t34(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 3 ampli(j) = t34(1,i) phase(j) = t34(2,i) end if if (t44(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 4 ampli(j) = t44(1,i) phase(j) = t44(2,i) end if if (t54(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 5 ampli(j) = t54(1,i) phase(j) = t54(2,i) end if if (t64(1,i) .ne. 0.0d0) then j = j + 1 fold(j) = 6 ampli(j) = t64(1,i) phase(j) = t64(2,i) end if write (itxt,810) i,k1,k2,k3,k4,(ampli(k), & phase(k),fold(k),k=1,j) 810 format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,2x,6(f8.3,f6.1,i2)) end do 820 continue end if c c pi-system torsion parameters c if (kpt(1) .ne. blank8) then write (itxt,830) formfeed,forcefield 830 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,840) 840 format (//,15x,'Pi-Orbital Torsion Parameters', & ///,18x,'Classes',15x,'KPT',/) do i = 1, maxnpt if (kpt(i) .eq. blank8) goto 860 k1 = number(kpt(i)(1:4)) k2 = number(kpt(i)(5:8)) write (itxt,850) i,k1,k2,ptcon(i) 850 format (4x,i7,5x,i4,'-',i4,6x,f12.3) end do 860 continue end if c c stretch-torsion parameters c if (kbt(1) .ne. blank16) then write (itxt,870) formfeed,forcefield 870 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,880) 880 format (//,15x,'Stretch-Torsion Parameters', & ///,17x,'Classes',12x,'Bond',8x,'KST1', & 8x,'KST2',8x,'KST3',/) do i = 1, maxnbt if (kbt(i) .eq. blank16) goto 900 k1 = number(kbt(i)(1:4)) k2 = number(kbt(i)(5:8)) k3 = number(kbt(i)(9:12)) k4 = number(kbt(i)(13:16)) write (itxt,890) i,k1,k2,k3,k4,(btcon(j,i),j=1,9) 890 format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,9x,'1st',3f12.3, & /,37x,'2nd',3f12.3,/,37x,'3rd',3f12.3) end do 900 continue end if c c angle-torsion parameters c if (kat(1) .ne. blank16) then write (itxt,910) formfeed,forcefield 910 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,920) 920 format (//,15x,'Angle-Torsion Parameters', & ///,17x,'Classes',12x,'Angle',7x,'KAT1', & 8x,'KAT2',8x,'KAT3',/) do i = 1, maxnat if (kat(i) .eq. blank16) goto 940 k1 = number(kat(i)(1:4)) k2 = number(kat(i)(5:8)) k3 = number(kat(i)(9:12)) k4 = number(kat(i)(13:16)) write (itxt,930) i,k1,k2,k3,k4,(atcon(j,i),j=1,6) 930 format (2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,9x,'1st',3f12.3 & /,37x,'2nd',3f12.3) end do 940 continue end if c c torsion-torsion parameters c if (ktt(1) .ne. blank20) then write (itxt,950) formfeed,forcefield 950 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,960) 960 format (//,15x,'Torsion-Torsion Parameters', & ///,19x,'Classes',18x,'KNX',9x,'KNY') do i = 1, maxntt if (ktt(i) .eq. blank20) goto 990 k1 = number(ktt(i)(1:4)) k2 = number(ktt(i)(5:8)) k3 = number(ktt(i)(9:12)) k4 = number(ktt(i)(13:16)) k5 = number(ktt(i)(17:20)) write (itxt,970) i,k1,k2,k3,k4,k5,tnx(i),tny(i) 970 format (/,2x,i5,2x,i4,'-',i4,'-',i4,'-',i4,'-',i4,2x,2i12,/) k = tnx(i) * tny(i) write (itxt,980) (tbf(j,i),j=1,k) 980 format (3x,6f12.4) end do 990 continue end if c c van der Waals parameters c exist = .false. do i = 1, maxtyp if (rad(i) .ne. 0.0d0) exist = .true. end do if (exist) then write (itxt,1000) formfeed,forcefield 1000 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) if (vdwindex .eq. 'CLASS') then write (itxt,1010) 1010 format (//,15x,'Van der Waals Parameters', & ///,21x,'Class',6x,'Radius',6x,'Epsilon', & 4x,'Reduction',/) else write (itxt,1020) 1020 format (//,15x,'Van der Waals Parameters', & ///,22x,'Type',6x,'Radius',6x,'Epsilon', & 4x,'Reduction',/) end if k = 0 do i = 1, maxtyp if (rad(i) .ne. 0.0d0) then k = k + 1 write (itxt,1030) k,i,rad(i),eps(i),reduct(i) 1030 format (8x,i7,4x,i7,3f12.3) end if end do c c van der Waals scaling parameters c write (itxt,1040) v2scale,v3scale,v4scale,v5scale 1040 format (//,15x,'Van der Waals Scaling Factors', & ///,20x,'1-2 Atoms',f17.3,/,20x,'1-3 Atoms',f17.3, & /,20x,'1-4 Atoms',f17.3,/,20x,'1-5 Atoms',f17.3) end if c c van der Waals 1-4 parameters for atom types c exist = .false. do i = 1, maxtyp if (rad4(i) .ne. 0.0d0) exist = .true. end do if (exist) then if (vdwindex .eq. 'CLASS') then write (itxt,1050) 1050 format (//,15x,'Van der Waals Parameters for 1-4', & ' Interactions', & ///,20x,'Class',7x,'Radius',6x,'Epsilon',/) else write (itxt,1060) 1060 format (//,15x,'Van der Waals Parameters for 1-4', & ' Interactions', & ///,20x,'Type',8x,'Radius',6x,'Epsilon',/) end if k = 0 do i = 1, maxtyp if (rad4(i) .ne. 0.0d0) then k = k + 1 write (itxt,1070) k,i,rad4(i),eps4(i) 1070 format (8x,i7,2x,i7,2x,2f12.3) end if end do end if c c van der Waals parameters for specific atom pairs c if (kvpr(1) .ne. blank8) then if (vdwindex .eq. 'CLASS') then write (itxt,1080) 1080 format (//,15x,'Van der Waals Parameters for Atom Pairs', & ///,22x,'Classes',7x,'Radii Sum',4x,'Epsilon',/) else write (itxt,1090) 1090 format (//,15x,'Van der Waals Parameters for Atom Pairs', & ///,23x,'Types',8x,'Radii Sum',4x,'Epsilon',/) end if do i = 1, maxnvp if (kvpr(i) .eq. blank8) goto 1110 k1 = number(kvpr(i)(1:4)) k2 = number(kvpr(i)(5:8)) write (itxt,1100) i,k1,k2,radpr(i),epspr(i) 1100 format (8x,i7,5x,i4,'-',i4,2x,2f12.3) end do 1110 continue end if c c hydrogen bonding parameters for specific atom pairs c if (khb(1) .ne. blank8) then if (vdwindex .eq. 'CLASS') then write (itxt,1120) 1120 format (//,15x,'Hydrogen Bonding Parameters for Atom Pairs', & ///,22x,'Classes',7x,'Radii Sum',4x,'Epsilon',/) else write (itxt,1130) 1130 format (//,15x,'Hydrogen Bonding Parameters for Atom Pairs', & ///,23x,'Types',8x,'Radii Sum',4x,'Epsilon',/) end if do i = 1, maxnhb if (khb(i) .eq. blank8) goto 1150 k1 = number(khb(i)(1:4)) k2 = number(khb(i)(5:8)) write (itxt,1140) i,k1,k2,radhb(i),epshb(i) 1140 format (8x,i7,5x,i4,'-',i4,2x,2f12.3) end do 1150 continue end if c c Pauli repulsion parameters c exist = .false. do i = 1, maxclass if (prsiz(i) .ne. 0.0d0) exist = .true. end do if (exist) then write (itxt,1160) formfeed,forcefield 1160 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,1170) 1170 format (//,15x,'Pauli Repulsion Parameters', & ///,24x,'Class',14x,'Size',8x,'Damp',5x,'Valence'/) k = 0 do i = 1, maxclass if (prsiz(i) .ne. 0.0d0) then k = k + 1 write (itxt,1180) k,i,prsiz(i),prdmp(i),prele(i) 1180 format (10x,i7,3x,i7,8x,2f12.4,f12.3) end if end do end if c c damped dispersion parameters c exist = .false. do i = 1, maxclass if (dspsix(i) .ne. 0.0d0) exist = .true. end do if (exist) then write (itxt,1190) formfeed,forcefield 1190 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,1200) 1200 format (//,15x,'Damped Dispersion Parameters', & ///,24x,'Class',15x,'C6',9x,'Damp',/) k = 0 do i = 1, maxclass if (dspsix(i) .ne. 0.0d0) then k = k + 1 write (itxt,1210) k,i,dspsix(i),dspdmp(i) 1210 format (10x,i7,3x,i7,8x,2f12.4) end if end do end if c c atomic partial charge parameters c exist = .false. do i = 1, maxtyp if (chg(i) .ne. 0.0d0) exist = .true. end do if (exist) then write (itxt,1220) formfeed,forcefield 1220 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,1230) 1230 format (//,15x,'Atomic Partial Charge Parameters', & ///,24x,'Type',9x,'Partial Chg',/) k = 0 do i = 1, maxtyp if (chg(i) .ne. 0.0d0) then k = k + 1 write (itxt,1240) k,i,chg(i) 1240 format (10x,i7,3x,i7,6x,f12.3) end if end do c c atomic partial charge scaling parameters c write (itxt,1250) c1scale,c2scale,c3scale,c4scale,c5scale 1250 format (//,15x,'Atomic Partial Charge Scaling Factors', & ///,20x,'1-1 Atoms',f17.3,/,20x,'1-2 Atoms',f17.3, & /,20x,'1-3 Atoms',f17.3,/,20x,'1-4 Atoms',f17.3, & /,20x,'1-5 Atoms',f17.3) end if c c bond dipole moment parameters c if (kd(1) .ne. blank8) then write (itxt,1260) formfeed,forcefield 1260 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,1270) 1270 format (//,15x,'Bond Dipole Moment Parameters', & ///,25x,'Types',10x,'Bond Dipole',4x,'Position',/) do i = 1, maxnd if (kd(i) .eq. blank8) goto 1290 k1 = number(kd(i)(1:4)) k2 = number(kd(i)(5:8)) write (itxt,1280) i,k1,k2,dpl(i),pos(i) 1280 format (10x,i7,5x,i4,'-',i4,6x,2f12.3) end do 1290 continue end if c c bond dipole moment parameters for 5-membered rings c if (kd5(1) .ne. blank8) then write (itxt,1300) 1300 format (//,15x,'5-Membered Ring Bond Dipole Parameters', & ///,25x,'Types',10x,'Bond Dipole',4x,'Position',/) do i = 1, maxnd5 if (kd5(i) .eq. blank8) goto 1320 k1 = number(kd5(i)(1:4)) k2 = number(kd5(i)(5:8)) write (itxt,1310) i,k1,k2,dpl5(i),pos5(i) 1310 format (10x,i7,5x,i4,'-',i4,6x,2f12.3) end do 1320 continue end if c c bond dipole moment parameters for 4-membered rings c if (kd4(1) .ne. blank8) then write (itxt,1330) 1330 format (//,15x,'4-Membered Ring Bond Dipole Parameters', & ///,25x,'Types',10x,'Bond Dipole',4x,'Position',/) do i = 1, maxnd4 if (kd4(i) .eq. blank8) goto 1350 k1 = number(kd4(i)(1:4)) k2 = number(kd4(i)(5:8)) write (itxt,1340) i,k1,k2,dpl4(i),pos4(i) 1340 format (10x,i7,5x,i4,'-',i4,6x,2f12.3) end do 1350 continue end if c c bond dipole moment parameters for 3-membered rings c if (kd3(1) .ne. blank8) then write (itxt,1360) 1360 format (//,15x,'3-Membered Ring Bond Dipole Parameters', & ///,25x,'Types',10x,'Bond Dipole',4x,'Position',/) do i = 1, maxnd3 if (kd3(i) .eq. blank8) goto 1380 k1 = number(kd3(i)(1:4)) k2 = number(kd3(i)(5:8)) write (itxt,1370) i,k1,k2,dpl3(i),pos3(i) 1370 format (10x,i7,5x,i4,'-',i4,6x,2f12.3) end do 1380 continue end if c c atomic multipole electrostatic parameters c if (kmp(1) .ne. blank16) then write (itxt,1390) formfeed,forcefield 1390 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,1400) 1400 format (//,17x,'Atomic Multipole Parameters', & ///,11x,'Type',7x,'Axis Types',8x,'Frame', & 9x,'Multipoles (M-D-Q)',/) do i = 1, maxnmp if (kmp(i) .eq. blank16) goto 1420 k1 = number(kmp(i)(1:4)) k2 = number(kmp(i)(5:8)) k3 = number(kmp(i)(9:12)) k4 = number(kmp(i)(13:16)) write (itxt,1410) i,k1,k2,k3,k4,mpaxis(i),multip(1,i), & multip(2,i),multip(3,i),multip(4,i), & multip(5,i),multip(8,i),multip(9,i), & multip(11,i),multip(12,i),multip(13,i) 1410 format (2x,i5,3x,i4,3x,i4,2x,i4,2x,i4,5x,a8,2x,f10.5, & /,48x,3f10.5,/,48x,f10.5, & /,48x,2f10.5,/,48x,3f10.5) end do 1420 continue c c atomic multipole scaling parameters c write (itxt,1430) m2scale,m3scale,m4scale,m5scale 1430 format (//,15x,'Atomic Multipole Scale Factors', & ///,20x,'1-2 Atoms',f17.3,/,20x,'1-3 Atoms',f17.3, & /,20x,'1-4 Atoms',f17.3,/,20x,'1-5 Atoms',f17.3) end if c c charge penetration parameters c exist = .false. do i = 1, maxclass if (cpele(i).ne.0.0d0 .or. cpalp(i).ne.0.0d0) exist = .true &. end do if (exist) then write (itxt,1440) formfeed,forcefield 1440 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,1450) 1450 format (//,15x,'Charge Penetration Parameters', & ///,24x,'Class',10x,'Core Chg',8x,'Damp',/) k = 0 do i = 1, maxclass if (cpele(i).ne.0.0d0 .or. cpalp(i).ne.0.0d0) then k = k + 1 write (itxt,1460) k,i,cpele(i),cpalp(i) 1460 format (10x,i7,3x,i7,8x,2f12.4) end if end do end if c c atomic dipole polarizability parameters c exist = .false. use_thole = .false. use_tholed = .false. do i = 1, maxclass if (polr(i) .ne. 0.0d0) exist = .true. if (athl(i) .ne. 0.0d0) use_thole = .true. if (dthl(i) .ne. 0.0d0) use_tholed = .true. end do if (exist) then write (itxt,1470) formfeed,forcefield 1470 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) if (use_tholed) then write (itxt,1480) 1480 format (//,15x,'Dipole Polarizability Parameters', & ///,22x,'Class',7x,'Alpha',5x,'Thole', & 4x,'TholeD',6x,'Group Types',/) else if (use_thole) then write (itxt,1490) 1490 format (//,15x,'Dipole Polarizability Parameters', & ///,22x,'Class',7x,'Alpha',5x,'Thole', & 6x,'Group Atom Types',/) else write (itxt,1500) 1500 format (//,15x,'Dipole Polarizability Parameters', & ///,22x,'Class',7x,'Alpha',6x,'Group Atom Types',/) end if k = 0 do i = 1, maxclass if (polr(i) .ne. 0.0d0) then k = k + 1 npg = 0 do j = 1, maxval if (pgrp(j,i) .ne. 0) npg = npg + 1 end do if (use_tholed) then if (npg .eq. 0) then write (itxt,1510) k,i,polr(i),athl(i),dthl(i) 1510 format (8x,i7,4x,i7,3x,3f10.3) else write (itxt,1520) k,i,polr(i),athl(i),dthl(i), & (pgrp(j,i),j=1,npg) 1520 format (8x,i7,4x,i7,3x,3f10.3,4x,6i5) end if else if (use_thole) then if (npg .eq. 0) then write (itxt,1530) k,i,polr(i),athl(i) 1530 format (8x,i7,4x,i7,3x,2f10.3) else write (itxt,1540) k,i,polr(i),athl(i), & (pgrp(j,i),j=1,npg) 1540 format (8x,i7,4x,i7,3x,2f10.3,4x,6i5) end if else if (npg .eq. 0) then write (itxt,1550) k,i,polr(i) 1550 format (8x,i7,4x,i7,3x,f10.3) else write (itxt,1560) k,i,polr(i),(pgrp(j,i),j=1,npg) 1560 format (8x,i7,4x,i7,3x,f10.3,4x,6i4) end if end if end if end do c c dipole polarizability scaling parameters c write (itxt,1570) d1scale,d2scale,d3scale,d4scale 1570 format (//,15x,'Direct Induction Scale Factors', & ///,20x,'1-1 Groups',f15.3,/,20x,'1-2 Groups',f15.3, & /,20x,'1-3 Groups',f15.3,/,20x,'1-4 Groups',f15.3) write (itxt,1580) u1scale,u2scale,u3scale,u4scale 1580 format (//,15x,'Mutual Induction Scale Factors', & ///,20x,'1-1 Groups',f15.3,/,20x,'1-2 Groups',f15.3, & /,20x,'1-3 Groups',f15.3,/,20x,'1-4 Groups',f15.3) write (itxt,1590) p2scale,p3scale,p4scale,p5scale 1590 format (//,15x,'Inter-Group Polarizability Scale Factors', & ///,20x,'1-2 Atoms',f16.3,/,20x,'1-3 Atoms',f16.3, & /,20x,'1-4 Atoms',f16.3,/,20x,'1-5 Atoms',f16.3) write (itxt,1600) p2iscale,p3iscale,p4iscale,p5iscale 1600 format (//,15x,'Intra-Group Polarizability Scale Factors', & ///,20x,'1-2 Atoms',f16.3,/,20x,'1-3 Atoms',f16.3, & /,20x,'1-4 Atoms',f16.3,/,20x,'1-5 Atoms',f16.3) write (itxt,1610) w2scale,w3scale,w4scale,w5scale 1610 format (//,15x,'Induced Dipole Interaction Scale Factors', & ///,20x,'1-2 Atoms',f16.3,/,20x,'1-3 Atoms',f16.3, & /,20x,'1-4 Atoms',f16.3,/,20x,'1-5 Atoms',f16.3) end if c c polarizability parameters for specific atom pairs c if (kppr(1) .ne. blank8) then write (itxt,1620) 1620 format (//,15x,'Polarizability Parameters for Atom Pairs', & ///,23x,'Types',10x,'Thole',6x,'TholeD',/) do i = 1, maxnpp if (kppr(i) .eq. blank8) goto 1640 k1 = number(kppr(i)(1:4)) k2 = number(kppr(i)(5:8)) write (itxt,1630) i,k1,k2,thlpr(i),thdpr(i) 1630 format (8x,i7,5x,i4,'-',i4,2x,2f12.3) end do 1640 continue end if c c exchange polarization parameters c exist = .false. do i = 1, maxclass if (pepdmp(i) .ne. 0.0d0) exist = .true. end do if (exist) then write (itxt,1650) formfeed,forcefield 1650 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,1660) 1660 format (//,15x,'Exchange Polarization Parameters', & ///,22x,'Class',8x,'Spring',8x,'Size',8x,'Damp', & 8x,'Use'/) k = 0 do i = 1, maxclass if (pepdmp(i) .ne. 0.0d0) then k = k + 1 write (itxt,1670) k,i,pepk(i),peppre(i), & pepdmp(i),pepl(k) 1670 format (10x,i7,1x,i7,4x,2f12.4,f12.3,9x,l1) end if end do end if c c charge transfer parameters c exist = .false. do i = 1, maxclass if (ctchg(i).ne.0.0d0 .or. ctdmp(i).ne.0.0d0) exist = .true &. end do if (exist) then write (itxt,1680) formfeed,forcefield 1680 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,1690) 1690 format (//,15x,'Charge Transfer Parameters', & ///,24x,'Class',12x,'Charge',7x,'Alpha',/) k = 0 do i = 1, maxclass if (ctchg(i).ne.0.0d0 .or. ctdmp(i).ne.0.0d0) then k = k + 1 write (itxt,1700) k,i,ctchg(i),ctdmp(i) 1700 format (10x,i7,3x,i7,8x,2f12.4) end if end do end if c c bond charge flux parameters c if (kcfb(1) .ne. blank8) then write (itxt,1710) formfeed,forcefield 1710 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,1720) 1720 format (//,15x,'Bond Charge Flux Parameters', & ///,22x,'Classes',14x,'KCFB',/) do i = 1, maxncfb if (kcfb(i) .eq. blank8) goto 1740 k1 = number(kcfb(i)(1:4)) k2 = number(kcfb(i)(5:8)) write (itxt,1730) i,k1,k2,cflb(i) 1730 format (8x,i7,5x,i4,'-',i4,6x,f12.4) end do 1740 continue end if c c angle charge flux parameters c if (kcfa(1) .ne. blank12) then write (itxt,1750) formfeed,forcefield 1750 format (a1,//,15x,'Tinker Force Field Parameters for ',a20) write (itxt,1760) 1760 format (//,15x,'Angle Charge Flux Parameters', & ///,18x,'Classes',10x,'KCFA1',7x,'KCFA2', & 7x,'KCFB1',7x,'KCFB2',/) do i = 1, maxncfa if (kcfa(i) .eq. blank12) goto 1780 k1 = number(kcfa(i)(1:4)) k2 = number(kcfa(i)(5:8)) k3 = number(kcfa(i)(9:12)) write (itxt,1770) i,k1,k2,k3,cfla(1,i),cfla(2,i), & cflab(1,i),cflab(2,i) 1770 format (1x,i7,5x,i4,'-',i4,'-',i4,1x,4f12.4) end do 1780 continue end if c c implicit solvation parameters c exist = .false. do i = 1, maxtyp if (pbr(i).ne.0.0d0 .or. csr(i).ne.0.0d0 .or. & gkr(i).ne.0.0d0 .or. snk(i).ne.0.0d0) exist = .true. end do if (exist) then write (itxt,1790) formfeed,forcefield 1790 format (a1,//,15x,'Tinker Force Field Parameters for ',a2 &0) write (itxt,1800) 1800 format (//,15x,'Implicit Solvation Parameters', & ///,22x,'Type',6x,'PB Size',5x,'CS Size', & 5x,'GK Size',6x,'S-Neck',/) k = 0 do i = 1, maxtyp if (pbr(i).ne.0.0d0 .or. csr(i).ne.0.0d0 .or. & gkr(i).ne.0.0d0 .or. snk(i).ne.0.0d0) then k = k + 1 write (itxt,1810) k,i,pbr(i),csr(i),gkr(i),snk(i) 1810 format (8x,i7,4x,i7,1x,4f12.4) end if end do end if c c conjugated pisystem atom parameters c exist = .false. do i = 1, maxclass if (ionize(i) .ne. 0.0d0) exist = .true. end do if (exist) then write (itxt,1820) formfeed,forcefield 1820 format (a1,//,15x,'Tinker Force Field Parameters for ',a2 &0) write (itxt,1830) 1830 format (//,15x,'Conjugated Pisystem Atom Parameters', & ///,20x,'Class',3x,'Electron', & 3x,'Ionization',3x,'Repulsion',/) k = 0 do i = 1, maxclass if (ionize(i) .ne. 0.0d0) then k = k + 1 write (itxt,1840) k,i,electron(i),ionize(i),repulse(i) 1840 format (6x,i7,4x,i7,f10.1,2x,2f12.3) end if end do end if c c conjugated pisystem bond parameters c if (kpi(1) .ne. blank8) then write (itxt,1850) 1850 format (//,15x,'Conjugated Pisystem Bond Parameters', & ///,20x,'Classes',8x,'d Force',4x,'d Length',/) do i = 1, maxnpi if (kpi(i) .eq. blank8) goto 1870 k1 = number(kpi(i)(1:4)) k2 = number(kpi(i)(5:8)) write (itxt,1860) i,k1,k2,sslope(i),tslope(i) 1860 format (6x,i7,5x,i4,'-',i4,3x,2f12.3) end do 1870 continue end if c c conjugated pisystem bond parameters for 5-membered rings c if (kpi5(1) .ne. blank8) then write (itxt,1880) 1880 format (//,15x,'5-Membered Ring Pisystem Bond Parameters' &, ///,20x,'Classes',8x,'d Force',4x,'d Length',/) do i = 1, maxnpi5 if (kpi5(i) .eq. blank8) goto 1900 k1 = number(kpi5(i)(1:4)) k2 = number(kpi5(i)(5:8)) write (itxt,1890) i,k1,k2,sslope5(i),tslope5(i) 1890 format (6x,i7,5x,i4,'-',i4,3x,2f12.3) end do 1900 continue end if c c conjugated pisystem bond parameters for 4-membered rings c if (kpi4(1) .ne. blank8) then write (itxt,1910) 1910 format (//,15x,'4-Membered Ring Pisystem Bond Parameters' &, ///,20x,'Classes',8x,'d Force',4x,'d Length',/) do i = 1, maxnpi4 if (kpi4(i) .eq. blank8) goto 1930 k1 = number(kpi4(i)(1:4)) k2 = number(kpi4(i)(5:8)) write (itxt,1920) i,k1,k2,sslope4(i),tslope4(i) 1920 format (6x,i7,5x,i4,'-',i4,3x,2f12.3) end do 1930 continue 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 prtseq -- output of biopolymer sequence ## c ## ## c ############################################################ c c c "prtseq" writes out a biopolymer sequence to an external c disk file with 15 residues per line and distinct chains c separated by blank lines c c subroutine prtseq (iseq) use files use sequen implicit none integer i,k,iseq integer smax,smin integer size,start,stop logical opened character*1 letter character*23 fstr character*240 seqfile c c c open the output unit if not already done c inquire (unit=iseq,opened=opened) if (.not. opened) then seqfile = filename(1:leng)//'.seq' call version (seqfile,'new') open (unit=iseq,file=seqfile,status='new') end if c c write out a three-letter code sequence file c do i = 1, nchain letter = chnnam(i) start = ichain(1,i) stop = ichain(2,i) size = stop - start + 1 smax = 0 do while (smax .lt. size) smin = smax + 1 smax = smax + 15 smax = min(smax,size) if (i.ne.1 .and. smin.eq.1) write (iseq,'()') fstr = '(3x,a1,i6,1x,15(1x,a3))' write (iseq,fstr) letter,smin,(seq(k+start-1),k=smin,smax) end do end do c c close the output unit if opened by this routine c if (.not. opened) close (unit=iseq) return end c c c ################################################### c ## COPYRIGHT (C) 2023 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine prtuind -- output of atomic induced dipoles ## c ## ## c ################################################################ c c c "prtuind" writes out a set of induced dipole components c to an external disk file in Tinker XYZ format c c subroutine prtuind (iind) use atomid use atoms use bound use boxes use couple use files use inform use polar use potent use solpot use titles use units implicit none integer i,j,k,iind integer size,crdsiz real*8 crdmin,crdmax logical opened character*2 atmc character*2 crdc character*2 digc character*25 fstr character*240 indfile c c c open the output unit if not already done c inquire (unit=iind,opened=opened) if (.not. opened) then indfile = filename(1:leng)//'.uind' call version (indfile,'new') open (unit=iind,file=indfile,status='new') end if c c check for large systems needing extended formatting c atmc = 'i6' if (n .ge. 100000) atmc = 'i7' if (n .ge. 1000000) atmc = 'i8' crdmin = 0.0d0 crdmax = 0.0d0 do i = 1, n crdmin = min(crdmin,x(i),y(i),z(i)) crdmax = max(crdmax,x(i),y(i),z(i)) end do crdsiz = 6 if (crdmin .le. -1000.0d0) crdsiz = 7 if (crdmax .ge. 10000.0d0) crdsiz = 7 if (crdmin .le. -10000.0d0) crdsiz = 8 if (crdmax .ge. 100000.0d0) crdsiz = 8 crdsiz = crdsiz + max(6,digits) size = 0 call numeral (crdsiz,crdc,size) if (digits .le. 6) then digc = '6 ' else if (digits .le. 8) then digc = '8' else digc = '10' end if c c write out the number of atoms and the title c if (ltitle .eq. 0) then fstr = '('//atmc//')' write (iind,fstr(1:4)) n else fstr = '('//atmc//',2x,a)' write (iind,fstr(1:9)) n,title(1:ltitle) end if c c write out the periodic cell lengths and angles c if (use_bounds) then fstr = '(1x,6f'//crdc//'.'//digc//')' write (iind,fstr) xbox,ybox,zbox,alpha,beta,gamma end if c c write out the induced dipole components for each atom c fstr = '('//atmc//',2x,a3,3f'//crdc// & '.'//digc//',i6,8'//atmc//')' if (use_solv) then if (solvtyp(1:2).eq.'GK' .or. solvtyp(1:2).eq.'PB') then do i = 1, n k = n12(i) if (k .eq. 0) then write (iind,fstr) i,name(i),(debye*uinds(j,i),j=1,3), & type(i) else write (iind,fstr) i,name(i),(debye*uinds(j,i),j=1,3), & type(i),(i12(j,i),j=1,k) end if end do else do i = 1, n k = n12(i) if (k .eq. 0) then write (iind,fstr) i,name(i),(debye*uind(j,i),j=1,3), & type(i) else write (iind,fstr) i,name(i),(debye*uind(j,i),j=1,3), & type(i),(i12(j,i),j=1,k) end if end do end if end if c c close the output unit if opened by this routine c if (.not. opened) close (unit=iind) return end c c c ############################################################# c ## ## c ## subroutine prtdcdu -- output of DCD induced dipoles ## c ## ## c ############################################################# c c c "prtdcdu" writes out a set of induced dipole components to c a file in CHARMM DCD binary format compatible with the VMD c visualization software and other packages c c note the format used is based on the "dcdplugin.c" code from c the NAMD and VMD programs, and tutorial 4.1 from the software c package GENESIS: Generalized-Ensemble Simulation System c c variables and parameters: c c header type of data (CORD=coordinates, VELD=velocities) c nframe number of frames stored in the DCD file c nprev number of previous integration steps c ncrdsav frequency in steps for saving coordinate frames c nstep number of integration steps in the total run c nvelsav frequency of coordinate saves with velocity data c ndfree number of degrees of freedom for the system c nfixat number of fixed atoms for the system c usebox flag for periodic boundaries (1=true, 0=false) c use4d flag for 4D trajectory (1=true, 0=false) c usefq flag for fluctuating charges (1=true, 0=false) c merged result of merge without checks (1=true, 0=false) c vcharmm version of CHARMM software for compatibility c c in general a value of zero for any of the above indicates that c the particular feature is unused c c subroutine prtdcdu (idcd,first) use atoms use bound use boxes use files use polar use potent use solpot use titles use units implicit none integer i,idcd integer zero,one integer nframe,nprev integer ncrdsav,nstep integer nvelsav,ndfree integer nfixat,usebox integer use4d,usefq integer merged,vcharmm integer ntitle real*4 tdelta logical opened,first character*4 header character*240 dcdfile c c c open the output unit if not already done c inquire (unit=idcd,opened=opened) if (.not. opened) then dcdfile = filename(1:leng)//'.dcdu' call version (dcdfile,'new') open (unit=idcd,file=dcdfile,form='unformatted',status='new') end if c c write header info along with title and number of atoms c if (first) then first = .false. zero = 0 one = 1 header = 'CORD' nframe = zero nprev = zero ncrdsav = one nstep = zero nvelsav = zero ndfree = zero nfixat = zero tdelta = 0.0 usebox = zero if (use_bounds) usebox = one use4d = zero usefq = zero merged = zero vcharmm = 24 ntitle = one write (idcd) header,nframe,nprev,ncrdsav,nstep, & nvelsav,zero,zero,ndfree,nfixat, & tdelta,usebox,use4d,usefq,merged, & zero,zero,zero,zero,zero,vcharmm write (idcd) ntitle,title(1:80) write (idcd) n end if c c append the lattice values based on header flag value c if (use_bounds) then write (idcd) xbox,gamma_cos,ybox,beta_cos,alpha_cos,zbox end if c c append the induced dipoles along each axis in turn c if (use_solv) then if (solvtyp(1:2).eq.'GK' .or. solvtyp(1:2).eq.'PB') then write (idcd) (real(debye*uinds(1,i)),i=1,n) write (idcd) (real(debye*uinds(2,i)),i=1,n) write (idcd) (real(debye*uinds(3,i)),i=1,n) else write (idcd) (real(debye*uind(1,i)),i=1,n) write (idcd) (real(debye*uind(2,i)),i=1,n) write (idcd) (real(debye*uind(3,i)),i=1,n) end if end if c c close the output unit if opened by this routine c if (.not. opened) close (unit=idcd) return end c c c ################################################### c ## COPYRIGHT (C) 2023 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine prtvel -- output of velocity components ## c ## ## c ############################################################ c c c "prtvel" writes out a set of atomic velocity components c to an external disk file in Tinker XYZ format c c subroutine prtvel (ivel) use atomid use atoms use bound use boxes use couple use files use inform use moldyn use titles implicit none integer i,j,k,ivel integer size,crdsiz real*8 crdmin,crdmax logical opened character*2 atmc character*2 crdc character*2 digc character*25 fstr character*240 velfile c c c open the output unit if not already done c inquire (unit=ivel,opened=opened) if (.not. opened) then velfile = filename(1:leng)//'.vel' call version (velfile,'new') open (unit=ivel,file=velfile,status='new') end if c c check for large systems needing extended formatting c atmc = 'i6' if (n .ge. 100000) atmc = 'i7' if (n .ge. 1000000) atmc = 'i8' crdmin = 0.0d0 crdmax = 0.0d0 do i = 1, n crdmin = min(crdmin,x(i),y(i),z(i)) crdmax = max(crdmax,x(i),y(i),z(i)) end do crdsiz = 6 if (crdmin .le. -1000.0d0) crdsiz = 7 if (crdmax .ge. 10000.0d0) crdsiz = 7 if (crdmin .le. -10000.0d0) crdsiz = 8 if (crdmax .ge. 100000.0d0) crdsiz = 8 crdsiz = crdsiz + max(6,digits) size = 0 call numeral (crdsiz,crdc,size) if (digits .le. 6) then digc = '6 ' else if (digits .le. 8) then digc = '8' else digc = '10' end if c c write out the number of atoms and the title c if (ltitle .eq. 0) then fstr = '('//atmc//')' write (ivel,fstr(1:4)) n else fstr = '('//atmc//',2x,a)' write (ivel,fstr(1:9)) n,title(1:ltitle) end if c c write out the periodic cell lengths and angles c if (use_bounds) then fstr = '(1x,6f'//crdc//'.'//digc//')' write (ivel,fstr) xbox,ybox,zbox,alpha,beta,gamma end if c c write out the velocity components for each atom c fstr = '('//atmc//',2x,a3,3f'//crdc// & '.'//digc//',i6,8'//atmc//')' do i = 1, n k = n12(i) if (k .eq. 0) then write (ivel,fstr) i,name(i),(v(j,i),j=1,3),type(i) else write (ivel,fstr) i,name(i),(v(j,i),j=1,3),type(i), & (i12(j,i),j=1,k) end if end do c c close the output unit if opened by this routine c if (.not. opened) close (unit=ivel) return end c c c ################################################################# c ## ## c ## subroutine prtdcdv -- output of DCD velocity components ## c ## ## c ################################################################# c c c "prtdcdv" writes out a set of atomic velocity components to c a file in CHARMM DCD binary format compatible with the VMD c visualization software and other packages c c note the format used is based on the "dcdplugin.c" code from c the NAMD and VMD programs, and tutorial 4.1 from the software c package GENESIS: Generalized-Ensemble Simulation System c c variables and parameters: c c header type of data (CORD=coordinates, VELD=velocities) c nframe number of frames stored in the DCD file c nprev number of previous integration steps c ncrdsav frequency in steps for saving coordinate frames c nstep number of integration steps in the total run c nvelsav frequency of coordinate saves with velocity data c ndfree number of degrees of freedom for the system c nfixat number of fixed atoms for the system c usebox flag for periodic boundaries (1=true, 0=false) c use4d flag for 4D trajectory (1=true, 0=false) c usefq flag for fluctuating charges (1=true, 0=false) c merged result of merge without checks (1=true, 0=false) c vcharmm version of CHARMM software for compatibility c c in general a value of zero for any of the above indicates that c the particular feature is unused c c subroutine prtdcdv (idcd,first) use atoms use bound use boxes use files use moldyn use titles implicit none integer i,idcd integer zero,one integer nframe,nprev integer ncrdsav,nstep integer nvelsav,ndfree integer nfixat,usebox integer use4d,usefq integer merged,vcharmm integer ntitle real*4 tdelta logical opened,first character*4 header character*240 dcdfile c c c open the output unit if not already done c inquire (unit=idcd,opened=opened) if (.not. opened) then dcdfile = filename(1:leng)//'.dcdv' call version (dcdfile,'new') open (unit=idcd,file=dcdfile,form='unformatted',status='new') end if c c write header info along with title and number of atoms c if (first) then first = .false. zero = 0 one = 1 header = 'CORD' nframe = zero nprev = zero ncrdsav = one nstep = zero nvelsav = zero ndfree = zero nfixat = zero tdelta = 0.0 usebox = zero if (use_bounds) usebox = one use4d = zero usefq = zero merged = zero vcharmm = 24 ntitle = one write (idcd) header,nframe,nprev,ncrdsav,nstep, & nvelsav,zero,zero,ndfree,nfixat, & tdelta,usebox,use4d,usefq,merged, & zero,zero,zero,zero,zero,vcharmm write (idcd) ntitle,title(1:80) write (idcd) n end if c c append the lattice values based on header flag value c if (use_bounds) then write (idcd) xbox,gamma_cos,ybox,beta_cos,alpha_cos,zbox end if c c append the velocity components along each axis in turn c write (idcd) (real(v(1,i)),i=1,n) write (idcd) (real(v(2,i)),i=1,n) write (idcd) (real(v(3,i)),i=1,n) c c close the output unit if opened by this routine c if (.not. opened) close (unit=idcd) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine prtxyz -- output of XYZ atomic coordinates ## c ## ## c ############################################################### c c c "prtxyz" writes out a set of Cartesian atomic coordinates c to an external disk file in Tinker XYZ format c c subroutine prtxyz (ixyz) use atomid use atoms use bound use boxes use couple use files use inform use titles implicit none integer i,j,k,ixyz integer size,crdsiz real*8 crdmin,crdmax logical opened character*2 atmc character*2 crdc character*2 digc character*25 fstr character*240 xyzfile c c c open the output unit if not already done c inquire (unit=ixyz,opened=opened) if (.not. opened) then xyzfile = filename(1:leng)//'.xyz' call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') end if c c check for large systems needing extended formatting c atmc = 'i6' if (n .ge. 100000) atmc = 'i7' if (n .ge. 1000000) atmc = 'i8' crdmin = 0.0d0 crdmax = 0.0d0 do i = 1, n crdmin = min(crdmin,x(i),y(i),z(i)) crdmax = max(crdmax,x(i),y(i),z(i)) end do crdsiz = 6 if (crdmin .le. -1000.0d0) crdsiz = 7 if (crdmax .ge. 10000.0d0) crdsiz = 7 if (crdmin .le. -10000.0d0) crdsiz = 8 if (crdmax .ge. 100000.0d0) crdsiz = 8 crdsiz = crdsiz + max(6,digits) size = 0 call numeral (crdsiz,crdc,size) if (digits .le. 6) then digc = '6 ' else if (digits .le. 8) then digc = '8' else digc = '10' end if c c write out the number of atoms and the title c if (ltitle .eq. 0) then fstr = '('//atmc//')' write (ixyz,fstr(1:4)) n else fstr = '('//atmc//',2x,a)' write (ixyz,fstr(1:9)) n,title(1:ltitle) end if c c write out the periodic cell lengths and angles c if (use_bounds) then fstr = '(1x,6f'//crdc//'.'//digc//')' write (ixyz,fstr) xbox,ybox,zbox,alpha,beta,gamma end if c c write out the atomic coordinates for each atom c fstr = '('//atmc//',2x,a3,3f'//crdc// & '.'//digc//',i6,8'//atmc//')' do i = 1, n k = n12(i) if (k .eq. 0) then write (ixyz,fstr) i,name(i),x(i),y(i),z(i),type(i) else write (ixyz,fstr) i,name(i),x(i),y(i),z(i),type(i), & (i12(j,i),j=1,k) end if end do c c close the output unit if opened by this routine c if (.not. opened) close (unit=ixyz) return end c c c ############################################################### c ## ## c ## subroutine prtdcd -- output of DCD atomic coordinates ## c ## ## c ############################################################### c c c "prtdcd" writes out a set of Cartesian atomic coordinates to c a file in CHARMM DCD binary format compatible with the VMD c visualization software and other packages c c note the format used is based on the "dcdplugin.c" code from c the NAMD and VMD programs, and tutorial 4.1 from the software c package GENESIS: Generalized-Ensemble Simulation System c c variables and parameters: c c header type of data (CORD=coordinates, VELD=velocities) c nframe number of frames stored in the DCD file c nprev number of previous integration steps c ncrdsav frequency in steps for saving coordinate frames c nstep number of integration steps in the total run c nvelsav frequency of coordinate saves with velocity data c ndfree number of degrees of freedom for the system c nfixat number of fixed atoms for the system c usebox flag for periodic boundaries (1=true, 0=false) c use4d flag for 4D trajectory (1=true, 0=false) c usefq flag for fluctuating charges (1=true, 0=false) c merged result of merge without checks (1=true, 0=false) c vcharmm version of CHARMM software for compatibility c c in general a value of zero for any of the above indicates that c the particular feature is unused c c subroutine prtdcd (idcd,first) use atoms use bound use boxes use files use titles implicit none integer i,idcd integer zero,one integer nframe,nprev integer ncrdsav,nstep integer nvelsav,ndfree integer nfixat,usebox integer use4d,usefq integer merged,vcharmm integer ntitle real*4 tdelta logical opened,first character*4 header character*240 dcdfile c c c open the output unit if not already done c inquire (unit=idcd,opened=opened) if (.not. opened) then dcdfile = filename(1:leng)//'.dcd' call version (dcdfile,'new') open (unit=idcd,file=dcdfile,form='unformatted',status='new') end if c c write header info along with title and number of atoms c if (first) then first = .false. zero = 0 one = 1 header = 'CORD' nframe = zero nprev = zero ncrdsav = one nstep = zero nvelsav = zero ndfree = zero nfixat = zero tdelta = 0.0 usebox = zero if (use_bounds) usebox = one use4d = zero usefq = zero merged = zero vcharmm = 24 ntitle = one write (idcd) header,nframe,nprev,ncrdsav,nstep, & nvelsav,zero,zero,ndfree,nfixat, & tdelta,usebox,use4d,usefq,merged, & zero,zero,zero,zero,zero,vcharmm write (idcd) ntitle,title(1:80) write (idcd) n end if c c append the lattice values based on header flag value c if (use_bounds) then write (idcd) xbox,gamma_cos,ybox,beta_cos,alpha_cos,zbox end if c c append the atomic coordinates along each axis in turn c write (idcd) (real(x(i)),i=1,n) write (idcd) (real(y(i)),i=1,n) write (idcd) (real(z(i)),i=1,n) c c close the output unit if opened by this routine c if (.not. opened) close (unit=idcd) return end c c c ############################################################## c ## COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ############################################################### c ## ## c ## program pss -- Cartesian potential smoothing & search ## c ## ## c ############################################################### c c c "pss" implements the potential smoothing plus search method c for global optimization in Cartesian coordinate space with c local searches performed in Cartesian or torsional space c c literature reference: c c J. Kostrowicki and H. A. Scheraga, "Application of the Diffusion c Equation Method for Global Optimization to Oligopeptides", Journal c of Physical Chemistry, 96, 7442-7449 (1992) c c S. Nakamura, H. Hirose, M. Ikeguchi and J. Doi, "Conformational c Energy Minimization Using a Two-Stage Method", Journal of Physical c Chemistry, 99, 8374-8378 (1995) c c program pss use atoms use inform use iounit use omega use refer use tree use warp implicit none integer i,next,range integer start,stop real*8 minimum,grdmin real*8 srchmax,rms real*8 ratio,sigmoid logical exist,check logical use_forward logical use_cart logical use_tors character*1 answer character*1 formtyp character*240 record character*240 string c c c set up the structure, mechanics calculation and smoothing c call initial call getxyz use_smooth = .true. use_dem = .true. call mechanic iwrite = 0 c c get the number of points along the deformation schedule c nlevel = -1 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) nlevel 10 continue if (nlevel .lt. 0) then write (iout,20) 20 format (/,' Enter the Number of Steps for Smoothing Schedule', & ' [100] : ',$) read (input,30) nlevel 30 format (i10) if (nlevel .le. 0) nlevel = 100 end if c c decide whether to use forward smoothing of initial structure c use_forward = .true. call nextarg (answer,exist) if (.not. exist) then write (iout,40) 40 format (/,' Perform Forward Smoothing from Input Structure', & ' [Y] : ',$) read (input,50) record 50 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'N') use_forward = .false. c c get the functional form for the deformation schedule c formtyp = 'C' call nextarg (answer,exist) if (.not. exist) then write (iout,60) 60 format (/,' Use Quadratic, Cubic or Sigmoidal Schedule', & ' (Q [C] or S) : ',$) read (input,70) record 70 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Q') formtyp = answer if (answer .eq. 'S') formtyp = answer c c decide which type of local search procedure to use c use_cart = .false. use_tors = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,80) 80 format (/,' Local Search Type - Cartesian, Torsional or None', & ' (C T or [N]) : ',$) read (input,90) record 90 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'C') use_cart = .true. if (answer .eq. 'T') use_tors = .true. c c get the rotatable bonds for torsional local search c if (use_tors) then call makeint (0) call initrot call active end if c c get the number of eigenvectors to use for local search c if (use_cart .or. use_tors) then start = -1 stop = -1 call nextarg (string,exist) if (exist) read (string,*,err=100,end=100) start call nextarg (string,exist) if (exist) read (string,*,err=100,end=100) stop 100 continue if (stop .le. 0) then write (iout,110) 110 format (/,' Enter the Range of Local Search Directions', & ' (1=Highest Freq) : ',$) read (input,120) record 120 format (a240) read (record,*) start,stop range = abs(stop-start) start = min(start,stop) stop = start + range end if if (use_cart) stop = min(stop,3*n-6) if (use_tors) stop = min(stop,nomega) end if c c get the maximal smoothing level for use of local search c if (use_cart .or. use_tors) then srchmax = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=130,end=130) srchmax 130 continue if (srchmax .lt. 0.0d0) then write (iout,140) 140 format (/,' Enter the Largest Smoothing Level for', & ' Local Search [5.0] : ',$) read (input,150) srchmax 150 format (f20.0) if (srchmax .lt. 0.0d0) srchmax = 5.0d0 end if end if c c decide whether to use forward smoothing of initial structure c check = .false. if ((use_cart .or. use_tors) .and. .not.use_forward) then call nextarg (answer,exist) if (.not. exist) then write (iout,160) 160 format (/,' Restrict Local Search to Children of Input', & ' Structure [N] : ',$) read (input,170) record 170 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') check = .true. end if c c get the termination criterion as RMS gradient per atom c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=180,end=180) grdmin 180 continue if (grdmin .le. 0.0d0) then write (iout,190) 190 format (/,' Enter RMS Gradient per Atom Criterion', & ' [0.0001] : ',$) read (input,200) grdmin 200 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.0001d0 c c compute the smoothing levels for the desired protocol c do i = 0, nlevel ratio = 1.0d0 - dble(nlevel-i)/dble(nlevel) if (formtyp .eq. 'Q') then ilevel(i) = deform * ratio**2 else if (formtyp .eq. 'C') then ilevel(i) = deform * ratio**3 else if (formtyp .eq. 'S') then ilevel(i) = deform * sigmoid (12.0d0,ratio) end if end do c c perform forward PSS by looping over smoothed surfaces c if (use_forward) then do i = 0, nlevel-1 deform = ilevel(i) call makeref (1) iprint = 1 call localxyz (minimum,grdmin) call impose (n,xref,yref,zref,n,x,y,z,rms) call psswrite (i) write (iout,210) minimum,deform 210 format (/,' Final Function Value and Deformation :',2f15.4) end do end if c c perform PSS reversal by looping over smoothed surfaces c do i = nlevel, 0, -1 deform = ilevel(i) call makeref (1) iprint = 1 call localxyz (minimum,grdmin) call impose (n,xref,yref,zref,n,x,y,z,rms) if (i .eq. nlevel) etree = minimum if (deform .le. srchmax) then if (use_cart) then call modecart (start,stop,minimum,grdmin,check) else if (use_tors) then call modetors (start,stop,minimum,grdmin,check) end if end if if (use_forward) then call psswrite (2*nlevel-i) else call psswrite (nlevel-i) end if write (iout,220) minimum,deform 220 format (/,' Final Function Value and Deformation :',2f15.4) end do c c perform any final tasks before program exit c call final end c c c ############################################################# c ## ## c ## function pss1 -- energy and gradient values for PSS ## c ## ## c ############################################################# c c c "pss1" is a service routine that computes the energy c and gradient during PSS global optimization in Cartesian c coordinate space c c function pss1 (xx,g) use atoms implicit none integer i,nvar real*8 pss1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) c c c convert optimization parameters to atomic coordinates 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 c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute and store the energy and gradient c call gradient (e,derivs) pss1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, n nvar = nvar + 1 g(nvar) = derivs(1,i) nvar = nvar + 1 g(nvar) = derivs(2,i) nvar = nvar + 1 g(nvar) = derivs(3,i) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ########################################################## c ## ## c ## subroutine pss2 -- Hessian matrix values for PSS ## c ## ## c ########################################################## c c c "pss2" is a service routine that computes the sparse c matrix Hessian elements during PSS global optimization c in Cartesian coordinate space c c subroutine pss2 (mode,xx,h,hinit,hstop,hindex,hdiag) use atoms implicit none integer i,nvar integer hinit(*) integer hstop(*) integer hindex(*) real*8 xx(*) real*8 hdiag(*) real*8 h(*) character*4 mode c c c convert optimization parameters to atomic coordinates c if (mode .eq. 'NONE') return 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 c c compute and store the Hessian elements c call hessian (h,hinit,hstop,hindex,hdiag) return end c c c ############################################################### c ## ## c ## subroutine modecart -- Cartesian local search for PSS ## c ## ## c ############################################################### c c subroutine modecart (start,stop,minimum,grdmin,check) use atoms use iounit use omega use refer implicit none integer i,j,k,nfreq integer start,stop integer niter,nsearch real*8 minimum,grdmin real*8 minref,minbest real*8 eps,rms,size real*8, allocatable :: xbest(:) real*8, allocatable :: ybest(:) real*8, allocatable :: zbest(:) real*8, allocatable :: eigen(:) real*8, allocatable :: step(:,:) real*8, allocatable :: vects(:,:) logical done,check c c c store the current coordinates as the reference set c call makeref (1) c c set parameters related to the local search procedure c done = .false. eps = 0.0001d0 minref = minimum minbest = minimum niter = 0 c c perform dynamic allocation of some local arrays c nfreq = 3 * n allocate (xbest(n)) allocate (ybest(n)) allocate (zbest(n)) allocate (eigen(nfreq)) allocate (step(3,nfreq)) allocate (vects(nfreq,nfreq)) c c find local minimum along each of the steepest directions c do while (.not. done) niter = niter + 1 write (iout,10) niter,minref 10 format (/,' Cartesian Mode Search :',5x,'Iteration',i4, & 6x,'Energy',f12.4,/) call eigenxyz (eigen,vects) c c search both directions along each eigenvector in turn c nsearch = 0 do i = start, stop do k = 1, n j = 3*(k-1) size = 1.0d0 / sqrt(abs(eigen(3*n-i+1))) step(1,k) = size * vects(j+1,3*n-i+1) step(2,k) = size * vects(j+2,3*n-i+1) step(3,k) = size * vects(j+3,3*n-i+1) end do nsearch = nsearch + 1 call getref (1) call climbxyz (nsearch,minimum,step,grdmin,check) if (minimum .lt. minbest) then minbest = minimum do k = 1, n xbest(k) = x(k) ybest(k) = y(k) zbest(k) = z(k) end do end if do k = 1, n step(1,k) = -step(1,k) step(2,k) = -step(2,k) step(3,k) = -step(3,k) end do nsearch = nsearch + 1 call getref (1) call climbxyz (nsearch,minimum,step,grdmin,check) if (minimum .lt. minbest) then minbest = minimum do k = 1, n xbest(k) = x(k) ybest(k) = y(k) zbest(k) = z(k) end do end if end do c c check for convergence of the local search procedure c if (minbest .lt. minref-eps) then done = .false. minref = minbest call impose (n,xref,yref,zref,n,xbest,ybest,zbest,rms) do k = 1, n x(k) = xbest(k) y(k) = ybest(k) z(k) = zbest(k) end do call makeref (1) else done = .true. minimum = minref call getref (1) end if end do c c perform deallocation of some local arrays c deallocate (xbest) deallocate (ybest) deallocate (zbest) deallocate (eigen) deallocate (step) deallocate (vects) return end c c c ############################################################### c ## ## c ## subroutine modetors -- torsional local search for PSS ## c ## ## c ############################################################### c c subroutine modetors (start,stop,minimum,grdmin,check) use atoms use iounit use omega use refer implicit none integer i,k integer start,stop integer niter,nsearch real*8 minimum,grdmin real*8 minref,minbest real*8 eps,rms real*8, allocatable :: xbest(:) real*8, allocatable :: ybest(:) real*8, allocatable :: zbest(:) real*8, allocatable :: step(:) real*8, allocatable :: eigen(:) real*8, allocatable :: vects(:,:) logical done,check c c c store the current coordinates as the reference set c call makeref (1) c c set parameters related to the local search procedure c done = .false. eps = 0.0001d0 minref = minimum minbest = minimum niter = 0 c c perform dynamic allocation of some local arrays c allocate (xbest(n)) allocate (ybest(n)) allocate (zbest(n)) allocate (step(nomega)) allocate (eigen(nomega)) allocate (vects(nomega,nomega)) c c find local minimum along each of the steepest directions c do while (.not. done) niter = niter + 1 write (iout,10) niter,minref 10 format (/,' Torsional Mode Search :',5x,'Iteration',i4, & 6x,'Energy',f12.4,/) call makeint (0) call eigentor (eigen,vects) c c search both directions along each eigenvector in turn c nsearch = 0 do i = start, stop do k = 1, nomega step(k) = vects(k,nomega-i+1) end do nsearch = nsearch + 1 call climbtor (nsearch,minimum,step,grdmin,check) if (minimum .lt. minbest) then minbest = minimum do k = 1, n xbest(k) = x(k) ybest(k) = y(k) zbest(k) = z(k) end do end if do k = 1, nomega step(k) = -step(k) end do nsearch = nsearch + 1 call climbtor (nsearch,minimum,step,grdmin,check) if (minimum .lt. minbest) then minbest = minimum do k = 1, n xbest(k) = x(k) ybest(k) = y(k) zbest(k) = z(k) end do end if end do c c check for convergence of the local search procedure c if (minbest .lt. minref-eps) then done = .false. minref = minbest call impose (n,xref,yref,zref,n,xbest,ybest,zbest,rms) do k = 1, n x(k) = xbest(k) y(k) = ybest(k) z(k) = zbest(k) end do call makeref (1) else done = .true. minimum = minref call getref (1) end if end do c c perform deallocation of some local arrays c deallocate (xbest) deallocate (ybest) deallocate (zbest) deallocate (step) deallocate (eigen) deallocate (vects) return end c c c ############################################################### c ## ## c ## subroutine eigenxyz -- Cartesian Hessian eigenvectors ## c ## ## c ############################################################### c c subroutine eigenxyz (eigen,vects) use atoms use hescut implicit none integer i,j,k,nfreq,ihess integer, allocatable :: hindex(:) integer, allocatable :: hinit(:,:) integer, allocatable :: hstop(:,:) real*8 eigen(*) real*8, allocatable :: matrix(:) real*8, allocatable :: h(:) real*8 vects(3*n,*) real*8, allocatable :: hdiag(:,:) c c c perform dynamic allocation of some local arrays c nfreq = 3 * n allocate (hindex((nfreq*(nfreq-1))/2)) allocate (hinit(3,n)) allocate (hstop(3,n)) allocate (matrix((nfreq*(nfreq+1))/2)) allocate (h((nfreq*(nfreq-1))/2)) allocate (hdiag(3,n)) c c compute the Hessian matrix in Cartesian space c hesscut = 0.0d0 call hessian (h,hinit,hstop,hindex,hdiag) c c place Hessian elements into triangular form c ihess = 0 do i = 1, n do j = 1, 3 ihess = ihess + 1 matrix(ihess) = hdiag(j,i) do k = hinit(j,i), hstop(j,i) ihess = ihess + 1 matrix(ihess) = h(k) end do end do end do c c diagonalize the Hessian to obtain eigenvalues c call diagq (nfreq,nfreq,matrix,eigen,vects) c c perform deallocation of some local arrays c deallocate (hindex) deallocate (hinit) deallocate (hstop) deallocate (matrix) deallocate (h) deallocate (hdiag) return end c c c ############################################################### c ## ## c ## subroutine eigentor -- torsional Hessian eigenvectors ## c ## ## c ############################################################### c c subroutine eigentor (eigen,vects) use atoms use omega implicit none integer i,j,ihess real*8 eigen(*) real*8, allocatable :: matrix(:) real*8 vects(nomega,*) real*8, allocatable :: hrot(:,:) c c c perform dynamic allocation of some local arrays c allocate (matrix(nomega*(nomega+1)/2)) allocate (hrot(nomega,nomega)) c c compute the Hessian in torsional space c call hessrot ('FULL',hrot) c c place Hessian elements into triangular form c ihess = 0 do i = 1, nomega do j = i, nomega ihess = ihess + 1 matrix(ihess) = hrot(i,j) end do end do c c diagonalize the Hessian to obtain eigenvalues c call diagq (nomega,nomega,matrix,eigen,vects) c c perform deallocation of some local arrays c deallocate (matrix) deallocate (hrot) return end c c c ################################################################# c ## ## c ## subroutine climbxyz -- Cartesian local search direction ## c ## ## c ################################################################# c c subroutine climbxyz (nsearch,minimum,step,grdmin,check) use atoms use inform use iounit use refer implicit none integer maxstep parameter (maxstep=500) integer i,kstep integer nstep,nsearch real*8 minimum,grdmin real*8 parent real*8 energy,big real*8 step(3,*) real*8 estep(0:maxstep) logical done,check,keep c c c convert current reference coordinates to a Z-matrix c call getref (1) c c set the maximum number of steps and the step size c done = .false. keep = .true. iprint = 0 big = 1000000.0d0 minimum = big kstep = 0 nstep = 65 c c scan the search direction for a minimization candidate c do while (.not. done) if (kstep .ne. 0) then do i = 1, n x(i) = x(i) + step(1,i) y(i) = y(i) + step(2,i) z(i) = z(i) + step(3,i) end do end if estep(kstep) = energy () if (kstep .ge. 2) then if (estep(kstep) .lt. estep(kstep-2) .and. & estep(kstep-1) .lt. estep(kstep-2)) then done = .true. do i = 1, n x(i) = x(i) - step(1,i) y(i) = y(i) - step(2,i) z(i) = z(i) - step(3,i) end do call localxyz (minimum,grdmin) parent = minimum if (check) call chktree (parent,grdmin,keep) if (minimum .ge. -big) then if (check) then write (iout,10) nsearch,kstep-1,minimum,parent 10 format (4x,'Search Direction',i4,10x,'Step', & i6,10x,2f12.4) else write (iout,20) nsearch,kstep-1,minimum 20 format (4x,'Search Direction',i4,10x,'Step', & i6,10x,f12.4) end if else minimum = big write (iout,30) nsearch 30 format (4x,'Search Direction',i4,36x,'------') end if if (.not. keep) minimum = big end if end if if (kstep.ge.nstep .and. .not.done) then done = .true. write (iout,40) nsearch 40 format (4x,'Search Direction',i4,36x,'------') end if kstep = kstep + 1 end do return end c c c ################################################################# c ## ## c ## subroutine climbtor -- torsional local search direction ## c ## ## c ################################################################# c c subroutine climbtor (nsearch,minimum,step,grdmin,check) use inform use iounit use math use omega use zcoord implicit none integer maxstep parameter (maxstep=500) integer i,kstep integer nstep,nsearch real*8 minimum,grdmin real*8 parent real*8 energy,big,size real*8 step(*) real*8 estep(0:maxstep) logical done,check,keep c c c convert current reference coordinates to a Z-matrix c call getref (1) call makeint (0) c c set the maximum number of steps and the step size c done = .false. keep = .true. iprint = 0 big = 1000000.0d0 minimum = big kstep = 0 nstep = 65 size = 0.1d0 * radian do i = 1, nomega step(i) = size * step(i) end do c c scan the search direction for a minimization candidate c do while (.not. done) if (kstep .ne. 0) then do i = 1, nomega ztors(zline(i)) = ztors(zline(i)) + step(i) end do end if call makexyz estep(kstep) = energy () if (kstep .ge. 2) then if (estep(kstep) .lt. estep(kstep-2) .and. & estep(kstep-1) .lt. estep(kstep-2)) then done = .true. do i = 1, nomega ztors(zline(i)) = ztors(zline(i)) - step(i) end do call makexyz call localxyz (minimum,grdmin) parent = minimum if (check) call chktree (parent,grdmin,keep) if (minimum .ge. -big) then if (check) then write (iout,10) nsearch,kstep-1,minimum,parent 10 format (4x,'Search Direction',i4,10x,'Step', & i6,10x,2f12.4) else write (iout,20) nsearch,kstep-1,minimum 20 format (4x,'Search Direction',i4,10x,'Step', & i6,10x,f12.4) end if else minimum = big write (iout,30) nsearch 30 format (4x,'Search Direction',i4,36x,'------') end if if (.not. keep) minimum = big end if end if if (kstep.ge.nstep .and. .not.done) then done = .true. write (iout,40) nsearch 40 format (4x,'Search Direction',i4,36x,'------') end if kstep = kstep + 1 end do return end c c c ############################################################## c ## ## c ## subroutine localxyz -- PSS local search optimization ## c ## ## c ############################################################## c c c "localxyz" is used during the potential smoothing and search c procedure to perform a local optimization at the current c smoothing level c c subroutine localxyz (minimum,grdmin) use atoms use inform implicit none integer i,nvar real*8 minimum real*8 grdmin real*8 pss1 real*8, allocatable :: xx(:) logical oldverb character*6 mode character*6 method external pss1,pss2 external optsave c c c perform dynamic allocation of some local arrays c allocate (xx(3*n)) c c translate the coordinates of each atom c nvar = 0 do i = 1, n nvar = nvar + 1 xx(nvar) = x(i) nvar = nvar + 1 xx(nvar) = y(i) nvar = nvar + 1 xx(nvar) = z(i) end do c c make the call to the optimization routine c oldverb = verbose verbose = .false. mode = 'AUTO' method = 'AUTO' call tncg (mode,method,nvar,xx,minimum,grdmin, & pss1,pss2,optsave) verbose = oldverb c c untranslate the final coordinates for each atom 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 c c perform deallocation of some local arrays c deallocate (xx) return end c c c ############################################################## c ## ## c ## subroutine chktree -- check for legitimacy of branch ## c ## ## c ############################################################## c c c "chktree" tests a minimum energy structure to see if it c belongs to the correct progenitor in the existing map c c subroutine chktree (parent,grdmin,keep) use atoms use tree use warp implicit none integer i real*8 parent,grdmin real*8 deform0,eps real*8, allocatable :: x0(:) real*8, allocatable :: y0(:) real*8, allocatable :: z0(:) logical keep c c c perform dynamic allocation of some local arrays c allocate (x0(n)) allocate (y0(n)) allocate (z0(n)) c c store the current smoothing level and coordinates c deform0 = deform do i = 1, n x0(i) = x(i) y0(i) = y(i) z0(i) = z(i) end do c c forward smoothing optimizations back to highest level c do i = 1, nlevel if (deform .lt. ilevel(i)) then deform = ilevel(i) call localxyz (parent,grdmin) end if end do c c compare energy to reference value for this tree branch c eps = 1.0d-4 keep = .false. if (abs(parent-etree) .lt. eps) keep = .true. c c restore the original smoothing level and coordinates c deform = deform0 do i = 1, n x(i) = x0(i) y(i) = y0(i) z(i) = z0(i) end do c c perform deallocation of some local arrays c deallocate (x0) deallocate (y0) deallocate (z0) return end c c c ############################################################## c ## ## c ## subroutine psswrite -- output structures on PSS path ## c ## ## c ############################################################## c c subroutine psswrite (i) use files implicit none integer i,ixyz integer lext,freeunit character*7 ext character*240 xyzfile c c c write the coordinates of the current minimum to a file c lext = 3 call numeral (i,ext,lext) ixyz = freeunit () xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') call prtxyz (ixyz) close (unit=ixyz) return end c c c ############################################################## c ## COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ################################################################## c ## ## c ## program pssrigid -- smoothing & search over rigid bodies ## c ## ## c ################################################################## c c c "pssrigid" implements the potential smoothing plus search method c for global optimization for a set of rigid bodies c c literature reference: c c J. Kostrowicki and H. A. Scheraga, "Application of the Diffusion c Equation Method for Global Optimization to Oligopeptides", Journal c of Physical Chemistry, 96, 7442-7449 (1992) c c S. Nakamura, H. Hirose, M. Ikeguchi and J. Doi, "Conformational c Energy Minimization Using a Two-Stage Method", Journal of Physical c Chemistry, 99, 8374-8378 (1995) c c program pssrigid use atoms use files use group use inform use iounit use math use molcul use refer use rigid use warp implicit none integer i,j,k,ixyz integer nvar,lext integer npoint,neigen integer next,freeunit real*8 minimum,grdmin real*8 srchmax,rms real*8 pssrgd1,deform0 real*8 ratio,sigmoid real*8, allocatable :: xx(:) logical exist logical use_local character*1 answer character*7 ext character*240 xyzfile character*240 record character*240 string external pssrgd1 external optsave c c c set up the structure, mechanics calculation and smoothing c call initial call getxyz use_smooth = .true. use_dem = .true. call mechanic c c get rigid body coordinates and save the Cartesian coordinates c use_rigid = .true. call orient call makeref (1) c c set maximum deformation value and disable coordinate saves c deform0 = deform iwrite = 0 c c get the number of points along the deformation schedule c npoint = -1 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) npoint 10 continue if (npoint .lt. 0) then write (iout,20) 20 format (/,' Enter the Number of Steps for the PSS Schedule', & ' [100] : ',$) read (input,30) npoint 30 format (i10) if (npoint .le. 0) npoint = 100 end if c c decide whether to use the local search procedure c use_local = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,40) 40 format (/,' Use Local Search to Explore Each Smoothing Level', & ' [N] : ',$) read (input,50) record 50 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') use_local = .true. c c get the number of eigenvectors to use for the local search c if (use_local) then neigen = -1 call nextarg (string,exist) if (exist) read (string,*,err=60,end=60) neigen 60 continue if (neigen .le. 0) then nvar = 6 * (ngrp-1) write (iout,70) nvar 70 format (/,' Enter the Number of Directions for Local', & ' Search [',i2,'] : ',$) read (input,80) neigen 80 format (i10) if (neigen .gt. nvar) neigen = nvar end if end if c c get the maximal smoothing level for use of local search c if (use_local) then srchmax = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=90,end=90) srchmax 90 continue if (srchmax .lt. 0.0d0) then write (iout,100) 100 format (/,' Enter the Largest Smoothing Value for Local', & ' Search [5.0] : ',$) read (input,110) srchmax 110 format (f20.0) if (srchmax .lt. 0.0d0) srchmax = 5.0d0 end if end if c c get the termination criterion as RMS gradient per atom c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=120,end=120) grdmin 120 continue if (grdmin .le. 0.0d0) then write (iout,130) 130 format (/,' Enter RMS Gradient per Rigid Body Criterion', & ' [0.0001] : ',$) read (input,140) grdmin 140 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.0001d0 c c perform dynamic allocation of some local arrays c allocate (xx(6*ngrp)) c c perform PSS iteration by looping over smoothed surfaces c do k = 0, 2*npoint ratio = 1.0d0 - dble(abs(npoint-k))/dble(npoint) if (nmol .eq. 1) then deform = deform0 * ratio**3 else deform = deform0 * sigmoid (12.0d0,ratio) end if c c convert rigid body coordinates to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 xx(nvar) = rbc(j,i) end do end do c c make the call to the variable metric optimization routine c iprint = 1 call ocvm (nvar,xx,minimum,grdmin,pssrgd1,optsave) c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c use normal mode local search to explore adjacent minima c if (use_local) then if (deform.le.srchmax .and. k.ge.npoint) & call modergd (neigen,minimum,grdmin) end if c c write out final energy function value and smoothing level c write (iout,150) minimum,deform 150 format (/,' Final Function Value and Deformation :',2f15.4) c c get Cartesian coordinates and superimpose on reference c call rigidxyz if (igrp(1,1).eq.1 .and. igrp(2,ngrp).eq.n) & call impose (n,xref,yref,zref,n,x,y,z,rms) c c write the coordinates of the current minimum to a file c lext = 3 call numeral (k,ext,lext) ixyz = freeunit () xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') call prtxyz (ixyz) close (unit=ixyz) end do c c perform deallocation of some local arrays c deallocate (xx) c c perform any final tasks before program exit c call final end c c c ################################################################ c ## ## c ## function pssrgd1 -- energy and gradient values for PSS ## c ## ## c ################################################################ c c c "pssrgd1" is a service routine that computes the energy and c gradient during PSS global optimization over rigid bodies c c function pssrgd1 (xx,g) use group use math use rigid implicit none integer i,j,nvar real*8 pssrgd1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) c c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c perform dynamic allocation of some local arrays c allocate (derivs(6,ngrp)) c c compute and store the energy and gradient c call rigidxyz call gradrgd (e,derivs) pssrgd1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 g(nvar) = derivs(j,i) end do end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ############################################################### c ## ## c ## subroutine modergd -- local search for rigid body PSS ## c ## ## c ############################################################### c c subroutine modergd (neigen,minimum,grdmin) use group use iounit use rigid use sizes implicit none integer maxrgd parameter (maxrgd=6*maxgrp) integer i,j,k integer neigen,ndoi integer nvar,nsearch real*8 minimum,grdmin real*8 eps,minref,minbest real*8, allocatable :: step(:) real*8, allocatable :: eigen(:) real*8, allocatable :: rorig(:,:) real*8, allocatable :: rbest(:,:) real*8, allocatable :: vects(:,:) logical done c c c perform dynamic allocation of some local arrays c allocate (step(ngrp)) allocate (eigen(ngrp)) allocate (rorig(6,ngrp)) allocate (rbest(6,ngrp)) allocate (vects(6*ngrp,6*ngrp)) c c set parameters related to the local search procedure c done = .false. eps = 0.0001d0 minref = minimum minbest = minimum ndoi = 0 nvar = 6 * ngrp do i = 1, ngrp do j = 1, 6 rorig(j,i) = rbc(j,i) end do end do c c find local minimum along each of the steepest directions c do while (.not. done) ndoi = ndoi + 1 write (iout,10) ndoi,minref 10 format (/,' Normal Mode Search :',8x,'Iteration',i4, & 6x,'Energy',f12.4,/) call rigidxyz call eigenrgd (eigen,vects) c c search both directions along each eigenvector in turn c nsearch = 0 do i = 1, neigen do k = 1, nvar step(k) = vects(k,nvar-i+1) end do do k = 1, ngrp do j = 1, 6 rbc(j,k) = rorig(j,k) end do end do nsearch = nsearch + 1 call climbrgd (nsearch,minimum,step,grdmin) if (minimum .lt. minbest) then minbest = minimum do k = 1, ngrp do j = 1, 6 rbest(j,k) = rbc(j,k) end do end do end if do k = 1, nvar step(k) = -vects(k,nvar-i+1) end do do k = 1, ngrp do j = 1, 6 rbc(j,k) = rorig(j,k) end do end do nsearch = nsearch + 1 call climbrgd (nsearch,minimum,step,grdmin) if (minimum .lt. minbest) then minbest = minimum do k = 1, ngrp do j = 1, 6 rbest(j,k) = rbc(j,k) end do end do end if end do c c check for convergence of the local search procedure c if (minbest .lt. minref-eps) then done = .false. minref = minbest do k = 1, ngrp do j = 1, 6 rorig(j,k) = rbest(j,k) end do end do else done = .true. minimum = minref do k = 1, ngrp do j = 1, 6 rbc(j,k) = rorig(j,k) end do end do end if end do c c perform deallocation of some local arrays c deallocate (step) deallocate (eigen) deallocate (rorig) deallocate (rbest) deallocate (vects) return end c c c ################################################################ c ## ## c ## subroutine eigenrgd -- rigid body Hessian eigenvectors ## c ## ## c ################################################################ c c subroutine eigenrgd (eigen,vects) use atoms use group implicit none integer maxrgd parameter (maxrgd=6*maxgrp) integer i,j integer ihess,nvar real*8 vnorm real*8 eigen(*) real*8, allocatable :: matrix(:) real*8 vects(6*ngrp,*) real*8, allocatable :: hrigid(:,:) c c c perform dynamic allocation of some local arrays c allocate (matrix(6*ngrp*(6*ngrp+1)/2)) allocate (hrigid(6*ngrp,6*ngrp)) c c compute the Hessian for rigid body motion c call hessrgd (hrigid) c c place Hessian elements into triangular form c nvar = 6 * ngrp ihess = 0 do i = 1, nvar do j = i, nvar ihess = ihess + 1 matrix(ihess) = hrigid(i,j) end do end do c c diagonalize the Hessian to obtain eigenvalues c call diagq (nvar,nvar,matrix,eigen,vects) c c normalize the rigid body Hessian eigenvectors c do i = 1, nvar vnorm = 0.0d0 do j = 1, nvar vnorm = vnorm + vects(j,i)**2 end do vnorm = sqrt(vnorm) do j = 1, nvar vects(j,i) = vects(j,i) / vnorm end do end do c c perform deallocation of some local arrays c deallocate (matrix) deallocate (hrigid) return end c c c ################################################################ c ## ## c ## subroutine climbrgd -- minimum from a PSS local search ## c ## ## c ################################################################ c c subroutine climbrgd (nsearch,minimum,step,grdmin) use group use iounit use math use rigid implicit none integer maxstep parameter (maxstep=500) integer i,j,nsearch integer nvar,kstep,nstep real*8 minimum,grdmin real*8 big,energy,size real*8 estep(0:maxstep) real*8 step(*) logical done c c c set the maximum number of steps and the step size c done = .false. big = 100000.0d0 minimum = big kstep = 0 nstep = 65 c size = 0.1d0 size = 1.0d0 nvar = 6 * ngrp do i = 1, nvar step(i) = size * step(i) end do c c scan the search direction for a minimization candidate c do while (.not. done) if (kstep .ne. 0) then nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = rbc(j,i) + step(nvar) end do end do end if call rigidxyz estep(kstep) = energy () if (kstep.ge.2 .and. estep(kstep).le.10000.0d0) then if (estep(kstep) .lt. estep(kstep-2) .and. & estep(kstep-1) .lt. estep(kstep-2)) then done = .true. nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = rbc(j,i) - step(nvar) end do end do call rigidxyz call localrgd (minimum,grdmin) if (minimum .ge. -big) then write (iout,10) nsearch,kstep-1,minimum 10 format (4x,'Search Direction',i4,10x,'Step', & i6,10x,f12.4) else minimum = big write (iout,20) nsearch 20 format (4x,'Search Direction',i4,36x,'------') end if end if end if if (kstep.ge.nstep .and. .not.done) then done = .true. write (iout,30) nsearch 30 format (4x,'Search Direction',i4,36x,'------') end if kstep = kstep + 1 end do return end c c c ############################################################## c ## ## c ## subroutine localrgd -- PSS local search optimization ## c ## ## c ############################################################## c c c "localrgd" is used during the PSS local search procedure c to perform a rigid body energy minimization c c subroutine localrgd (minimum,grdmin) use inform use group use minima use rigid implicit none integer i,j,nvar integer oldprt real*8 minimum real*8 grdmin real*8 pssrgd1 real*8, allocatable :: xx(:) logical oldverb external pssrgd1 external optsave c c c perform dynamic allocation of some local arrays c allocate (xx(6*ngrp)) c c convert rigid body coordinates to optimization parameters c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 xx(nvar) = rbc(j,i) end do end do c c make the call to the optimization routine c oldverb = verbose oldprt = iprint verbose = .false. iprint = 0 call ocvm (nvar,xx,minimum,grdmin,pssrgd1,optsave) verbose = oldverb iprint = oldprt c c convert optimization parameters to rigid body coordinates c nvar = 0 do i = 1, ngrp do j = 1, 6 nvar = nvar + 1 rbc(j,i) = xx(nvar) end do end do c c perform deallocation of some local arrays c deallocate (xx) return end c c c ############################################################## c ## COPYRIGHT (C) 1997 by Rohit Pappu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ################################################################## c ## ## c ## program pssrot -- torsional potential smoothing & search ## c ## ## c ################################################################## c c c "pssrot" implements the potential smoothing plus search method c for global optimization in torsional space c c literature reference: c c J. Kostrowicki and H. A. Scheraga, "Application of the Diffusion c Equation Method for Global Optimization to Oligopeptides", Journal c of Physical Chemistry, 96, 7442-7449 (1992) c c S. Nakamura, H. Hirose, M. Ikeguchi and J. Doi, "Conformational c Energy Minimization Using a Two-Stage Method", Journal of Physical c Chemistry, 99, 8374-8378 (1995) c c program pssrot use atoms use files use inform use iounit use math use omega use refer use warp use zcoord implicit none integer i,k integer ixyz,next integer npoint,neigen integer lext,freeunit real*8 minimum,grdmin real*8 pssrot1,rms real*8 srchmax real*8 deform0,ratio real*8, allocatable :: xx(:) logical exist logical use_local character*1 answer character*7 ext character*240 xyzfile character*240 record character*240 string external pssrot1 external optsave c c c set up the structure, mechanics calculation and smoothing c call initial call getint use_smooth = .true. use_dem = .true. call mechanic call initrot c c convert to Cartesian coordinates and save the initial set c call makexyz call makeref (1) c c set maximum deformation value and disable coordinate saves c deform0 = deform iwrite = 0 c c get the number of points along the deformation schedule c npoint = -1 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) npoint 10 continue if (npoint .lt. 0) then write (iout,20) 20 format (/,' Enter the Number of Steps for the PSS Schedule', & ' [100] : ',$) read (input,30) npoint 30 format (i10) if (npoint .le. 0) npoint = 100 end if c c decide whether to use the local search procedure c use_local = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,40) 40 format (/,' Use Local Search to Explore the Smoothing Levels', & ' [N] : ',$) read (input,50) record 50 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') use_local = .true. c c get the number of eigenvectors to use for the local search c if (use_local) then neigen = -1 call nextarg (string,exist) if (exist) read (string,*,err=60,end=60) neigen 60 continue if (neigen .le. 0) then write (iout,70) 70 format (/,' Enter the Number of Directions for Local', & ' Search [5] : ',$) read (input,80) neigen 80 format (i10) if (neigen .le. 0) neigen = 5 end if end if c c get the maximal smoothing level for use of local search c if (use_local) then srchmax = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=90,end=90) srchmax 90 continue if (srchmax .lt. 0.0d0) then write (iout,100) 100 format (/,' Enter the Largest Smoothing Value for Local', & ' Search [5.0] : ',$) read (input,110) srchmax 110 format (f20.0) if (srchmax .lt. 0.0d0) srchmax = 5.0d0 end if end if c c get the termination criterion as RMS gradient per atom c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=120,end=120) grdmin 120 continue if (grdmin .le. 0.0d0) then write (iout,130) 130 format (/,' Enter RMS Gradient per Atom Criterion', & ' [0.0001] : ',$) read (input,140) grdmin 140 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.0001d0 c c perform dynamic allocation of some local arrays c allocate (xx(nomega)) c c perform PSS iteration by looping over smoothed surfaces c do k = 0, 2*npoint ratio = 1.0d0 - dble(abs(npoint-k))/dble(npoint) deform = deform0 * ratio**3 c c translate the initial coordinates c do i = 1, nomega xx(i) = dihed(i) end do c c make the call to the variable metric optimization routine c iprint = 1 call ocvm (nomega,xx,minimum,grdmin,pssrot1,optsave) c c untranslate the final coordinates for each atom c do i = 1, nomega dihed(i) = xx(i) ztors(zline(i)) = dihed(i) * radian end do c c use normal mode local search to explore adjacent minima c if (use_local) then if (k.ge.npoint .and. deform.le.srchmax) & call moderot (neigen,minimum,grdmin) end if c c write out final energy function value and smoothing level c write (iout,150) minimum,deform 150 format (/,' Final Function Value and Deformation :',2f15.4) c c get Cartesian coordinates and superimpose on reference c call makexyz call impose (n,xref,yref,zref,n,x,y,z,rms) c c write the coordinates of the current minimum to a file c lext = 3 call numeral (k,ext,lext) ixyz = freeunit () xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') call prtxyz (ixyz) close (unit=ixyz) end do c c perform deallocation of some local arrays c deallocate (xx) c c perform any final tasks before program exit c call final end c c c ################################################################ c ## ## c ## function pssrot1 -- energy and gradient values for PSS ## c ## ## c ################################################################ c c c "pssrot1" is a service routine that computes the energy and c gradient during PSS global optimization in torsional space c c function pssrot1 (xx,g) use math use omega use zcoord implicit none integer i real*8 pssrot1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:) c c c translate optimization variables into dihedrals c do i = 1, nomega dihed(i) = xx(i) ztors(zline(i)) = dihed(i) * radian end do c c perform dynamic allocation of some local arrays c allocate (derivs(nomega)) c c compute and store the energy and gradient c call makexyz call gradrot (e,derivs) pssrot1 = e c c store torsional gradient as optimization gradient c do i = 1, nomega g(i) = derivs(i) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ############################################################## c ## ## c ## subroutine moderot -- torsional local search for PSS ## c ## ## c ############################################################## c c subroutine moderot (neigen,minimum,grdmin) use iounit use math use omega use zcoord implicit none integer i,k,neigen integer ndoi,nsearch real*8 minimum,grdmin real*8 eps,minref,minbest real*8, allocatable :: step(:) real*8, allocatable :: eigen(:) real*8, allocatable :: zorig(:) real*8, allocatable :: zbest(:) real*8, allocatable :: vects(:,:) logical done c c c perform dynamic allocation of some local arrays c allocate (step(nomega)) allocate (eigen(nomega)) allocate (zorig(nomega)) allocate (zbest(nomega)) allocate (vects(nomega,nomega)) c c set parameters related to the local search procedure c done = .false. eps = 0.0001d0 minref = minimum minbest = minimum ndoi = 0 do k = 1, nomega zorig(k) = ztors(zline(k)) end do c c find local minimum along each of the steepest directions c do while (.not. done) ndoi = ndoi + 1 write (iout,10) ndoi,minref 10 format (/,' Torsional Mode Search :',5x,'Iteration',i4, & 6x,'Energy',f12.4,/) call makexyz call eigenrot (eigen,vects) c c search both directions along each eigenvector in turn c nsearch = 0 do i = 1, neigen do k = 1, nomega step(k) = vects(k,nomega-i+1) ztors(zline(k)) = zorig(k) end do nsearch = nsearch + 1 call climbrot (nsearch,minimum,step,grdmin) if (minimum .lt. minbest) then minbest = minimum do k = 1, nomega zbest(k) = ztors(zline(k)) end do end if do k = 1, nomega step(k) = -vects(k,nomega-i+1) ztors(zline(k)) = zorig(k) end do nsearch = nsearch + 1 call climbrot (nsearch,minimum,step,grdmin) if (minimum .lt. minbest) then minbest = minimum do k = 1, nomega zbest(k) = ztors(zline(k)) end do end if end do c c check for convergence of the local search procedure c if (minbest .lt. minref-eps) then done = .false. minref = minbest do k = 1, nomega zorig(k) = zbest(k) end do else done = .true. minimum = minref do k = 1, nomega dihed(k) = zorig(k) / radian ztors(zline(k)) = zorig(k) end do end if end do c c perform deallocation of some local arrays c deallocate (step) deallocate (eigen) deallocate (zorig) deallocate (zbest) deallocate (vects) return end c c c ############################################################### c ## ## c ## subroutine eigenrot -- torsional Hessian eigenvectors ## c ## ## c ############################################################### c c subroutine eigenrot (eigen,vects) use atoms use omega implicit none integer i,j,ihess real*8 eigen(*) real*8, allocatable :: matrix(:) real*8 vects(nomega,*) real*8, allocatable :: hrot(:,:) c c c perform dynamic allocation of some local arrays c allocate (matrix(nomega*(nomega+1)/2)) allocate (hrot(nomega,nomega)) c c compute the Hessian in torsional space c call hessrot ('FULL',hrot) c c place Hessian elements into triangular form c ihess = 0 do i = 1, nomega do j = i, nomega ihess = ihess + 1 matrix(ihess) = hrot(i,j) end do end do c c diagonalize the Hessian to obtain eigenvalues c call diagq (nomega,nomega,matrix,eigen,vects) c c perform deallocation of some local arrays c deallocate (matrix) deallocate (hrot) return end c c c ################################################################ c ## ## c ## subroutine climbrot -- minimum from a PSS local search ## c ## ## c ################################################################ c c subroutine climbrot (nsearch,minimum,step,grdmin) use iounit use math use omega use zcoord implicit none integer maxstep parameter (maxstep=500) integer i,nsearch integer kstep,nstep real*8 minimum,grdmin real*8 energy real*8 big,small,size real*8 estep(0:maxstep) real*8 step(*) logical done c c c set the maximum number of steps and the step size c done = .false. big = 1.0d10 small = -1.0d5 minimum = big kstep = 0 nstep = 65 size = 0.1d0 * radian do i = 1, nomega step(i) = size * step(i) end do c c scan the search direction for a minimization candidate c do while (.not. done) if (kstep .ne. 0) then do i = 1, nomega ztors(zline(i)) = ztors(zline(i)) + step(i) end do end if call makexyz estep(kstep) = energy () if (kstep .ge. 2) then if (estep(kstep) .lt. estep(kstep-2) .and. & estep(kstep-1) .lt. estep(kstep-2)) then done = .true. do i = 1, nomega ztors(zline(i)) = ztors(zline(i)) - step(i) end do call makexyz call localrot (minimum,grdmin) if (minimum .ge. small) then write (iout,10) nsearch,kstep-1,minimum 10 format (4x,'Search Direction',i4,10x,'Step', & i6,10x,f12.4) else minimum = big write (iout,20) nsearch 20 format (4x,'Search Direction',i4,36x,'------') end if end if end if if (kstep.ge.nstep .and. .not.done) then done = .true. write (iout,30) nsearch 30 format (4x,'Search Direction',i4,36x,'------') end if kstep = kstep + 1 end do return end c c c ############################################################## c ## ## c ## subroutine localrot -- PSS local search optimization ## c ## ## c ############################################################## c c c "localrot" is used during the PSS local search procedure c to perform a torsional space energy minimization c c subroutine localrot (minimum,grdmin) use inform use minima use math use omega use zcoord implicit none integer i,oldprt real*8 minimum real*8 grdmin real*8 pssrot1 real*8, allocatable :: xx(:) logical oldverb external pssrot1 external optsave c c c perform dynamic allocation of some local arrays c allocate (xx(nomega)) c c translate the coordinates of each atom c do i = 1, nomega dihed(i) = ztors(zline(i)) / radian xx(i) = dihed(i) end do c c make the call to the optimization routine c oldverb = verbose oldprt = iprint verbose = .false. iprint = 0 call ocvm (nomega,xx,minimum,grdmin,pssrot1,optsave) verbose = oldverb iprint = oldprt c c untranslate the final coordinates for each atom c do i = 1, nomega dihed(i) = xx(i) ztors(zline(i)) = dihed(i) * radian end do c c perform deallocation of some local arrays c deallocate (xx) return end c c c ################################################### c ## COPYRIGHT (C) 2012 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module ptable -- symbols and info for chemical elements ## c ## ## c ################################################################# c c c maxele maximum number of elements from periodic table c c atmass standard atomic weight for each chemical element c vdwrad van der Waals radius for each chemical element c covrad covalent radius for each chemical element c elemnt atomic symbol for each chemical element c c module ptable implicit none integer maxele parameter (maxele=112) real*8 atmass(maxele) real*8 vdwrad(maxele) real*8 covrad(maxele) character*3 elemnt(maxele) save end c c c ################################################################ c ## COPYRIGHT (C) 2009 by Chuanjie Wu and Jay William Ponder ## c ## All Rights Reserved ## c ################################################################ c c ################################################################## c ## ## c ## module qmstuf -- quantum data from Gaussian calculation ## c ## ## c ################################################################## c c c ngatom number of atoms in the QM data file c egau quantum mechanical (QM) total energy (kcal/mole) c gx x-coordinate of each atom in the QM data file c gy y-coordinate of each atom in the QM data file c gz z-coordinate of each atom in the QM data file c gfreq calculated vibrational frequencies from QM data c gforce force components on each atom from QM data c gh Hessian matrix elements from QM data c c module qmstuf implicit none integer ngatom real*8 egau real*8, allocatable :: gx(:) real*8, allocatable :: gy(:) real*8, allocatable :: gz(:) real*8, allocatable :: gfreq(:) real*8, allocatable :: gforce(:,:) real*8, allocatable :: gh(:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine qrfact -- rectangular matrix QR factorization ## c ## ## c ################################################################## c c c "qrfact" computes the QR factorization of an m by n matrix a c via Householder transformations with optional column pivoting; c the routine determines an orthogonal matrix q, a permutation c matrix p, and an upper trapezoidal matrix r with diagonal c elements of nonincreasing magnitude, such that a*p = q*r; the c Householder transformation for column k, k = 1,2,...,min(m,n), c is of the form: c c i - (1/u(k))*u*u(transpose) c c where u has zeros in the first k-1 positions c c arguments and variables: c c n number of columns in the "a" matrix c m number of rows in the "a" matrix c a on input contains the m by n matrix for which the QR c factorization is to be computed; on output the c strict upper trapezoidal part contains the strict c upper trapezoidal part of r, the lower trapezoidal c part contains a factored form of q c pivot logical flag governing use of pivoting c ipvt integer output array which defines the permutation c matrix p such that a*p = q*r; column j of p is c column ipvt(j) of the identity matrix c rdiag output vector of length n with diagonal elements of r c c subroutine qrfact (n,m,a,pivot,ipvt,rdiag) implicit none integer i,j,k integer m,n,minmn integer jmax,itemp integer ipvt(*) real*8 aknorm,temp real*8 rdiag(*) real*8, allocatable :: work(:) real*8 a(m,*) logical pivot c c c perform dynamic allocation of some local arrays c allocate (work(n)) c c initialize variables, and find the initial column norms c do j = 1, n temp = 0.0d0 do i = 1, m temp = temp + a(i,j)**2 end do rdiag(j) = sqrt(temp) work(j) = rdiag(j) if (pivot) ipvt(j) = j end do c c bring the column of largest norm into the pivot position c minmn = min(m,n) do k = 1, minmn if (pivot) then jmax = k do j = k, n if (rdiag(j) .gt. rdiag(jmax)) jmax = j end do if (jmax .ne. k) then do i = 1, m temp = a(i,k) a(i,k) = a(i,jmax) a(i,jmax) = temp end do rdiag(jmax) = rdiag(k) work(jmax) = work(k) itemp = ipvt(k) ipvt(k) = ipvt(jmax) ipvt(jmax) = itemp end if end if c c compute the Householder transformation to reduce the c k-th column of "a" to a multiple of the k-th unit vector c aknorm = 0.0d0 do i = k, m aknorm = aknorm + a(i,k)**2 end do aknorm = sqrt(aknorm) if (aknorm .ne. 0.0d0) then if (a(k,k) .lt. 0.0d0) aknorm = -aknorm do i = k, m a(i,k) = a(i,k) / aknorm end do a(k,k) = a(k,k) + 1.0d0 c c apply transform to remaining columns and update column norms c if (n .ge. k+1) then do j = k+1, n temp = 0.0d0 do i = k, m temp = temp + a(i,k)*a(i,j) end do temp = temp / a(k,k) do i = k, m a(i,j) = a(i,j) - temp*a(i,k) end do if (pivot .and. rdiag(j).ne.0.0d0) then temp = a(k,j) / rdiag(j) if (abs(temp) .lt. 1.0d0) then rdiag(j) = rdiag(j) * sqrt(1.0d0-temp**2) else temp = 0.0d0 do i = k+1, m temp = temp + a(i,j)**2 end do rdiag(j) = sqrt(temp) work(j) = rdiag(j) end if end if end do end if end if rdiag(k) = -aknorm end do c c perform deallocation of some local arrays c deallocate (work) return end c c c ################################################################# c ## ## c ## subroutine qrsolve -- triangular least squares solution ## c ## ## c ################################################################# c c c "qrsolve" solves a*x = b and d*x = 0 in the least squares sense; c used with routine "qrfact" to solve least squares problems c c arguments and variables: c c n number of rows and columns in the matrix r c np leading physical dimension of r in the calling program c r on input, an n by n array with the upper triangular c matrix r; on output the full triangle is unaltered, c and the strict lower triangle contains the transpose c of the strict upper triangular matrix s c ipvt vector of length n which defines the permutation c matrix p such that a*p = q*r; column j of p is c column ipvt(j) of the identity matrix c diag vector of length n containing the diagonal elements c of the matrix d c qtb vector of length n containing the first n elements c of the vector q(transpose)*b c x vector of length n containing the least squares c solution of the systems a*x = b and d*x = 0 c sdiag vector of length n containing the diagonal elements c of the upper triangular matrix s c xpvt vector of length n containing permuted (pivoted) c solution of the systems c c subroutine qrsolve (n,np,r,ipvt,diag,qtb,x,sdiag,xpvt) implicit none integer i,j,k,jj integer n,np,nsing integer ipvt(*) real*8 sine,cosine real*8 tangent real*8 cotangent real*8 qtbpj,temp real*8 diag(*) real*8 qtb(*) real*8 x(*) real*8 sdiag(*) real*8 xpvt(*) real*8 r(np,*) c c c copy r and (q transpose)*b to preserve input and initialize s; c in particular, save the diagonal elements of r in x c do j = 1, n-1 do k = j+1, n r(k,j) = r(j,k) end do end do do j = 1, n x(j) = r(j,j) xpvt(j) = qtb(j) end do c c eliminate the diagonal matrix d using a Givens rotation; c first, prepare the row of d to be eliminated, locating c the diagonal element from the QR factorization c do j = 1, n jj = ipvt(j) if (diag(jj) .ne. 0.0d0) then do k = j, n sdiag(k) = 0.0d0 end do sdiag(j) = diag(jj) c c transform to eliminate the row of d modify only one element c of (q transpose)*b beyond the first n, which is initially zero c qtbpj = 0.0d0 do k = j, n c c determine a Givens rotation which eliminates the c appropriate element in the current row of d c if (sdiag(k) .ne. 0.0d0) then if (abs(r(k,k)) .lt. abs(sdiag(k))) then cotangent = r(k,k) / sdiag(k) sine = 0.5d0 / sqrt(0.25d0+0.25d0*cotangent**2) cosine = sine * cotangent else tangent = sdiag(k) / r(k,k) cosine = 0.5d0 / sqrt(0.25d0+0.25d0*tangent**2) sine = cosine * tangent end if c c compute the modified diagonal element of r c and the modified element of ((q transpose)*b,0) c r(k,k) = cosine*r(k,k) + sine*sdiag(k) temp = cosine*xpvt(k) + sine*qtbpj qtbpj = -sine*xpvt(k) + cosine*qtbpj xpvt(k) = temp c c accumulate the tranformation in the row of s c if (n .ge. k+1) then do i = k+1, n temp = cosine*r(i,k) + sine*sdiag(i) sdiag(i) = -sine*r(i,k) + cosine*sdiag(i) r(i,k) = temp end do end if end if end do end if c c store the diagonal element of s and restore c the corresponding diagonal elements of r c sdiag(j) = r(j,j) r(j,j) = x(j) end do c c solve the triangular system for xpvt; if the system c is singular, then obtain a least squares solution c nsing = n do j = 1, n if (sdiag(j).eq.0.0d0 .and. nsing.eq.n) nsing = j - 1 if (nsing .lt. n) xpvt(j) = 0.0d0 end do if (nsing .ge. 1) then do k = 1, nsing j = nsing - k + 1 temp = 0.0d0 if (nsing .ge. j+1) then do i = j+1, nsing temp = temp + r(i,j)*xpvt(i) end do end if xpvt(j) = (xpvt(j)-temp) / sdiag(j) end do end if c c permute the components of xpvt back to components of x c do j = 1, n k = ipvt(j) x(k) = xpvt(j) end do return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine quatfit -- optimal rotation for superposition ## c ## ## c ################################################################## c c c "quatfit" uses a quaternion-based method to find the optimal c rotation to achieve the best fit superposition of two sets of c coordinates, assuming the centroids are already superimposed c c literature reference: c c S. K. Kearsley, "On the Orthogonal Transformation Used for c Structural Comparisons", Acta Crystallographica Section A, c 45, 208-210 (1989) c c adapted from an original program written by D. J. Heisterberg, c Ohio Supercomputer Center, Columbus, OH c c subroutine quatfit (n1,x1,y1,z1,n2,x2,y2,z2) use align implicit none integer i,i1,i2,n1,n2 real*8 weigh,xrot,yrot,zrot real*8 xxyx,xxyy,xxyz real*8 xyyx,xyyy,xyyz real*8 xzyx,xzyy,xzyz real*8 q(4),d(4) real*8 x1(*),x2(*) real*8 y1(*),y2(*) real*8 z1(*),z2(*) real*8 rot(3,3) real*8 c(4,4),v(4,4) c c c build the upper triangle of the quadratic form matrix c xxyx = 0.0d0 xxyy = 0.0d0 xxyz = 0.0d0 xyyx = 0.0d0 xyyy = 0.0d0 xyyz = 0.0d0 xzyx = 0.0d0 xzyy = 0.0d0 xzyz = 0.0d0 do i = 1, nfit i1 = ifit(1,i) i2 = ifit(2,i) weigh = wfit(i) xxyx = xxyx + weigh*x1(i1)*x2(i2) xxyy = xxyy + weigh*y1(i1)*x2(i2) xxyz = xxyz + weigh*z1(i1)*x2(i2) xyyx = xyyx + weigh*x1(i1)*y2(i2) xyyy = xyyy + weigh*y1(i1)*y2(i2) xyyz = xyyz + weigh*z1(i1)*y2(i2) xzyx = xzyx + weigh*x1(i1)*z2(i2) xzyy = xzyy + weigh*y1(i1)*z2(i2) xzyz = xzyz + weigh*z1(i1)*z2(i2) end do c(1,1) = xxyx + xyyy + xzyz c(1,2) = xzyy - xyyz c(2,2) = xxyx - xyyy - xzyz c(1,3) = xxyz - xzyx c(2,3) = xxyy + xyyx c(3,3) = xyyy - xzyz - xxyx c(1,4) = xyyx - xxyy c(2,4) = xzyx + xxyz c(3,4) = xyyz + xzyy c(4,4) = xzyz - xxyx - xyyy c c diagonalize the quadratic form matrix c call jacobi (4,c,d,v) c c extract the desired quaternion components c q(1) = v(1,4) q(2) = v(2,4) q(3) = v(3,4) q(4) = v(4,4) c c assemble rotation matrix that superimposes the molecules c rot(1,1) = q(1)**2 + q(2)**2 - q(3)**2 - q(4)**2 rot(2,1) = 2.0d0 * (q(2) * q(3) - q(1) * q(4)) rot(3,1) = 2.0d0 * (q(2) * q(4) + q(1) * q(3)) rot(1,2) = 2.0d0 * (q(3) * q(2) + q(1) * q(4)) rot(2,2) = q(1)**2 - q(2)**2 + q(3)**2 - q(4)**2 rot(3,2) = 2.0d0 * (q(3) * q(4) - q(1) * q(2)) rot(1,3) = 2.0d0 * (q(4) * q(2) - q(1) * q(3)) rot(2,3) = 2.0d0 * (q(4) * q(3) + q(1) * q(2)) rot(3,3) = q(1)**2 - q(2)**2 - q(3)**2 + q(4)**2 c c rotate second molecule to best fit with first molecule c do i = 1, n2 xrot = x2(i)*rot(1,1) + y2(i)*rot(1,2) + z2(i)*rot(1,3) yrot = x2(i)*rot(2,1) + y2(i)*rot(2,2) + z2(i)*rot(2,3) zrot = x2(i)*rot(3,1) + y2(i)*rot(3,2) + z2(i)*rot(3,3) x2(i) = xrot y2(i) = yrot z2(i) = zrot end do return end c c c ############################################################## c ## COPYRIGHT (C) 1995 by Yong Kong and Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ################################################################ c ## ## c ## program radial -- compute radial distribution function ## c ## ## c ################################################################ c c c "radial" finds the radial distribution function for a specified c pair of atom types via analysis of a set of coordinate frames c c program radial use argue use atomid use atoms use bound use boxes use files use inform use iounit use limits use math use molcul use potent implicit none integer i,j,k integer nframe,iframe integer iarc,next integer molj,molk integer numj,numk integer typej,typek integer start,stop integer step,skip integer nbin,bin integer, allocatable :: hist(:) real*8 xj,yj,zj real*8 dx,dy,dz real*8 rjk,rmax,width real*8 rlower,rupper real*8 factor,pairs real*8 volume,expect real*8, allocatable :: gr(:) real*8, allocatable :: gs(:) logical exist,query logical first,intramol character*1 answer character*3 namej,namek character*6 labelj,labelk 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 the unitcell parameters and number of molecules c call unitcell call molecule c c set cutoffs small to enforce use of minimum images c use_vdw = .true. use_charge = .false. use_dipole = .false. use_mpole = .false. use_ewald = .false. vdwcut = 0.01d0 call lattice 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 names of the atoms to be used in rdf computation c call nextarg (labelj,exist) call nextarg (labelk,exist) if (.not. exist) then write (iout,50) 50 format (/,' Enter 1st & 2nd Atom Names or Type Numbers : ',$) read (input,60) record 60 format (a240) next = 1 call gettext (record,labelj,next) call gettext (record,labelk,next) end if c c convert the labels to either atom names or type numbers c namej = ' ' typej = -1 read (labelj,*,err=70,end=70) typej 70 continue if (typej .le. 0) then next = 1 call gettext (labelj,namej,next) end if namek = ' ' typek = -1 read (labelk,*,err=80,end=80) typek 80 continue if (typek .le. 0) then next = 1 call gettext (labelk,namek,next) end if c c get maximum distance from input or minimum image convention c if (.not. use_bounds) then rmax = -1.0d0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=90,end=90) rmax query = .false. end if 90 continue if (query) then write (iout,100) 100 format (/,' Enter Maximum Distance to Accumulate', & ' [10.0 Ang] : ',$) read (input,110) rmax 110 format (f20.0) end if if (rmax .le. 0.0d0) rmax = 10.0d0 else if (octahedron) then rmax = (sqrt(3.0d0)/4.0d0) * xbox rmax = 0.95d0 * rmax else rmax = min(xbox2*beta_sin*gamma_sin,ybox2*gamma_sin, & zbox2*beta_sin) rmax = 0.95d0 * rmax end if c c get the desired width of the radial distance bins c width = -1.0d0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=120,end=120) width query = .false. end if 120 continue if (query) then write (iout,130) 130 format (/,' Enter Width of Distance Bins [0.01 Ang] : ',$) read (input,140) width 140 format (f20.0) end if if (width .le. 0.0d0) width = 0.01d0 c c decide whether to restrict to intermolecular atom pairs c intramol = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,150) 150 format (/,' Include Intramolecular Pairs in Distribution', & ' [N] : ',$) read (input,160) record 160 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') intramol = .true. 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,170) nframe 170 format (/,' Number of Coordinate Frames :',i14) c c set the number of distance bins to be accumulated c nbin = int(rmax/width) write (iout,180) nbin 180 format (' Number of Distance Bins :',i18) c c perform dynamic allocation of some local arrays c allocate (hist(nbin)) allocate (gr(nbin)) allocate (gs(nbin)) c c zero out the distance bins and distribution functions c do i = 1, nbin hist(i) = 0 gr(i) = 0.0d0 gs(i) = 0.0d0 end do c c get the archived coordinates for each frame in turn c write (iout,190) 190 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 (.not. abort) then nframe = nframe + 1 if (mod(nframe,100) .eq. 0) then write (iout,200) nframe 200 format (4x,'Processing Coordinate Frame',i13) end if do j = 1, n if (name(j).eq.namej .or. type(j).eq.typej) then xj = x(j) yj = y(j) zj = z(j) molj = molcule(j) do k = 1, n if (name(k).eq.namek .or. type(k).eq.typek) then if (j .ne. k) then molk = molcule(k) if (intramol .or. molj.ne.molk) then dx = x(k) - xj dy = y(k) - yj dz = z(k) - zj call image (dx,dy,dz) rjk = sqrt(dx*dx + dy*dy + dz*dz) bin = int(rjk/width) + 1 if (bin .le. nbin) & hist(bin) = hist(bin) + 1 end if end if end if end do end if end do end if end do c c ensure a valid frame is loaded and report total frames c if (abort) then rewind (unit=iarc) first = .true. call readcart (iarc,first) end if close (unit=iarc) if (mod(nframe,100) .ne. 0) then write (iout,210) nframe 210 format (4x,'Processing Coordinate Frame',i13) end if c c count the number of occurrences of each atom type c numj = 0 numk = 0 do i = 1, n if (name(i).eq.namej .or. type(i).eq.typej) numj = numj + 1 if (name(i).eq.namek .or. type(i).eq.typek) numk = numk + 1 end do c c normalize the distance bins to give radial distribution c if (numj.ne.0 .and. numk.ne.0) then factor = (4.0d0/3.0d0) * pi * dble(nframe) if (use_bounds) then pairs = dble(numj) * dble(numk) volume = (gamma_sin*gamma_term) * xbox * ybox * zbox if (octahedron) volume = 0.5d0 * volume if (dodecadron) volume = volume / root2 factor = factor * pairs / volume end if do i = 1, nbin rupper = dble(i) * width rlower = rupper - width expect = factor * (rupper**3 - rlower**3) gr(i) = dble(hist(i)) / expect end do end if c c find the 5th degree polynomial smoothed distribution function c if (nbin .ge. 5) then gs(1) = (69.0d0*gr(1) + 4.0d0*gr(2) - 6.0d0*gr(3) & + 4.0d0*gr(4) - gr(5)) / 70.0d0 gs(2) = (2.0d0*gr(1) + 27.0d0*gr(2) + 12.0d0*gr(3) & - 8.0d0*gr(4) + 2.0d0*gr(5)) / 35.0d0 do i = 3, nbin-2 gs(i) = (-3.0d0*gr(i-2) + 12.0d0*gr(i-1) + 17.0d0*gr(i) & + 12.0d0*gr(i+1) - 3.0d0*gr(i+2)) / 35.0d0 end do gs(nbin-1) = (2.0d0*gr(nbin-4) - 8.0d0*gr(nbin-3) & + 12.0d0*gr(nbin-2) + 27.0d0*gr(nbin-1) & + 2.0d0*gr(nbin)) / 35.0d0 gs(nbin) = (-gr(nbin-4) + 4.0d0*gr(nbin-3) - 6.0d0*gr(nbin-2) & + 4.0d0*gr(nbin-1) + 69.0d0*gr(nbin)) / 70.0d0 do i = 1, nbin gs(i) = max(0.0d0,gs(i)) end do end if c c output the final radial distribution function results c write (iout,220) labelj,labelk 220 format (/,' Pairwise Radial Distribution Function :' & //,7x,'First Name or Type : ',a6, & 5x,'Second Name or Type : ',a6) write (iout,230) 230 format (/,5x,'Bin',9x,'Counts',7x,'Distance',7x,'Raw g(r)', & 4x,'Smooth g(r)',/) do i = 1, nbin write (iout,240) i,hist(i),(dble(i)-0.5d0)*width,gr(i),gs(i) 240 format (i8,i15,3x,f12.4,3x,f12.4,3x,f12.4) end do c c perform deallocation of some local arrays c c deallocate (hist) c deallocate (gr) c deallocate (gs) 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 ## function random -- portable random number generator ## c ## ## c ############################################################# c c c "random" generates a random number on [0,1] via a long c period generator due to L'Ecuyer with Bays-Durham shuffle c c literature references: c c P. L'Ecuyer, Communications of the ACM, 31, 742-774 (1988) 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 7.1 c c function random () use inform use iounit use keys implicit none integer im1,ia1,iq1,ir1 integer im2,ia2,iq2,ir2 integer big,nshuffle integer imm1,ndiv real*8 factor parameter (im1=2147483563) parameter (ia1=40014) parameter (iq1=53668) parameter (ir1=12211) parameter (im2=2147483399) parameter (ia2=40692) parameter (iq2=52774) parameter (ir2=3791) parameter (big=141803398) parameter (nshuffle=32) parameter (imm1=im1-1) parameter (ndiv=1+imm1/nshuffle) parameter (factor=1.0d0/im1) integer i,k,iy,next integer seed,seed2 integer year,month,day integer hour,minute,second integer ishuffle(nshuffle) real*8 random logical first character*20 keyword character*240 record character*240 string save first save seed,seed2 save iy,ishuffle data first / .true. / c c c random number seed is first set to a big number, c then incremented by the seconds elapsed this decade c if (first) then first = .false. seed = big call calendar (year,month,day,hour,minute,second) year = mod(year,10) seed = seed + 32140800*year + 2678400*(month-1) seed = seed + 86400*(day-1) + 3600*hour seed = seed + 60*minute + second c c search the keywords for a random number seed c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:11) .eq. 'RANDOMSEED ') then string = record(next:240) read (string,*,err=10) seed seed = max(1,seed) end if 10 continue end do c c print the value used for the random number seed c if (verbose) then write (iout,20) seed 20 format (/,' Random Number Generator Initialized', & ' with SEED :',3x,i12) end if c c warm up and then load the shuffling table c seed2 = seed do i = nshuffle+8, 1, -1 k = seed / iq1 seed = ia1 * (seed-k*iq1) - k*ir1 if (seed .lt. 0) seed = seed + im1 if (i .le. nshuffle) ishuffle(i) = seed end do iy = ishuffle(1) end if c c get a new random number value each call c k = seed / iq1 seed = ia1*(seed-k*iq1) - k*ir1 if (seed .lt. 0) seed = seed + im1 k = seed2 / iq2 seed2 = ia2*(seed2-k*iq2) - k*ir2 if (seed2 .lt. 0) seed2 = seed2 + im2 i = 1 + iy/ndiv iy = ishuffle(i) - seed2 ishuffle(i) = seed if (iy .lt. 1) iy = iy + imm1 random = factor * iy c c print the value of the current random number c c if (debug) then c write (iout,30) random c 30 format (' RANDOM -- Random Number Value is',f12.8) c end if return end c c c ############################################################ c ## ## c ## function normal -- random number from normal curve ## c ## ## c ############################################################ c c c "normal" generates a random number from a normal Gaussian c distribution with a mean of zero and a variance of one c c function normal () use inform use iounit implicit none real*8 v1,v2,rsq real*8 factor,store real*8 normal,random logical compute external random save compute,store data compute / .true. / c c c get a pair of random values from the distribution c if (compute) then 10 continue v1 = 2.0d0*random() - 1.0d0 v2 = 2.0d0*random() - 1.0d0 rsq = v1**2 + v2**2 if (rsq .ge. 1.0d0) goto 10 factor = sqrt(-2.0d0*log(rsq)/rsq) store = v1 * factor normal = v2 * factor compute = .false. c c use the second random value computed at the last call c else normal = store compute = .true. end if c c print the value of the current random number c c if (debug) then c write (iout,20) normal c 20 format (' NORMAL -- Normal Random Number is',f12.8) c end if return end c c c ############################################################## c ## ## c ## subroutine ranvec -- unit vector in random direction ## c ## ## c ############################################################## c c c "ranvec" generates a unit vector in 3-dimensional c space with uniformly distributed random orientation c c literature references: c c G. Marsaglia, Ann. Math. Stat., 43, 645 (1972) c c R. C. Rapaport, The Art of Molecular Dynamics Simulation, c 2nd Edition, Cambridge University Press, 2004, Section 18.4 c c subroutine ranvec (vector) use inform use iounit implicit none real*8 x,y,s real*8 random real*8 vector(3) external random c c c get a pair of appropriate components in the plane c s = 2.0d0 do while (s .ge. 1.0d0) x = 2.0d0*random() - 1.0d0 y = 2.0d0*random() - 1.0d0 s = x**2 + y**2 end do c c construct the 3-dimensional random unit vector c vector(3) = 1.0d0 - 2.0d0*s s = 2.0d0 * sqrt(1.0d0 - s) vector(2) = s * y vector(1) = s * x c c print the components of the random unit vector c c if (debug) then c write (iout,10) vector(1),vector(2),vector(3) c 10 format (' RANVEC -- Unit Random Vector is',3f10.4) c end if return end c c c ############################################################## c ## ## c ## subroutine sphere -- uniform set of points on sphere ## c ## ## c ############################################################## c c c "sphere" finds a specified number of uniformly distributed c points on a sphere of unit radius centered at the origin c c literature reference: c c E. B. Saff and A. B. J. Kuijlaars, "Distributing Many c Points on a Sphere", The Mathematical Intelligencer, c 19, 5-11 (1997) c c subroutine sphere (ndot,dot) use math implicit none integer i,ndot real*8 theta,phi real*8 h,phiold real*8 tot,tot1 real*8 dot(3,*) c c c find spherical coordinates then convert to Cartesian c tot = dble(ndot) tot1 = dble(ndot-1) do i = 1, ndot h = -1.0d0 + 2.0d0*dble(i-1)/tot1 h = min(1.0d0,h) theta = acos(h) if (i.eq.1 .or. i.eq.ndot) then phi = 0.0d0 else phi = mod(phiold+3.6d0/sqrt(tot*(1.0d0-h*h)),2.0d0*pi) end if dot(1,i) = sin(theta) * cos(phi) dot(2,i) = sin(theta) * sin(phi) dot(3,i) = cos(theta) phiold = phi end do return end c c c ################################################################# c ## ## c ## subroutine wiggle -- random perturbation of coordinates ## c ## ## c ################################################################# c c c "wiggle" applies a small random perturbation of coordinates c to avoid numerical instability in geometric calculations for c linear, planar and other symmetric structures c c subroutine wiggle (nxyz,xyz,eps) implicit none integer i,nxyz real*8 eps real*8 vector(3) real*8 xyz(3,*) c c c apply a small perturbation to the position of each atom c do i = 1, nxyz call ranvec (vector) xyz(1,i) = xyz(1,i) + eps*vector(1) xyz(2,i) = xyz(2,i) + eps*vector(2) xyz(3,i) = xyz(3,i) + eps*vector(3) 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 rattle -- RATTLE distance constraint method ## c ## ## c ################################################################ c c c "rattle" implements the first portion of the RATTLE algorithm c by correcting atomic positions and half-step velocities to c maintain interatomic distance and absolute spatial constraints c c literature reference: c c H. C. Andersen, "RATTLE: A Velocity Version of the SHAKE c Algorithm for Molecular Dynamics Calculations", Journal of c Computational Physics, 52, 24-34 (1983) c c subroutine rattle (dt,xold,yold,zold) use atomid use atoms use freeze use group use inform use iounit use moldyn use usage implicit none integer i,j,k integer ia,ib,mode integer niter,maxiter integer start,stop real*8 dt,eps,sor real*8 xr,yr,zr real*8 xo,yo,zo real*8 xv,yv,zv real*8 dot,rma,rmb real*8 weigh,dist2 real*8 delta,term real*8 xterm,yterm,zterm real*8 xold(*) real*8 yold(*) real*8 zold(*) logical done logical, allocatable :: moved(:) logical, allocatable :: update(:) c c c perform dynamic allocation of some local arrays c allocate (moved(n)) allocate (update(n)) c c initialize the lists of atoms previously corrected c do i = 1, n if (use(i)) then moved(i) = .true. else moved(i) = .false. end if update(i) = .false. end do c c set the iteration counter, termination and tolerance c maxiter = 500 sor = 1.25d0 eps = rateps c c apply RATTLE to distances and half-step velocity values c niter = 0 done = .false. do while (.not.done .and. niter.lt.maxiter) niter = niter + 1 done = .true. do i = 1, nrat ia = irat(1,i) ib = irat(2,i) if (moved(ia) .or. moved(ib)) then xr = x(ib) - x(ia) yr = y(ib) - y(ia) zr = z(ib) - z(ia) if (ratimage(i)) call image (xr,yr,zr) dist2 = xr**2 + yr**2 + zr**2 delta = krat(i)**2 - dist2 if (abs(delta) .gt. eps) then done = .false. update(ia) = .true. update(ib) = .true. xo = xold(ib) - xold(ia) yo = yold(ib) - yold(ia) zo = zold(ib) - zold(ia) if (ratimage(i)) call image (xo,yo,zo) dot = xr*xo + yr*yo + zr*zo rma = 1.0d0 / mass(ia) rmb = 1.0d0 / mass(ib) term = 0.5d0 * sor * delta / ((rma+rmb) * dot) xterm = xo * term yterm = yo * term zterm = zo * term x(ia) = x(ia) - xterm*rma y(ia) = y(ia) - yterm*rma z(ia) = z(ia) - zterm*rma x(ib) = x(ib) + xterm*rmb y(ib) = y(ib) + yterm*rmb z(ib) = z(ib) + zterm*rmb rma = rma / dt rmb = rmb / dt v(1,ia) = v(1,ia) - xterm*rma v(2,ia) = v(2,ia) - yterm*rma v(3,ia) = v(3,ia) - zterm*rma v(1,ib) = v(1,ib) + xterm*rmb v(2,ib) = v(2,ib) + yterm*rmb v(3,ib) = v(3,ib) + zterm*rmb end if end if end do do i = 1, n moved(i) = update(i) update(i) = .false. end do end do c c perform deallocation of some local arrays c deallocate (moved) deallocate (update) c c write information on the number of iterations needed c if (niter .eq. maxiter) then write (iout,10) 10 format (/,' RATTLE -- Warning, Distance Constraints', & ' not Satisfied') call prterr call fatal else if (debug) then write (iout,20) niter 20 format (' RATTLE -- Distance Constraints met at',i6, & ' Iterations') end if c c apply group position and velocity constraints via exact reset c do i = 1, nratx ia = iratx(i) mode = kratx(i) xr = 0.0d0 yr = 0.0d0 zr = 0.0d0 xv = 0.0d0 yv = 0.0d0 zv = 0.0d0 start = igrp(1,ia) stop = igrp(2,ia) do j = start, stop k = kgrp(j) weigh = mass(k) / grpmass(ia) if (mode .gt. 2) then xr = xr + x(k)*weigh xv = xv + v(1,k)*weigh end if if (mode .gt. 1) then yr = yr + y(k)*weigh yv = yv + v(2,k)*weigh end if zr = zr + z(k)*weigh zv = zv + v(3,k)*weigh end do do j = start, stop k = kgrp(j) x(k) = x(k) - xr y(k) = y(k) - yr z(k) = z(k) - zr v(1,k) = v(1,k) - xv v(2,k) = v(2,k) - yv v(3,k) = v(3,k) - zv end do end do return end c c c ################################################################ c ## ## c ## subroutine rattle2 -- RATTLE atom velocity corrections ## c ## ## c ################################################################ c c c "rattle2" implements the second portion of the RATTLE algorithm c by correcting the full-step velocities in order to maintain c interatomic distance constraints c c subroutine rattle2 (dt) use atomid use atoms use freeze use group use inform use iounit use moldyn use units use usage use virial implicit none integer i,j,k integer ia,ib,mode integer niter,maxiter integer start,stop real*8 dt,eps,sor real*8 xr,yr,zr real*8 xv,yv,zv real*8 dot,rma,rmb real*8 weigh,vterm,term real*8 xterm,yterm,zterm real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy logical done logical, allocatable :: moved(:) logical, allocatable :: update(:) c c c perform dynamic allocation of some local arrays c allocate (moved(n)) allocate (update(n)) c c initialize the lists of atoms previously corrected c do i = 1, n if (use(i)) then moved(i) = .true. else moved(i) = .false. end if update(i) = .false. end do c c set the iteration counter, termination and tolerance c maxiter = 500 niter = 0 done = .false. sor = 1.25d0 eps = rateps / dt vterm = 2.0d0 / (dt*ekcal) c c apply the RATTLE algorithm to correct the velocities c do while (.not.done .and. niter.lt.maxiter) niter = niter + 1 done = .true. do i = 1, nrat ia = irat(1,i) ib = irat(2,i) if (moved(ia) .or. moved(ib)) then xr = x(ib) - x(ia) yr = y(ib) - y(ia) zr = z(ib) - z(ia) if (ratimage(i)) call image (xr,yr,zr) xv = v(1,ib) - v(1,ia) yv = v(2,ib) - v(2,ia) zv = v(3,ib) - v(3,ia) dot = xr*xv + yr*yv + zr*zv rma = 1.0d0 / mass(ia) rmb = 1.0d0 / mass(ib) term = -dot / ((rma+rmb) * krat(i)**2) if (abs(term) .gt. eps) then done = .false. update(ia) = .true. update(ib) = .true. term = sor * term xterm = xr * term yterm = yr * term zterm = zr * term v(1,ia) = v(1,ia) - xterm*rma v(2,ia) = v(2,ia) - yterm*rma v(3,ia) = v(3,ia) - zterm*rma v(1,ib) = v(1,ib) + xterm*rmb v(2,ib) = v(2,ib) + yterm*rmb v(3,ib) = v(3,ib) + zterm*rmb c c increment the internal virial tensor components c xterm = xterm * vterm yterm = yterm * vterm zterm = zterm * vterm vxx = xr * xterm vyx = yr * xterm vzx = zr * xterm vyy = yr * yterm vzy = zr * yterm vzz = zr * zterm 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 do i = 1, n moved(i) = update(i) update(i) = .false. end do end do c c perform deallocation of some local arrays c deallocate (moved) deallocate (update) c c write information on the number of iterations needed c if (niter .eq. maxiter) then write (iout,10) 10 format (/,' RATTLE2 -- Warning, Velocity Constraints', & ' not Satisfied') call prterr call fatal else if (debug) then write (iout,20) niter 20 format (' RATTLE2 -- Velocity Constraints met at',i6, & ' Iterations') end if c c apply any atom group velocity constraints via exact reset c do i = 1, nratx ia = iratx(i) mode = kratx(i) xv = 0.0d0 yv = 0.0d0 zv = 0.0d0 start = igrp(1,ia) stop = igrp(2,ia) do j = start, stop k = kgrp(j) weigh = mass(k) / grpmass(ia) if (mode .gt. 2) then xv = xv + v(1,k)*weigh end if if (mode .gt. 1) then yv = yv + v(2,k)*weigh end if zv = zv + v(3,k)*weigh end do do j = start, stop k = kgrp(j) v(1,k) = v(1,k) - xv v(2,k) = v(2,k) - yv v(3,k) = v(3,k) - zv end do end do return end c c c ############################################################## c ## ## c ## subroutine shake -- SHAKE distance constraint method ## c ## ## c ############################################################## c c c "shake" implements the SHAKE algorithm by correcting atomic c positions to maintain interatomic distance and absolute spatial c constraints c c literature reference: c c J. P. Ryckaert, G. Ciccotti and H. J. C. Berendsen, "Numerical c Integration of the Cartesian Equations of Motion of a System c with Constraints: Molecular Dynamics of n-Alkanes", Journal of c Computational Physics, 23, 327-341 (1977) c c subroutine shake (xold,yold,zold) use atomid use atoms use freeze use group use inform use iounit use usage implicit none integer i,j,k integer ia,ib,mode integer niter,maxiter integer start,stop real*8 eps,sor real*8 xr,yr,zr real*8 xo,yo,zo real*8 dot,rma,rmb real*8 weigh,dist2 real*8 delta,term real*8 xterm,yterm,zterm real*8 xold(*) real*8 yold(*) real*8 zold(*) logical done logical, allocatable :: moved(:) logical, allocatable :: update(:) c c c perform dynamic allocation of some local arrays c allocate (moved(n)) allocate (update(n)) c c initialize the lists of atoms previously corrected c do i = 1, n if (use(i)) then moved(i) = .true. else moved(i) = .false. end if update(i) = .false. end do c c set the iteration counter, termination and tolerance c maxiter = 500 sor = 1.25d0 eps = rateps c c apply SHAKE to adjust distances to constraint values c niter = 0 done = .false. do while (.not.done .and. niter.lt.maxiter) niter = niter + 1 done = .true. do i = 1, nrat ia = irat(1,i) ib = irat(2,i) if (moved(ia) .or. moved(ib)) then xr = x(ib) - x(ia) yr = y(ib) - y(ia) zr = z(ib) - z(ia) if (ratimage(i)) call image (xr,yr,zr) dist2 = xr**2 + yr**2 + zr**2 delta = krat(i)**2 - dist2 if (abs(delta) .gt. eps) then done = .false. update(ia) = .true. update(ib) = .true. xo = xold(ib) - xold(ia) yo = yold(ib) - yold(ia) zo = zold(ib) - zold(ia) if (ratimage(i)) call image (xo,yo,zo) dot = xr*xo + yr*yo + zr*zo rma = 1.0d0 / mass(ia) rmb = 1.0d0 / mass(ib) term = 0.5d0 * sor * delta / ((rma+rmb) * dot) xterm = xo * term yterm = yo * term zterm = zo * term x(ia) = x(ia) - xterm*rma y(ia) = y(ia) - yterm*rma z(ia) = z(ia) - zterm*rma x(ib) = x(ib) + xterm*rmb y(ib) = y(ib) + yterm*rmb z(ib) = z(ib) + zterm*rmb end if end if end do do i = 1, n moved(i) = update(i) update(i) = .false. end do end do c c perform deallocation of some local arrays c deallocate (moved) deallocate (update) c c write information on the number of iterations needed c if (niter .eq. maxiter) then write (iout,10) 10 format (/,' SHAKE -- Warning, Distance Constraints', & ' not Satisfied') call prterr call fatal else if (debug) then write (iout,20) niter 20 format (' SHAKE -- Distance Constraints met at',i6, & ' Iterations') end if c c apply any group position constraints via exact reset c do i = 1, nratx ia = iratx(i) mode = kratx(i) xr = 0.0d0 yr = 0.0d0 zr = 0.0d0 start = igrp(1,ia) stop = igrp(2,ia) do j = start, stop k = kgrp(j) weigh = mass(k) / grpmass(ia) if (mode .gt. 2) then xr = xr + x(k)*weigh end if if (mode .gt. 1) then yr = yr + y(k)*weigh end if zr = zr + z(k)*weigh end do do j = start, stop k = kgrp(j) x(k) = x(k) - xr y(k) = y(k) - yr z(k) = z(k) - zr end do end do return end c c c ############################################################### c ## ## c ## subroutine shake2 -- SHAKE gradient vector correction ## c ## ## c ############################################################### c c c "shake2" modifies the gradient to remove components along any c holonomic distance contraints using a variant of SHAKE c c literature reference: c c Y. Duan, S. Kumar, J. M. Rosenberg and P. A. Kollman, "Gradient c SHAKE: An Improved Method for Constrained Energy Minimization in c Macromolecular Simulations", Journal of Computational Chemistry, c 16, 1351-1356 (1995) c c subroutine shake2 (derivs) use atoms use freeze use inform use iounit use usage implicit none integer i,ia,ib integer niter,maxiter real*8 eps,sor real*8 xr,yr,zr real*8 xf,yf,zf real*8 dist2,delta,term real*8 xterm,yterm,zterm real*8 derivs(3,*) logical done logical, allocatable :: moved(:) logical, allocatable :: update(:) c c c perform dynamic allocation of some local arrays c allocate (moved(n)) allocate (update(n)) c c initialize the lists of atoms previously corrected c do i = 1, n if (use(i)) then moved(i) = .true. else moved(i) = .false. end if update(i) = .false. end do c c set the iteration counter, termination and tolerance c maxiter = 500 sor = 1.15d0 eps = rateps c c adjust the gradient to remove constraint components c niter = 0 done = .false. do while (.not.done .and. niter.lt.maxiter) niter = niter + 1 done = .true. do i = 1, nrat ia = irat(1,i) ib = irat(2,i) if (moved(ia) .or. moved(ib)) then xr = x(ib) - x(ia) yr = y(ib) - y(ia) zr = z(ib) - z(ia) if (ratimage(i)) call image (xr,yr,zr) dist2 = xr**2 + yr**2 + zr**2 xf = derivs(1,ib) - derivs(1,ia) yf = derivs(2,ib) - derivs(2,ia) zf = derivs(3,ib) - derivs(3,ia) delta = xr*xf + yr*yf + zr*zf if (abs(delta) .gt. eps) then done = .false. update(ia) = .true. update(ib) = .true. term = 0.5d0 * sor * delta / dist2 xterm = xr * term yterm = yr * term zterm = zr * term derivs(1,ia) = derivs(1,ia) + xterm derivs(2,ia) = derivs(2,ia) + yterm derivs(3,ia) = derivs(3,ia) + zterm derivs(1,ib) = derivs(1,ib) - xterm derivs(2,ib) = derivs(2,ib) - yterm derivs(3,ib) = derivs(3,ib) - zterm end if end if end do do i = 1, n moved(i) = update(i) update(i) = .false. end do end do c c perform deallocation of some local arrays c deallocate (moved) deallocate (update) c c write information on the number of iterations needed c if (niter .eq. maxiter) then write (iout,10) 10 format (/,' SHAKE2 -- Warning, Gradient Constraints', & ' not Satisfied') call prterr call fatal else if (debug) then write (iout,20) niter 20 format (' SHAKE2 -- Gradient Constraints met at',i6, & ' Iterations') end if return end c c c ################################################### c ## COPYRIGHT (C) 2022 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine readcart -- input of Cartesian coordinates ## c ## ## c ############################################################### c c c "readcart" gets a set of Cartesian coordinates from either c a formatted or binary disk file c c subroutine readcart (ixyz,first) use output implicit none integer ixyz logical first c c c get next coordinates set from formatted or binary file c if (archive) then call readxyz (ixyz) else if (binary) then call readdcd (ixyz,first) end if return end c c c ########################################################### c ## COPYRIGHT (C) 2022 by Zhi Wang & Jay William Ponder ## c ## All Rights Reserved ## c ########################################################### c c ############################################################### c ## ## c ## subroutine readdcd -- input of DCD coordinate archive ## c ## ## c ############################################################### c c c "readdcd" reads in a set of Cartesian coordinates from an c external disk file in CHARMM DCD binary format c c subroutine readdcd (idcd,first) use atoms use bound use boxes use files use inform use iounit use math use titles implicit none integer i,idcd integer blank integer nframe,nprev integer ncrdsav,nstep integer nvelsav,ndfree integer nfixat,usebox integer use4d,usefq integer merged,vcharmm integer ntitle real*4 tdelta real*4, allocatable :: xs(:) real*4, allocatable :: ys(:) real*4, allocatable :: zs(:) logical exist,opened logical first character*4 header character*80 info(10) character*240 dcdfile c c c open the input unit if it has not already been done c inquire (unit=idcd,opened=opened) if (.not. opened) then dcdfile = filename(1:leng)//'.dcd' call version (dcdfile,'old') inquire (file=dcdfile,exist=exist) if (exist) then open (unit=idcd,file=dcdfile,form='unformatted', & status='old') rewind (unit=idcd) else write (iout,10) 10 format (/,' READDCD -- Unable to Find the DCD', & ' Binary Archive File') call fatal end if end if c c read header info along with title and number of atoms c abort = .true. if (first) then first = .false. read (idcd,err=20,end=20) header,nframe,nprev,ncrdsav, & nstep,nvelsav,blank,blank,ndfree, & nfixat,tdelta,usebox,use4d,usefq, & merged,blank,blank,blank,blank, & blank,vcharmm read (idcd,err=20,end=20) ntitle,(info(i),i=1,ntitle) read (idcd,err=20,end=20) n if (usebox .eq. 1) use_bounds = .true. title(1:80) = info(1) end if c c quit if the binary DCD file was not parsed correctly c abort = .false. 20 continue if (abort) then write (iout,30) 30 format (/,' READDCD -- Error Reading Header from', & ' Binary DCD File') call fatal end if c c read the lattice values based on header flag value c abort = .true. if (use_bounds) then call unitcell read (idcd,err=40,end=60) xbox,gamma_cos,ybox,beta_cos, & alpha_cos,zbox alpha = 90.0d0 beta = 90.0d0 gamma = 90.0d0 if (alpha_cos .ne. 0.0d0) alpha = radian * acos(alpha_cos) if (beta_cos .ne. 0.0d0) beta = radian * acos(beta_cos) if (gamma_cos .ne. 0.0d0) gamma = radian * acos(gamma_cos) call lattice end if c c perform dynamic allocation of some local arrays c allocate (xs(n)) allocate (ys(n)) allocate (zs(n)) c c read the atomic coordinates along each axis in turn c abort = .true. read (idcd,err=40,end=60) (xs(i),i=1,n) read (idcd,err=40,end=40) (ys(i),i=1,n) read (idcd,err=40,end=40) (zs(i),i=1,n) c c quit if the binary DCD file was not parsed correctly c abort = .false. 40 continue if (abort) then write (iout,50) 50 format (/,' READDCD -- Error Reading Coordinates from', & ' Binary DCD File') call fatal end if c c copy the atomic coordinates into the current structure c do i = 1, n x(i) = dble(xs(i)) y(i) = dble(ys(i)) z(i) = dble(zs(i)) end do c c perform deallocation of some local arrays c 60 continue if (allocated(xs)) deallocate (xs) if (allocated(ys)) deallocate (ys) if (allocated(zs)) deallocate (zs) c c close the input unit if opened by this routine c if (.not. opened) close (unit=idcd) return end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine readdyn -- input of MD restart information ## c ## ## c ############################################################### c c c "readdyn" get the positions, velocities and accelerations c for a molecular dynamics restart from an external disk file c c subroutine readdyn (idyn) use atoms use boxes use files use group use iounit use mdstuf use moldyn use rgddyn implicit none integer i,idyn,ndyn logical exist,opened,quit character*240 dynfile character*240 record c c c open the input file if it has not already been done c inquire (unit=idyn,opened=opened) if (.not. opened) then dynfile = filename(1:leng)//'.dyn' call version (dynfile,'old') inquire (file=dynfile,exist=exist) if (exist) then open (unit=idyn,file=dynfile,status='old') rewind (unit=idyn) else write (iout,10) 10 format (/,' READDYN -- Unable to Find the Dynamics', & ' Restart File') call fatal end if end if c c initialize error handling during reading of the file c i = 0 quit = .true. c c get the number of atoms and check for consistency c read (idyn,20) 20 format () read (idyn,30) record 30 format (a240) read (record,*,err=240,end=240) ndyn if (ndyn .ne. n) then write (iout,40) 40 format (/,' READDYN -- Restart File has Incorrect', & ' Number of Atoms') call fatal end if c c get the periodic box edge lengths and angles c read (idyn,50) 50 format () read (idyn,60) record 60 format (a240) read (record,*,err=240,end=240) xbox,ybox,zbox read (idyn,70) record 70 format (a240) read (record,*,err=240,end=240) alpha,beta,gamma c c set the box volume and additional periodic box values c call lattice c c get rigid body positions, translational and angular velocities c if (integrate .eq. 'RIGIDBODY') then read (idyn,80) 80 format () do i = 1, n read (idyn,90) record 90 format (a240) read (record,*,err=240,end=240) x(i),y(i),z(i) end do read (idyn,100) 100 format () do i = 1, ngrp read (idyn,110) record 110 format (a240) read (record,*,err=240,end=240) vcm(1,i),vcm(2,i),vcm(3,i) end do read (idyn,120) 120 format () do i = 1, ngrp read (idyn,130) record 130 format (a240) read (record,*,err=240,end=240) wcm(1,i),wcm(2,i),wcm(3,i) end do read (idyn,140) 140 format () do i = 1, ngrp read (idyn,150) record 150 format (a240) read (record,*,err=240,end=240) lm(1,i),lm(2,i),lm(3,i) end do c c get the atomic positions, velocities and accelerations c else read (idyn,160) 160 format () do i = 1, n read (idyn,170) record 170 format (a240) read (record,*,err=240,end=240) x(i),y(i),z(i) end do read (idyn,180) 180 format () do i = 1, n read (idyn,190) record 190 format (a240) read (record,*,err=240,end=240) v(1,i),v(2,i),v(3,i) end do read (idyn,200) 200 format () do i = 1, n read (idyn,210) record 210 format (a240) read (record,*,err=240,end=240) a(1,i),a(2,i),a(3,i) end do read (idyn,220) 220 format () do i = 1, n read (idyn,230) record 230 format (a240) read (record,*,err=240,end=240) aalt(1,i),aalt(2,i), & aalt(3,i) end do end if quit = .false. 240 continue if (.not. opened) close (unit=idyn) c c report any error in reading the dynamics restart file c if (quit) then write (iout,250) i 250 format (/,' READDYN -- Error in Dynamics Restart', & ' File at Atom',i6) call fatal end if return end c c c ############################################################## c ## COPYRIGHT (C) 2008 by Chuanjie Wu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ############################################################## c ## ## c ## subroutine readgau -- read data from G09 output file ## c ## ## c ############################################################## c c c "readgau" reads an ab initio optimized structure, forces, c Hessian and frequencies from a Gaussian 09 output file c c subroutine readgau use ascii use iounit use qmstuf use units implicit none integer i,j integer igau,code integer ngfreq,nghess integer itmp,jtmp,ktmp integer length,next integer freeunit integer trimtext logical hasinputxyz logical hasmp2 logical exist real*8 xtmp,ytmp,ztmp real*8 frcunit,hessunit character*4 arcstart character*6 gname character*240 gaufile character*240 record character*240 string character*240 word c c c initialize some values prior to opening the log file c exist = .false. hasinputxyz = .false. ngatom = 0 ngfreq = 0 arcstart = '1'//char(backslash)//'1'//char(backslash) c c specify and open the Gaussian 09 output log file c call nextarg (gaufile,exist) if (exist) then inquire (file=gaufile,exist=exist) igau = freeunit() call basefile (gaufile) call suffix (gaufile,'log','old') inquire (file=gaufile,exist=exist) if (.not. exist) then call basefile (gaufile) call suffix (gaufile,'out','old') inquire (file=gaufile,exist=exist) end if end if do while (.not. exist) write (iout,10) 10 format (/,' Enter the Gaussian Output File Name : ',$) read (input,20) gaufile 20 format (a240) igau = freeunit () call basefile (gaufile) call suffix (gaufile,'log','old') inquire (file=gaufile,exist=exist) if (.not. exist) then call basefile (gaufile) call suffix (gaufile,'out','old') inquire (file=gaufile,exist=exist) end if end do c c scan the Gaussian output file to get the number of atoms c open (unit=igau,file=gaufile,status='old') rewind (unit=igau) c do while (.true. .and. .not.eof(igau)) do while (.true.) read (igau,30,err=70,end=70) record 30 format (a240) next = 1 string = record call trimhead (string) length = trimtext (string) call upcase (string) if (string(1:20) .eq. 'STANDARD ORIENTATION') then do i = 1, 4 read (igau,40,err=70,end=70) record 40 format (a240) end do i = 1 do while (.true.) read (igau,50,err=70,end=70) record 50 format (a240) read (record,*,err=60,end=60) itmp,jtmp,ktmp, & xtmp,ytmp,ztmp if (jtmp .le. 0) goto 60 i = i + 1 end do 60 continue ngatom = i - 1 end if end do 70 continue c c perform dynamic allocation of some global arrays c nghess = (3*ngatom*(3*ngatom+1)) / 2 if (.not. allocated(gx)) allocate (gx(ngatom)) if (.not. allocated(gy)) allocate (gy(ngatom)) if (.not. allocated(gz)) allocate (gz(ngatom)) if (.not. allocated(gfreq)) allocate (gfreq(3*ngatom)) if (.not. allocated(gforce)) allocate (gforce(3,ngatom)) if (.not. allocated(gh)) allocate (gh(nghess)) c c read structure, forces and frequencies from Gaussian output c rewind (unit=igau) c do while (.true. .and. .not.eof(igau)) do while (.true.) read (igau,80,err=220,end=220) record 80 format (a240) next = 1 string = record call trimhead (string) length = trimtext (string) call upcase (string) if (string(1:20) .eq. 'STANDARD ORIENTATION') then do i = 1, 4 read (igau,90,err=220,end=220) record 90 format (a240) end do i = 1 do while (.true.) read (igau,100,err=220,end=220) record 100 format (a240) read (record,*,err=110,end=110) itmp,jtmp,ktmp, & gx(i),gy(i),gz(i) if (jtmp .le. 0) goto 110 i = i + 1 end do 110 continue ngatom = i - 1 else if (string(37:58) .eq. 'FORCES (HARTREES/BOHR)') then read (igau,120,err=220,end=220) record 120 format (a240) read (igau,130,err=220,end=220) record 130 format (a240) frcunit = hartree / bohr do i = 1, ngatom gforce(1,i) = 0.0d0 gforce(2,i) = 0.0d0 gforce(3,i) = 0.0d0 read (igau,140,err=220,end=220) record 140 format (a240) read (record,*,err=150,end=150) itmp,jtmp,gforce(1,i), & gforce(2,i),gforce(3,i) do j = 1, 3 gforce(j,i) = frcunit * gforce(j,i) end do 150 continue end do else if (string(1:14) .eq. 'FREQUENCIES --') then gfreq(ngfreq+1) = 0.0d0 gfreq(ngfreq+2) = 0.0d0 gfreq(ngfreq+3) = 0.0d0 read (string(15:240),*,err=160,end=160) gfreq(ngfreq+1), & gfreq(ngfreq+2), & gfreq(ngfreq+3) 160 continue ngfreq = ngfreq + 3 c c read the Hessian from archive section at bottom of output c else if (string(1:4) .eq. arcstart) then itmp = 0 c do while (.true. .and. .not.eof(igau)) do while (.true.) if (next .gt. 73) then read (igau,170,err=220,end=220) record 170 format (a240) next = 1 end if call readgarc (igau,record,word,length,next) if (word(1:1) .eq. char(backslash)) itmp = itmp + 1 if (itmp.eq.16 .and. hasinputxyz) then do i = 1, ngatom do j = 1, 5 if (next .gt. 73) then read (igau,180,err=220,end=220) record 180 format (a240) next = 1 end if call readgarc (igau,record,word,length,next) if (j .eq. 1) read(word(1:length),*) gname if (j .eq. 2) read(word(1:length),*) gx(i) if (j .eq. 3) read(word(1:length),*) gy(i) if (j .eq. 4) read(word(1:length),*) gz(i) end do end do end if if (itmp.gt.16 .and. word(1:2).eq.'HF') then do i = 1, 2 if (next .gt. 73) then read (igau,190,err=220,end=220) record 190 format (a240) next = 1 end if call readgarc (igau,record,word,length,next) end do read (word(1:length),*) egau egau = hartree * egau else if (itmp.gt.16 .and. word(1:3).eq.'MP2') then hasmp2 = .true. do i = 1, 2 if (next .gt. 73) then read (igau,200,err=220,end=220) record 200 format (a240) next = 1 end if call readgarc (igau,record,word,length,next) end do read (word(1:length),*) egau egau = hartree * egau else if (word(1:5) .eq. 'NImag') then do i = 1, 4 call readgarc (igau,record,word,length,next) end do hessunit = hartree / bohr**2 do i = 1, nghess call readgarc (igau,record,word,length,next) read (word(1:length),*) gh(i) gh(i) = hessunit * gh(i) end do goto 220 end if code = ichar(word(1:1)) if (code .eq. atsign) goto 210 end do end if 210 continue end do 220 continue close (unit=igau) c c zero out the frequencies if none were in Gaussian output c if (ngfreq .eq. 0) then do i = 1, 3*ngatom gfreq(i) = 0.0d0 end do end if return end c c c ############################################################## c ## ## c ## subroutine readgarc -- read Gaussian archive section ## c ## ## c ############################################################## c c c "readgarc" reads data from Gaussian archive section; each c entry is terminated with a backslash symbol c c subroutine readgarc (igau,string,word,length,next) use ascii implicit none integer i,igau,code integer next,length character*1 letter character*240 word character*240 string c c c initialize some values prior to parsing the test string c length = 1 letter = ' ' do i = 1, 240 word(i:i) = ' ' end do c c attempt to read a text word entry from the input string c letter = string (next:next) code = ichar(letter) if (code.eq.backslash .or. code.eq.equal & .or. code.eq.space) then word(1:1) = letter next = next + 1 length = 1 return end if 10 continue do i = next, 75 if (code.eq.backslash .or. code.eq.equal & .or. code.eq.space) return if (next .gt. 70) then read (igau,20,err=30,end=30) string 20 format (a240) next = 1 goto 10 end if if (code .eq. comma) then next = next + 1 return end if if (code.eq.backslash .or. code.eq.equal & .or. code.eq.space) return word(length:length) = letter next = next + 1 letter = string(next:next) code = ichar(letter) length = length + 1 end do if (code .eq. atsign) then word(1:1) = letter length = 1 end if 30 continue return end c c c ################################################### c ## COPYRIGHT (C) 2008 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine readgdma -- input of GDMA multipole analysis ## c ## ## c ################################################################# c c c "readgdma" takes the Distributed Multipole Analysis (DMA) output c in spherical harmonics from the GDMA program and converts to c Cartesian multipoles in the global coordinate frame c c this version is compatible with the formatted output from c GDMA package developed by Anthony Stone; it also reads GDMA c output from Psi4 c c subroutine readgdma (idma) use atomid use atoms use dma use files use iounit use mpole use units implicit none integer i,j,k integer idma,next integer freeunit real*8 term logical exist,done logical opened logical use_bohr character*3 atmnam character*240 record character*240 dmafile c c c open the input file if it has not already been done c inquire (unit=idma,opened=opened) if (.not. opened) then dmafile = filename(1:leng)//'.dma' call version (dmafile,'old') inquire (file=dmafile,exist=exist) if (exist) then open (unit=idma,file=dmafile,status='old') rewind (unit=idma) else call nextarg (dmafile,exist) if (exist) then call basefile (dmafile) call suffix (dmafile,'dma','old') inquire (file=dmafile,exist=exist) end if do while (.not. exist) write (iout,10) 10 format (/,' Enter GDMA Output File Name : ',$) read (input,20) dmafile 20 format (a240) call basefile (dmafile) call suffix (dmafile,'dma','old') inquire (file=dmafile,exist=exist) end do end if end if c c first open and then read the GDMA output file c idma = freeunit () open (unit=idma,file=dmafile,status='old') c c count the number of atoms in the GDMA output file c i = 0 rewind (unit=idma) do while (.true.) read (idma,30,err=40,end=40) record 30 format (a240) if (record(12:14) .eq. 'x =') then i = i + 1 else if (record(1:16) .eq. 'Total multipoles') then goto 40 end if end do 40 continue n = i c c perform dynamic allocation of some global arrays c if (.not. allocated(mp)) allocate (mp(n)) if (.not. allocated(dpx)) allocate (dpx(n)) if (.not. allocated(dpy)) allocate (dpy(n)) if (.not. allocated(dpz)) allocate (dpz(n)) if (.not. allocated(q20)) allocate (q20(n)) if (.not. allocated(q21c)) allocate (q21c(n)) if (.not. allocated(q21s)) allocate (q21s(n)) if (.not. allocated(q22c)) allocate (q22c(n)) if (.not. allocated(q22s)) allocate (q22s(n)) c c zero out the atomic coordinates and DMA values c do i = 1, n x(i) = 0.0d0 y(i) = 0.0d0 z(i) = 0.0d0 mp(i) = 0.0d0 dpx(i) = 0.0d0 dpy(i) = 0.0d0 dpz(i) = 0.0d0 q20(i) = 0.0d0 q21c(i) = 0.0d0 q21s(i) = 0.0d0 q22c(i) = 0.0d0 q22s(i) = 0.0d0 end do c c get coordinates and multipoles from GDMA output file c i = 0 rewind (unit=idma) do while (.true.) read (idma,50,err=70,end=70) record 50 format (a240) if (i .ne. 0) call match1 (i,record) if (record(12:14) .eq. 'x =') then i = i + 1 next = 1 call gettext (record,name(i),next) read (record(15:24),*) x(i) read (record(30:39),*) y(i) read (record(45:54),*) z(i) read (idma,60,err=70,end=70) 60 format () else if (record(1:16) .eq. 'Total multipoles') then goto 70 end if end do 70 continue c c perform dynamic allocation of some global arrays c if (.not. allocated(rpole)) allocate (rpole(maxpole,n)) c c convert quadrupole from spherical harmonic to Cartesian c term = sqrt(0.75d0) do i = 1, n rpole(1,i) = mp(i) rpole(2,i) = dpx(i) rpole(3,i) = dpy(i) rpole(4,i) = dpz(i) rpole(5,i) = -0.5d0*q20(i) + term*q22c(i) rpole(6,i) = term*q22s(i) rpole(7,i) = term*q21c(i) rpole(8,i) = rpole(6,i) rpole(9,i) = -0.5d0*q20(i) - term*q22c(i) rpole(10,i) = term*q21s(i) rpole(11,i) = rpole(7,i) rpole(12,i) = rpole(10,i) rpole(13,i) = q20(i) end do c c check for GDMA coordinate values in atomic units c use_bohr = .false. rewind (unit=idma) do while (.true.) read (idma,80,err=90,end=90) record 80 format (a240) if (record(1:27) .eq. 'Positions and radii in bohr') then use_bohr = .true. goto 90 end if end do 90 continue c c convert coordinates from Bohrs to Angstroms if needed c if (use_bohr) then do i = 1, n x(i) = x(i) * bohr y(i) = y(i) * bohr z(i) = z(i) * bohr end do end if c c find atomic numbers in verbose GDMA output if available c done = .false. rewind (unit=idma) do while (.true.) read (idma,100,err=120,end=120) record 100 format (a240) if (record(1:16) .eq. 'Nuclear charges:') then k = min(n,20) read (record(17:240),*,err=120,end=120) (atomic(i),i=1,k) do while (k .ne. n) j = k + 1 k = min(n,k+20) read (idma,110,err=120,end=120) record 110 format (a240) read (record,*,err=120,end=120) (atomic(i),i=j,k) end do done = .true. end if end do 120 continue c c attempt to get atomic numbers from GDMA atom names c if (.not. done) then do i = 1, n atomic(i) = 0 atmnam = name(i) call upcase (atmnam) if (atmnam(1:2) .eq. 'SI') then atomic(i) = 14 else if (atmnam(1:2) .eq. 'CL') then atomic(i) = 17 else if (atmnam(1:2) .eq. 'BR') then atomic(i) = 35 else if (atmnam(1:1) .eq. 'H') then atomic(i) = 1 else if (atmnam(1:1) .eq. 'B') then atomic(i) = 5 else if (atmnam(1:1) .eq. 'C') then atomic(i) = 6 else if (atmnam(1:1) .eq. 'N') then atomic(i) = 7 else if (atmnam(1:1) .eq. 'O') then atomic(i) = 8 else if (atmnam(1:1) .eq. 'F') then atomic(i) = 9 else if (atmnam(1:1) .eq. 'P') then atomic(i) = 15 else if (atmnam(1:1) .eq. 'S') then atomic(i) = 16 else if (atmnam(1:1) .eq. 'I') then atomic(i) = 53 else read (atmnam,*,err=130,end=130) atomic(i) 130 continue end if end do end if c c print the global frame Cartesian atomic multipoles c write (iout,140) 140 format (/,' Global Frame Cartesian Multipole Moments :') do i = 1, n write (iout,150) i,name(i),atomic(i) 150 format (/,' Atom:',i8,9x,'Name:',3x,a3,7x,'Atomic Number:',i8) write (iout,160) x(i),y(i),z(i) 160 format (/,' Coordinates:',5x,3f15.6) write (iout,170) rpole(1,i) 170 format (/,' Charge:',10x,f15.5) write (iout,180) rpole(2,i),rpole(3,i),rpole(4,i) 180 format (' Dipole:',10x,3f15.5) write (iout,190) rpole(5,i) 190 format (' Quadrupole:',6x,f15.5) write (iout,200) rpole(8,i),rpole(9,i) 200 format (18x,2f15.5) write (iout,210) rpole(11,i),rpole(12,i),rpole(13,i) 210 format (18x,3f15.5) end do c c convert the dipole and quadrupole moments to Angstroms, c quadrupole divided by 3 for use as traceless values c do i = 1, n do k = 2, 4 rpole(k,i) = rpole(k,i) * bohr end do do k = 5, 13 rpole(k,i) = rpole(k,i) * bohr**2 / 3.0d0 end do end do c c close the GDMA multipole analysis output file c if (.not. opened) close (unit=idma) return end c c c ################################################################# c ## ## c ## subroutine match1 -- match first value from GDMA output ## c ## ## c ################################################################# c c c "match1" finds and stores the first multipole component found c on a line of output from Stone's GDMA program c c subroutine match1 (i,record) use dma implicit none integer i character*240 record c c c store first multipole components on a line of GDMA output c if (record(6:8) .eq. 'Q0 ') then read (record(13:23),*) mp(i) call match2 (i,record) else if (record(20:23) .eq. 'Q00 ') then read (record(26:36),*) mp(i) else if (record(20:23) .eq. 'Q10 ') then read (record(26:36),*) dpz(i) call match2 (i,record) else if (record(20:23) .eq. 'Q11c') then read (record(26:36),*) dpx(i) call match2 (i,record) else if (record(20:23) .eq. 'Q11s') then read (record(26:36),*) dpy(i) call match2 (i,record) else if (record(20:23) .eq. 'Q20 ') then read (record(26:36),*) q20(i) call match2 (i,record) else if (record(20:23) .eq. 'Q21c') then read (record(26:36),*) q21c(i) call match2 (i,record) else if (record(20:23) .eq. 'Q21s') then read (record(26:36),*) q21s(i) call match2 (i,record) else if (record(20:23) .eq. 'Q22c') then read (record(26:36),*) q22c(i) call match2 (i,record) else if (record(20:23) .eq. 'Q22s') then read (record(26:36),*) q22s(i) call match2 (i,record) end if return end c c c ################################################################## c ## ## c ## subroutine match2 -- match second value from GDMA output ## c ## ## c ################################################################## c c c "match2" finds and stores the second multipole component found c on a line of output from Stone's GDMA program c c subroutine match2 (i,record) use dma implicit none integer i character*240 record c c c store second multipole component on a line of GDMA output c if (record(29:31) .eq. 'Q1 ') then read (record(36:46),*) dpz(i) call match3 (i,record) else if (record(39:42) .eq. 'Q11c') then read (record(45:55),*) dpx(i) call match3 (i,record) else if (record(39:42) .eq. 'Q11s') then read (record(45:55),*) dpy(i) call match3 (i,record) else if (record(39:42) .eq. 'Q21c') then read (record(45:55),*) q21c(i) call match3 (i,record) else if (record(39:42) .eq. 'Q21s') then read (record(45:55),*) q21s(i) call match3 (i,record) else if (record(39:42) .eq. 'Q22c') then read (record(45:55),*) q22c(i) call match3 (i,record) else if (record(39:42) .eq. 'Q22s') then read (record(45:55),*) q22s(i) call match3 (i,record) end if return end c c c ################################################################# c ## ## c ## subroutine match3 -- match third value from GDMA output ## c ## ## c ################################################################# c c c "match3" finds and stores the third multipole component found c on a line of output from Stone's GDMA program c c subroutine match3 (i,record) use dma implicit none integer i character*240 record c c c store third multipole component on a line of GDMA output c if (record(52:54) .eq. 'Q2 ') then read (record(59:69),*) q20(i) else if (record(58:61) .eq. 'Q11s') then read (record(64:74),*) dpy(i) else if (record(58:61) .eq. 'Q21s') then read (record(64:74),*) q21s(i) else if (record(58:61) .eq. 'Q22c') then read (record(64:74),*) q22c(i) else if (record(58:61) .eq. 'Q22s') then read (record(64:74),*) q22s(i) 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 readint -- input of internal coordinates ## c ## ## c ############################################################# c c c "readint" gets a set of Z-matrix internal coordinates c from an external file c c subroutine readint (izmt) use atomid use atoms use files use inform use iounit use titles use zclose use zcoord implicit none integer i,j,izmt integer next,size integer first,last integer nexttext integer trimtext logical exist,opened logical quit character*240 intfile character*240 record character*240 string c c c initialize the total number of atoms in the system c n = 0 c c open the input file if it has not already been done c inquire (unit=izmt,opened=opened) if (.not. opened) then intfile = filename(1:leng)//'.int' open (unit=izmt,file=intfile,status='old') rewind (unit=izmt) call version (intfile,'old') inquire (file=intfile,exist=exist) if (exist) then open (unit=izmt,file=intfile,status='old') rewind (unit=izmt) else write (iout,10) 10 format (/,' READINT -- Unable to Find the Internal', & ' Coordinates File') call fatal end if end if c c read first line and return if already at end of file c quit = .false. abort = .true. size = 0 do while (size .eq. 0) read (izmt,20,err=70,end=70) record 20 format (a240) size = trimtext (record) end do abort = .false. quit = .true. c c parse the title line to get the number of atoms c i = 0 next = 1 call gettext (record,string,next) read (string,*,err=70,end=70) n c c extract the title and determine its length c string = record(next:240) first = nexttext (string) last = trimtext (string) if (last .eq. 0) then title = ' ' ltitle = 0 else title = string(first:last) ltitle = trimtext (title) end if c c check for too many total atoms in the file c if (n .le. 0) then write (iout,30) 30 format (/,' READINT -- The Coordinate File Does Not', & ' Contain Any Atoms') call fatal else if (n .gt. maxatm) then write (iout,40) maxatm 40 format (' READINT -- The Maximum of',i9,' Atoms', & ' has been Exceeded') call fatal end if c c initialize coordinates and connectivities for each atom c do i = 1, n tag(i) = 0 name(i) = ' ' zbond(i) = 0.0d0 zang(i) = 0.0d0 ztors(i) = 0.0d0 type(i) = 0 do j = 1, 4 iz(j,i) = 0 end do end do c c read the coordinates and connectivities for each atom c do i = 1, n next = 1 size = 0 do while (size .eq. 0) read (izmt,50,err=70,end=70) record 50 format (a240) size = trimtext (record) end do read (record,*,err=70,end=70) tag(i) call getword (record,name(i),next) string = record(next:240) read (string,*,err=60,end=60) type(i),iz(1,i),zbond(i), & iz(2,i),zang(i),iz(3,i), & ztors(i),iz(4,i) 60 continue end do quit = .false. 70 continue if (.not. opened) close (unit=izmt) c c an error occurred in reading the Z-matrix coordinates c if (quit) then write (iout,80) i 80 format (' READZ -- Error in Z-Matrix File at Atom',i9) call fatal end if c c read in any additional bonds to be added or deleted c nadd = 0 ndel = 0 read (izmt,90,err=130,end=130) 90 format () do i = 1, maxatm read (izmt,100,err=130,end=130) record 100 format (a240) read (record,*,err=110,end=110) (iadd(j,i),j=1,2) nadd = i end do 110 continue do i = 1, maxatm read (izmt,120,err=130,end=130) record 120 format (a240) read (record,*,err=130,end=130) (idel(j,i),j=1,2) ndel = i end do 130 continue return end c c c ################################################### c ## COPYRIGHT (C) 2024 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine readmbis -- input of MBIS multipole analysis ## c ## ## c ################################################################# c c c "readmbis" takes the Minimal Basis Iterative Stockholder (MBIS) c output as Cartesian multipoles from the Multiwfn program and c converts to Tinker format c c this version assumes Multiwfn was invoked using Frank Jensen's c MBIS method to compute atomic multipoles c c subroutine readmbis (ichg,imbis) use atomid use atoms use files use iounit use mpole use units implicit none integer i,j,k,next integer ichg,imbis integer freeunit logical exist,done logical openchg logical openmbis character*3 atmnam character*240 record character*240 string character*240 chgfile character*240 mbisfile c c c open the charge and coordinates file if not already done c inquire (unit=ichg,opened=openchg) if (.not. openchg) then chgfile = filename(1:leng)//'.chg' call version (chgfile,'old') inquire (file=chgfile,exist=exist) if (exist) then open (unit=ichg,file=chgfile,status='old') rewind (unit=ichg) else call nextarg (chgfile,exist) if (exist) then call basefile (chgfile) call suffix (chgfile,'chg','old') inquire (file=chgfile,exist=exist) end if do while (.not. exist) write (iout,10) 10 format (/,' Enter CHG Output File Name : ',$) read (input,20) chgfile 20 format (a240) call basefile (chgfile) call suffix (chgfile,'chg','old') inquire (file=chgfile,exist=exist) end do end if end if c c open the MBIS atomic multipole file if not already done c inquire (unit=imbis,opened=openmbis) if (.not. openmbis) then mbisfile = filename(1:leng)//'.mbis' call version (mbisfile,'old') inquire (file=mbisfile,exist=exist) if (exist) then open (unit=imbis,file=mbisfile,status='old') rewind (unit=imbis) else call nextarg (mbisfile,exist) if (exist) then call basefile (mbisfile) call suffix (mbisfile,'mbis_mpl','old') inquire (file=mbisfile,exist=exist) end if do while (.not. exist) write (iout,30) 30 format (/,' Enter MBIS Output File Name : ',$) read (input,40) mbisfile 40 format (a240) call basefile (mbisfile) call suffix (mbisfile,'mbis_mpl','old') inquire (file=mbisfile,exist=exist) end do end if end if c c first open and then read the charge output file c ichg = freeunit () open (unit=ichg,file=chgfile,status='old') rewind (unit=ichg) c c get the number of atoms and the atomic coordinates c i = 0 do while (.true.) read (ichg,50,err=60,end=60) record 50 format (a240) i = i + 1 next = 1 call gettext (record,name(i),next) string = record(next:240) read (string,*,err=60,end=60) x(i),y(i),z(i) end do 60 continue n = i c c perform dynamic allocation of some global arrays c if (.not. allocated(rpole)) allocate (rpole(maxpole,n)) c c now open and then read the MBIS output file c imbis = freeunit () open (unit=imbis,file=mbisfile,status='old') rewind (unit=imbis) c c get the atomic multipole values from MBIS output file c do while (.true.) read (imbis,70,err=110,end=110) record 70 format (a240) if (record(3:16) .eq. 'Atomic charges') then do i = 1, n read (imbis,80,err=110,end=110) record 80 format (a240) next = 1 call gettext (record,name(i),next) string = record(next:240) read (string,*,err=110,end=110) rpole(1,i) end do end if if (record(3:16) .eq. 'Atomic dipoles') then do i = 1, n read (imbis,90,err=110,end=110) record 90 format (a240) next = 1 call gettext (record,name(i),next) string = record(next:240) read (string,*,err=110,end=110) (rpole(j,i),j=2,4) end do end if if (record(3:31) .eq. 'Atomic quadrupoles, Traceless') then do i = 1, n read (imbis,100,err=110,end=110) record 100 format (a240) next = 1 call gettext (record,name(i),next) string = record(next:240) read (string,*,err=110,end=110) rpole(5,i),rpole(6,i), & rpole(7,i),rpole(9,i), & rpole(10,i),rpole(13,i) rpole(8,i) = rpole(6,i) rpole(11,i) = rpole(7,i) rpole(12,i) = rpole(10,i) end do end if end do 110 continue c c attempt to get atomic numbers from Multiwfn atom names c do i = 1, n atomic(i) = 0 atmnam = name(i) call upcase (atmnam) if (atmnam(1:2) .eq. 'SI') then atomic(i) = 14 else if (atmnam(1:2) .eq. 'CL') then atomic(i) = 17 else if (atmnam(1:2) .eq. 'BR') then atomic(i) = 35 else if (atmnam(1:1) .eq. 'H') then atomic(i) = 1 else if (atmnam(1:1) .eq. 'B') then atomic(i) = 5 else if (atmnam(1:1) .eq. 'C') then atomic(i) = 6 else if (atmnam(1:1) .eq. 'N') then atomic(i) = 7 else if (atmnam(1:1) .eq. 'O') then atomic(i) = 8 else if (atmnam(1:1) .eq. 'F') then atomic(i) = 9 else if (atmnam(1:1) .eq. 'P') then atomic(i) = 15 else if (atmnam(1:1) .eq. 'S') then atomic(i) = 16 else if (atmnam(1:1) .eq. 'I') then atomic(i) = 53 else read (atmnam,*,err=120,end=120) atomic(i) 120 continue end if end do c c print the global frame Cartesian atomic multipoles c write (iout,130) 130 format (/,' Global Frame Cartesian Multipole Moments :') do i = 1, n write (iout,140) i,name(i),atomic(i) 140 format (/,' Atom:',i8,9x,'Name:',3x,a3,7x,'Atomic Number:',i8) write (iout,150) x(i),y(i),z(i) 150 format (/,' Coordinates:',5x,3f15.6) write (iout,160) rpole(1,i) 160 format (/,' Charge:',10x,f15.5) write (iout,170) rpole(2,i),rpole(3,i),rpole(4,i) 170 format (' Dipole:',10x,3f15.5) write (iout,180) rpole(5,i) 180 format (' Quadrupole:',6x,f15.5) write (iout,190) rpole(8,i),rpole(9,i) 190 format (18x,2f15.5) write (iout,200) rpole(11,i),rpole(12,i),rpole(13,i) 200 format (18x,3f15.5) end do c c convert the dipole and quadrupole moments to Angstroms, c quadrupole divided by 3 for use as traceless values c do i = 1, n do k = 2, 4 rpole(k,i) = rpole(k,i) * bohr end do do k = 5, 13 rpole(k,i) = rpole(k,i) * bohr**2 / 3.0d0 end do end do c c close the MBIS multipole analysis output file c if (.not. openchg) close (unit=imbis) if (.not. openmbis) close (unit=imbis) return end c c c ################################################### c ## COPYRIGHT (C) 2012 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine readmol -- read in a MDL MOL format file ## c ## ## c ############################################################# c c c "readmol" gets a set of MDL MOL coordinates from c an external disk file c c subroutine readmol (imdl) use atomid use atoms use couple use files use iounit use ptable use titles implicit none integer i,j,ia,ib,imdl integer nbond integer trimtext logical exist,opened character*240 mdlfile c c c open the input file if it has not already been done c inquire (unit=imdl,opened=opened) if (.not. opened) then mdlfile = filename(1:leng)//'.mol' call version (mdlfile,'old') inquire (file=mdlfile,exist=exist) if (exist) then open (unit=imdl,file=mdlfile,status='old') rewind (unit=imdl) else write (iout,10) 10 format (/,' READMOL -- Unable to Find the Specified', & ' MDL MOL File') call fatal end if end if c c zero out the total number of atoms and of bonds c n = 0 nbond = 0 c c get title line and get the number of atoms and bonds c read (imdl,20) title 20 format (a240) ltitle = trimtext (title) read (imdl,30) 30 format (/) read (imdl,40) n,nbond 40 format (2i3) c c check for too few or too many total atoms in the file c if (n .le. 0) then write (iout,50) 50 format (/,' READMOL -- The Coordinate File Does Not', & ' Contain Any Atoms') call fatal else if (n .gt. maxatm) then write (iout,60) maxatm 60 format (/,' READMOL -- The Maximum of',i9,' Atoms', & ' has been Exceeded') call fatal end if c c read the atomic coordinates and atomic symbol c do i = 1, n read (imdl,70) x(i),y(i),z(i),name(i) 70 format (3f10.4,1x,a3) n12(i) = 0 end do c c read the bond list to get attached atom lists c do i = 1, nbond read (imdl,80) ia,ib 80 format (2i3) n12(ia) = n12(ia) + 1 i12(n12(ia),ia) = ib n12(ib) = n12(ib) + 1 i12(n12(ib),ib) = ia end do c c assign atom types from atomic number and connectivity c do i = 1, n type(i) = 0 do j = 1, maxele if (name(i) .eq. elemnt(j)) then type(i) = 10*j + n12(i) goto 90 end if end do 90 continue end do c c for each atom, sort its list of attached atoms c do i = 1, n call sort (n12(i),i12(1,i)) end do if (.not. opened) close (unit=imdl) return end c c c ################################################### c ## COPYRIGHT (C) 1995 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## subroutine readmol2 -- input of a Tripos MOL2 file ## c ## ## c ############################################################ c c c "readmol2" gets a set of Tripos MOL2 coordinates from an c external disk file c c subroutine readmol2 (imol2) use atomid use atoms use couple use files use iounit use ptable use titles implicit none integer i,j,k,m integer ia,ib,imol2 integer nbond,number integer next,trimtext logical exist,opened character*8 atmnam character*240 mol2file character*240 record character*240 string c c c open the input file if it has not already been done c inquire (unit=imol2,opened=opened) if (.not. opened) then mol2file = filename(1:leng)//'.mol2' call version (mol2file,'old') inquire (file=mol2file,exist=exist) if (exist) then open (unit=imol2,file=mol2file,status='old') rewind (unit=imol2) else write (iout,10) 10 format (/,' READMOL2 -- Unable to Find the TRIPOS', & ' MOL2 File') call fatal end if end if c c zero out the total number of atoms and of bonds c n = 0 nbond = 0 c c get title line and get the number of atoms and bonds c do while (.true.) read (imol2,20,err=50,end=50) record 20 format (a240) next = 1 call gettext (record,string,next) call upcase (string) if (string .eq. '@MOLECULE') then read (imol2,30) title 30 format (a240) ltitle = trimtext (title) read (imol2,40) record 40 format (a240) read (record,*) n,nbond goto 50 end if end do 50 continue c c check for too few or too many total atoms in the file c if (n .le. 0) then write (iout,60) 60 format (/,' READMOL2 -- The Coordinate File Does Not', & ' Contain Any Atoms') call fatal else if (n .gt. maxatm) then write (iout,70) maxatm 70 format (/,' READMOL2 -- The Maximum of',i9,' Atoms', & ' has been Exceeded') call fatal end if c c read the atom names and coordinates c do while (.true.) read (imol2,80,err=100,end=100) record 80 format (a240) next = 1 call gettext (record,string,next) call upcase (string) if (string .eq. '@ATOM') then do j = 1, n read (imol2,90) record 90 format (a240) read (record,*) number next = 1 call getword (record,atmnam,next) string = record(next:240) read (string,*) x(j),y(j),z(j) call getword (record,atmnam,next) name(j) = atmnam(1:3) do k = 1, 3 if (atmnam(k:k) .eq. '.') then do m = k, 3 name(j)(m:m) = ' ' end do end if end do end do goto 100 end if end do 100 continue c c read the bond list to get attached atom lists c do while (.true.) read (imol2,110,err=130,end=130) record 110 format (a240) next = 1 call gettext (record,string,next) call upcase (string) if (string .eq. '@BOND') then do j = 1, nbond read (imol2,120) record 120 format (a240) read (record,*) number,ia,ib n12(ia) = n12(ia) + 1 i12(n12(ia),ia) = ib n12(ib) = n12(ib) + 1 i12(n12(ib),ib) = ia end do goto 130 end if end do 130 continue c c assign atom types from atomic number and connectivity c do i = 1, n type(i) = 0 do j = 1, maxele if (name(i) .eq. elemnt(j)) then type(i) = 10*j + n12(i) goto 140 end if end do 140 continue end do c c for each atom, sort its list of attached atoms c do i = 1, n call sort (n12(i),i12(1,i)) end do if (.not. opened) close (unit=imol2) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine readpdb -- input of Protein Data Bank file ## c ## ## c ############################################################### c c c "readpdb" gets a set of Protein Data Bank coordinates c from an external disk file c c subroutine readpdb (ipdb) use files use inform use iounit use pdb use resdue use sequen use titles implicit none integer i,j,k,ipdb integer start,stop integer index,serial integer next,nxtlast integer residue,reslast integer trimtext real*8 xx,yy,zz logical exist,opened logical first character*1 chain,chnlast character*1 altloc character*1 insert,inslast character*1 letter character*1, allocatable :: chnatm(:) character*3 resname,atmsymb character*3 namelast character*4 atmname character*6 remark character*240 pdbfile character*240 record character*240 string save first data first / .true. / c c c open the input file if it has not already been done c inquire (unit=ipdb,opened=opened) if (.not. opened) then pdbfile = filename(1:leng)//'.pdb' call version (pdbfile,'old') inquire (file=pdbfile,exist=exist) if (exist) then open (unit=ipdb,file=pdbfile,status='old') rewind (unit=ipdb) else write (iout,10) 10 format (/,' READPDB -- Unable to Find the Protein', & ' Data Bank File') call fatal end if end if c c get alternate sites, chains and insertions to be used c if (first) call scanpdb (ipdb) c c initialize title, atom and residue counters and name c title = ' ' ltitle = 0 npdb = 0 nres = 0 reslast = maxres namelast = ' ' chnlast = ' ' c c perform dynamic allocation of some local arrays c allocate (chnatm(maxatm)) c c perform dynamic allocation of some global arrays c if (first) then first = .false. if (.not. allocated(resnum)) allocate (resnum(maxatm)) if (.not. allocated(resatm)) allocate (resatm(2,maxatm)) if (.not. allocated(xpdb)) allocate (xpdb(maxatm)) if (.not. allocated(ypdb)) allocate (ypdb(maxatm)) if (.not. allocated(zpdb)) allocate (zpdb(maxatm)) if (.not. allocated(pdbres)) allocate (pdbres(maxatm)) if (.not. allocated(pdbsym)) allocate (pdbsym(maxatm)) if (.not. allocated(pdbatm)) allocate (pdbatm(maxatm)) if (.not. allocated(pdbtyp)) allocate (pdbtyp(maxatm)) end if c c process individual atoms from the Protein Data Bank file c do while (.true.) read (ipdb,20,err=230,end=230) record 20 format (a240) remark = record(1:6) call upcase (remark) if (remark .eq. 'HEADER') then title = record(11:70) ltitle = trimtext (title) else if (remark .eq. 'TITLE ') then if (ltitle .eq. 0) then title = record(11:70) ltitle = trimtext (title) end if else if (remark .eq. 'ATOM ') then next = 7 call getnumb (record,serial,next) string = record(next+1:next+4) read (string,30) atmname 30 format (a4) call upcase (atmname) string = record(next+5:next+5) read (string,40) altloc 40 format (a1) string = record(next+6:next+8) read (string,50) resname 50 format (a3) call upcase (resname) string = record(next+10:next+10) read (string,60) chain 60 format (a1) next = next + 11 nxtlast = next call getnumb (record,residue,next) if (next .eq. nxtlast) then string = record(next:next+3) read (string,70) residue 70 format (i4) next = next + 4 end if string = record(next:next) read (string,80) insert 80 format (a1) string = record(next+1:240) read (string,*,err=90,end=90) xx,yy,zz goto 100 90 continue string = record(31:38) read (string,*) xx string = record(39:46) read (string,*) yy string = record(47:54) read (string,*) zz 100 continue next = 77 call getword (record,atmsymb,next) if (index(chnsym,chain) .eq. 0) goto 120 if (altloc.ne.' ' .and. altloc.ne.altsym) goto 120 if (insert.ne.' ' .and. index(instyp,insert).eq.0) goto 120 call fixpdb (resname,atmname) if (resname .eq. 'HOH') then remark = 'HETATM' else if (resname .eq. ' LI') then remark = 'HETATM' else if (resname .eq. ' F') then remark = 'HETATM' else if (resname .eq. ' NA') then remark = 'HETATM' else if (resname .eq. ' MG') then remark = 'HETATM' else if (resname .eq. ' CL') then remark = 'HETATM' else if (resname .eq. ' K') then remark = 'HETATM' else if (resname .eq. ' CA') then remark = 'HETATM' else if (resname .eq. ' FE') then remark = 'HETATM' else if (resname .eq. ' ZN') then remark = 'HETATM' else if (resname .eq. ' BR') then remark = 'HETATM' else if (resname .eq. ' I') then remark = 'HETATM' else if (residue.ne.reslast .or. resname.ne.namelast .or. & chain.ne.chnlast .or. insert.ne.inslast) then nres = nres + 1 reslast = residue namelast = resname chnlast = chain inslast = insert if (nres .gt. maxres) then write (iout,110) maxres 110 format (/,' READPDB -- The Maximum of',i6, & ' Residues has been Exceeded') call fatal end if nseq = nres seq(nseq) = resname end if npdb = npdb + 1 xpdb(npdb) = xx ypdb(npdb) = yy zpdb(npdb) = zz pdbtyp(npdb) = remark pdbatm(npdb) = atmname pdbsym(npdb) = atmsymb pdbres(npdb) = resname resnum(npdb) = nres if (resname .eq. 'HOH') resnum(npdb) = 0 chnatm(npdb) = chain 120 continue else if (remark .eq. 'HETATM') then next = 7 call getnumb (record,serial,next) string = record(next+1:next+4) read (string,130) atmname 130 format (a4) call upcase (atmname) string = record(next+5:next+5) read (string,140) altloc 140 format (a1) string = record(next+6:next+8) read (string,150) resname 150 format (a3) call upcase (resname) string = record(next+10:next+10) read (string,160) chain 160 format (a1) next = next + 11 call getnumb (record,residue,next) if (next .eq. nxtlast) then string = record(next:next+3) read (string,170) residue 170 format (i4) next = next + 4 end if string = record(next:next) read (string,180) insert 180 format (a1) string = record(next+1:240) read (string,*,err=190,end=190) xx,yy,zz goto 200 190 continue string = record(31:38) read (string,*) xx string = record(39:46) read (string,*) yy string = record(47:54) read (string,*) zz 200 continue next = 77 call getword (record,atmsymb,next) if (index(chnsym,chain) .eq. 0) goto 210 if (altloc.ne.' ' .and. altloc.ne.altsym) goto 210 if (insert.ne.' ' .and. index(instyp,insert).eq.0) goto 210 call fixpdb (resname,atmname) npdb = npdb + 1 xpdb(npdb) = xx ypdb(npdb) = yy zpdb(npdb) = zz pdbtyp(npdb) = remark pdbatm(npdb) = atmname pdbsym(npdb) = atmsymb pdbres(npdb) = resname resnum(npdb) = 0 chnatm(npdb) = chain 210 continue else if (remark .eq. 'ENDMDL') then goto 230 else if (remark .eq. 'END ') then goto 230 end if if (npdb .gt. maxatm) then write (iout,220) maxatm 220 format (/,' READPDB -- The Maximum of',i6, & ' Atoms has been Exceeded') call fatal end if end do 230 continue c c set the total sequence length and chain terminus sites c if (npdb .ne. 0) then nchain = 0 chnlast = '#' do i = 1, npdb if (pdbtyp(i) .eq. 'ATOM ') then letter = chnatm(i) if (letter .ne. chnlast) then nchain = nchain + 1 ichain(1,nchain) = resnum(i) chnnam(nchain) = letter chnlast = letter else ichain(2,nchain) = resnum(i) end if end if end do end if c c perform deallocation of some local arrays c deallocate (chnatm) c c find the type of species present in each chain c do i = 1, nchain start = ichain(1,i) stop = ichain(2,i) chntyp(i) = 'GENERIC' do j = start, stop do k = 1, maxamino if (seq(j) .eq. amino(k)) then chntyp(i) = 'PEPTIDE' goto 240 end if end do chntyp(i) = 'GENERIC' goto 250 240 continue end do 250 continue if (chntyp(i) .eq. 'GENERIC') then do j = start, stop do k = 1, maxnuc if (seq(j) .eq. nuclz(k)) then chntyp(i) = 'NUCLEIC' goto 260 end if end do chntyp(i) = 'GENERIC' goto 270 260 continue end do 270 continue end if end do c c get the three-letter sequence and code for each residue c do i = 1, nchain start = ichain(1,i) stop = ichain(2,i) do j = start, stop do k = 1, maxamino if (seq(j) .eq. amino(k)) then seqtyp(j) = k goto 280 end if end do do k = 1, maxnuc if (seq(j) .eq. nuclz(k)) then seqtyp(j) = k goto 280 end if end do seq(j) = 'UNK' seqtyp(j) = 0 if (chntyp(i) .eq. 'PEPTIDE') seqtyp(j) = maxamino if (chntyp(i) .eq. 'NUCLEIC') seqtyp(j) = maxnuc 280 continue end do end do c c set a pointer to the first and last atom of each residue c nres = 0 k = 0 do i = 1, npdb if (pdbtyp(i) .eq. 'ATOM ') then if (resnum(i) .ne. k) then k = resnum(i) nres = nres + 1 resatm(1,nres) = i if (nres .gt. 1) resatm(2,nres-1) = i - 1 end if end if end do if (nres .ge. 1) resatm(2,nres) = npdb c c close the PDB file and quit if there are no coordinates c if (npdb .eq. 0) abort = .true. if (.not. opened) close (unit=ipdb) return end c c c ################################################################## c ## ## c ## subroutine scanpdb -- PDB chains, alternates and inserts ## c ## ## c ################################################################## c c c "scanpdb" reads the first model in a Protein Data Bank file and c sets chains, alternate sites and insertion records to be used c c subroutine scanpdb (ipdb) use iounit use pdb use sequen implicit none integer i,k,ipdb integer next,nxtlast integer length,dummy integer nalt,nins logical exist,done character*1 chain,chnlast character*1 altloc,altlast character*1 insert,inslast character*6 remark character*20 blank,text character*20 chntemp character*20 alttyp character*20 instemp character*240 record character*240 string c c c initialize chain, alternate site and insertion lists c nchain = 0 nalt = 0 nins = 0 chnlast = '#' altlast = '#' inslast = '#' blank = ' ' chnsym = '####################' altsym = ' ' alttyp = blank instyp = blank c c scan for multiple chains, alternate locations and inserts c done = .false. do while (.not. done) read (ipdb,10,err=60,end=60) record 10 format (a240) remark = record(1:6) call upcase (remark) if (remark.eq.'ATOM ' .or. remark.eq.'HETATM') then next = 7 call getnumb (record,dummy,next) string = record(next+5:next+5) read (string,20) altloc 20 format (a1) string = record(next+10:next+10) read (string,30) chain 30 format (a1) next = next + 11 nxtlast = next call getnumb (record,dummy,next) if (next .eq. nxtlast) then string = record(next:next+3) read (string,40) dummy 40 format (i4) next = next + 4 end if string = record(next:next) read (string,50) insert 50 format (a1) if (chain .ne. chnlast) then if (index(chnsym,chain) .eq. 0) then nchain = nchain + 1 chnsym(nchain:nchain) = chain chnlast = chain end if end if if (altloc .ne. altlast) then if (index(alttyp,altloc) .eq. 0) then nalt = nalt + 1 alttyp(nalt:nalt) = altloc altlast = altloc end if end if if (insert .ne. inslast) then if (index(instyp,insert) .eq. 0) then nins = nins + 1 instyp(nins:nins) = insert inslast = insert end if end if else if (remark .eq. 'ENDMDL') then done = .true. else if (remark .eq. 'END ') then done = .true. end if end do 60 continue rewind (unit=ipdb) c c find out which of the multiple chains will be used c if (nchain .gt. 1) then call nextarg (chntemp,exist) if (.not. exist) then chntemp = blank if (chnsym(1:1) .eq. ' ') then string = 'BLANK=@' length = 7 else string(1:1) = chnsym(1:1) length = 1 end if do i = 2, nchain if (chnsym(i:i) .eq. ' ') then string = string(1:length)//' BLANK=@' length = length + 8 else string = string(1:length)//' '//chnsym(i:i) length = length + 2 end if end do string = string(1:length)//' [ALL]' length = length + 6 write (iout,70) string(1:length) 70 format (/,' Enter the Chain Names to Include', & ' (',a,') : ',$) read (input,80) chntemp 80 format (a20) end if call upcase (chntemp) next = 1 call gettext (chntemp,text,next) if (text.eq.blank .or. text(1:3).eq.'ALL') then chnsym = chnsym(1:nchain) else do i = 1, nchain chain = chnsym(i:i) if (chain .eq. ' ') chain = '@' k = index(chntemp,chain) if (k .eq. 0) chnsym(i:i) = '#' end do chntemp = chnsym k = 0 do i = 1, nchain chain = chntemp(i:i) if (chain .eq. '@') chain = ' ' if (chain .ne. '#') then k = k + 1 chnsym(k:k) = chain end if end do nchain = k end if end if do i = nchain+1, 20 chnsym(i:i) = '#' end do c c find out which of the alternate locations will be used c if (nalt .gt. 0) then call nextarg (altsym,exist) if (.not. exist) then string(1:3) = '['//alttyp(1:1)//']' length = 3 do i = 2, nalt string = string(1:length)//' '//alttyp(i:i) length = length + 2 end do write (iout,90) string(1:length) 90 format (/,' Enter a Set of Alternate Atom Locations', & ' from (',a,') : ',$) read (input,100) record 100 format (a240) next = 1 call gettext (record,altsym,next) end if if (altsym .eq. ' ') altsym = alttyp(1:1) call upcase (altsym) end if c c find out which of the insert records will be used c if (nins .gt. 0) then call nextarg (instemp,exist) if (.not. exist) then instemp = blank string(1:1) = instyp(1:1) length = 1 do i = 2, nins string = string(1:length)//' '//instyp(i:i) length = length + 2 end do string = string(1:length)//' [ALL] NONE' length = length + 11 write (iout,110) string(1:length) 110 format (/,' Enter the Insert Records to Include', & ' (',a,') : ',$) read (input,120) instemp 120 format (a20) end if call upcase (instemp) next = 1 call gettext (instemp,text,next) if (text.eq.blank .or. text.eq.'ALL ') then instyp = instyp(1:nins) else if (text .eq. 'NONE ') then instyp = blank else instyp = instemp end if end if return end c c c ################################################################## c ## ## c ## subroutine fixpdb -- standard PDB atom and residue names ## c ## ## c ################################################################## c c c "fixpdb" corrects problems with PDB files by converting residue c and atom names to the standard forms used by Tinker c c subroutine fixpdb (resname,atmname) use resdue implicit none integer i character*3 resname character*4 atmname character*7 restype c c c convert traditional 3-letter base names to PDB names c if (resname .eq. 'ADE') resname = ' A' if (resname .eq. 'GUA') resname = ' G' if (resname .eq. 'CYT') resname = ' C' if (resname .eq. 'URA') resname = ' U' if (resname .eq. 'DAD') resname = ' DA' if (resname .eq. 'DGU') resname = ' DG' if (resname .eq. 'DCY') resname = ' DC' if (resname .eq. 'THY') resname = ' DT' c c convert shifted standard base names to PDB names c if (resname .eq. 'A ') resname = ' A' if (resname .eq. 'G ') resname = ' G' if (resname .eq. 'C ') resname = ' C' if (resname .eq. 'U ') resname = ' U' if (resname .eq. ' A ') resname = ' A' if (resname .eq. ' G ') resname = ' G' if (resname .eq. ' C ') resname = ' C' if (resname .eq. ' U ') resname = ' U' if (resname .eq. 'DA ') resname = ' DA' if (resname .eq. 'DG ') resname = ' DG' if (resname .eq. 'DC ') resname = ' DC' if (resname .eq. 'DT ') resname = ' DT' c c convert terminal 3-letter base names to PDB names c if (resname .eq. 'DA5') resname = ' DA' if (resname .eq. 'DG5') resname = ' DG' if (resname .eq. 'DC5') resname = ' DC' if (resname .eq. 'DT5') resname = ' DT' if (resname .eq. 'DA3') resname = ' DA' if (resname .eq. 'DG3') resname = ' DG' if (resname .eq. 'DC3') resname = ' DC' if (resname .eq. 'DT3') resname = ' DT' c c convert unusual names for protonated histidine residues c if (resname .eq. 'HSD') resname = 'HID' if (resname .eq. 'HSE') resname = 'HIE' if (resname .eq. 'HSP') resname = 'HIS' if (resname .eq. 'HSH') resname = 'HIS' if (resname .eq. 'HIP') resname = 'HIS' if (resname .eq. 'HIH') resname = 'HIS' c c convert unusual names for other amino acid residues c if (resname .eq. 'CYN') resname = 'CYS' if (resname .eq. 'CYM') resname = 'CYD' if (resname .eq. 'LYP') resname = 'LYS' if (resname .eq. 'LYN') resname = 'LYD' c c convert unusual names for terminal capping residues c if (resname .eq. 'NMA') resname = 'NME' c c convert nonstandard names for water molecules c if (resname .eq. 'H2O') resname = 'HOH' if (resname .eq. 'WAT') resname = 'HOH' if (resname .eq. 'TIP') resname = 'HOH' if (resname .eq. 'DOD') resname = 'HOH' c c convert shifted and unusual names for atoms and ions c if (resname .eq. 'HE ') resname = ' HE' if (resname .eq. 'LI ') resname = ' LI' if (resname .eq. 'LI+') resname = ' LI' if (resname .eq. 'F ') resname = ' F' if (resname .eq. 'F- ') resname = ' F' if (resname .eq. 'NE ') resname = ' NE' if (resname .eq. 'NA ') resname = ' NA' if (resname .eq. 'NA+') resname = ' NA' if (resname .eq. 'SOD') resname = ' NA' if (resname .eq. 'MG ') resname = ' MG' if (resname .eq. 'MG+') resname = ' MG' if (resname .eq. 'CL ') resname = ' CL' if (resname .eq. 'CL-') resname = ' CL' if (resname .eq. 'CLA') resname = ' CL' if (resname .eq. 'AR ') resname = ' AR' if (resname .eq. 'K ') resname = ' K' if (resname .eq. 'K+ ') resname = ' K' if (resname .eq. 'POT') resname = ' K' if (resname .eq. 'CA ') resname = ' CA' if (resname .eq. 'CA+') resname = ' CA' if (resname .eq. 'CAL') resname = ' CA' if (resname .eq. 'FE ') resname = ' FE' if (resname .eq. 'FE+') resname = ' FE' if (resname .eq. 'ZN ') resname = ' ZN' if (resname .eq. 'ZN+') resname = ' ZN' if (resname .eq. 'BR ') resname = ' BR' if (resname .eq. 'BR-') resname = ' BR' if (resname .eq. 'KR ') resname = ' KR' if (resname .eq. 'RB ') resname = ' RB' if (resname .eq. 'RB+') resname = ' RB' if (resname .eq. 'SR ') resname = ' SR' if (resname .eq. 'SR+') resname = ' SR' if (resname .eq. 'I ') resname = ' I' if (resname .eq. 'I- ') resname = ' I' if (resname .eq. 'XE ') resname = ' XE' if (resname .eq. 'CS ') resname = ' CS' if (resname .eq. 'CS+') resname = ' CS' if (resname .eq. 'CES') resname = ' CS' if (resname .eq. 'BA ') resname = ' BA' if (resname .eq. 'BA+') resname = ' BA' c c decide whether residue is protein or nucleic acid c restype = 'UNKNOWN' do i = 1, maxamino if (resname .eq. amino(i)) restype = 'PROTEIN' end do do i = 1, maxnuc if (resname .eq. nuclz(i)) restype = 'NUCLEIC' end do c c convert unusual names common to many protein residues c if (restype .eq. 'PROTEIN') then if (atmname .eq. ' HN ') atmname = ' H ' if (atmname .eq. ' D ') atmname = ' H ' end if c c convert unusual names in protein terminal residues c if (restype .eq. 'PROTEIN') then if (atmname .eq. '1H ') atmname = ' H1 ' if (atmname .eq. ' HN1') atmname = ' H1 ' if (atmname .eq. ' HT1') atmname = ' H1 ' if (atmname .eq. '2H ') atmname = ' H2 ' if (atmname .eq. ' HN2') atmname = ' H2 ' if (atmname .eq. ' HT2') atmname = ' H2 ' if (atmname .eq. '3H ') atmname = ' H3 ' if (atmname .eq. ' HN3') atmname = ' H3 ' if (atmname .eq. ' HT3') atmname = ' H3 ' if (atmname .eq. ' O1 ') atmname = ' O ' if (atmname .eq. ' OT1') atmname = ' O ' if (atmname .eq. 'OCT1') atmname = ' O ' if (atmname .eq. ' O2 ') atmname = ' OXT' if (atmname .eq. ' OT2') atmname = ' OXT' if (atmname .eq. 'OCT2') atmname = ' OXT' if (atmname .eq. ' OT ') atmname = ' OXT' end if c c convert unusual names common to many nucleotides c if (restype .eq. 'NUCLEIC') then if (atmname .eq. ' O1P') atmname = ' OP1' if (atmname .eq. ' O2P') atmname = ' OP2' if (atmname .eq. ' O3P') atmname = ' OP3' if (atmname .eq. '2HOP') atmname = 'HOP2' if (atmname .eq. '3HOP') atmname = 'HOP3' if (atmname .eq. ' C1*') atmname = ' C1''' if (atmname .eq. ' C2*') atmname = ' C2''' if (atmname .eq. ' C3*') atmname = ' C3''' if (atmname .eq. ' C4*') atmname = ' C4''' if (atmname .eq. ' C5*') atmname = ' C5''' if (atmname .eq. ' O2*') atmname = ' O2''' if (atmname .eq. ' O3*') atmname = ' O3''' if (atmname .eq. ' O4*') atmname = ' O4''' if (atmname .eq. ' O5*') atmname = ' O5''' if (atmname .eq. ' H1*') atmname = ' H1''' if (atmname .eq. ' H2*') atmname = ' H2''' if (atmname .eq. '1H2*') atmname = ' H2''' if (atmname .eq. '2H2*') atmname = 'H2''''' if (atmname .eq. ' H3*') atmname = ' H3''' if (atmname .eq. ' H4*') atmname = ' H4''' if (atmname .eq. '1H5*') atmname = ' H5''' if (atmname .eq. '2H5*') atmname = 'H5''''' if (atmname .eq. '2HO*') atmname = 'HO2''' end if c c convert unusual names in terminal nucleotides c if (restype .eq. 'NUCLEIC') then if (atmname .eq. ' H5T') atmname = 'HO5''' if (atmname .eq. ' H3T') atmname = 'HO3''' end if c c glycine residue (GLY) c if (resname .eq. 'GLY') then if (atmname .eq. '1HA ') atmname = ' HA2' if (atmname .eq. ' HA1') atmname = ' HA3' if (atmname .eq. '2HA ') atmname = ' HA3' c c alanine residue (ALA) c else if (resname .eq. 'ALA') then if (atmname .eq. '1HB ') atmname = ' HB1' if (atmname .eq. '2HB ') atmname = ' HB2' if (atmname .eq. '3HB ') atmname = ' HB3' c c valine residue (VAL) c else if (resname .eq. 'VAL') then if (atmname .eq. '1HG1') atmname = 'HG11' if (atmname .eq. '2HG1') atmname = 'HG12' if (atmname .eq. '3HG1') atmname = 'HG13' if (atmname .eq. '1HG2') atmname = 'HG21' if (atmname .eq. '2HG2') atmname = 'HG22' if (atmname .eq. '3HG2') atmname = 'HG23' c c leucine residue (LEU) c else if (resname .eq. 'LEU') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. '1HD1') atmname = 'HD11' if (atmname .eq. '2HD1') atmname = 'HD12' if (atmname .eq. '3HD1') atmname = 'HD13' if (atmname .eq. '1HD2') atmname = 'HD21' if (atmname .eq. '2HD2') atmname = 'HD22' if (atmname .eq. '3HD2') atmname = 'HD23' c c isoleucine residue (ILE) c else if (resname .eq. 'ILE') then if (atmname .eq. ' CD ') atmname = ' CD1' if (atmname .eq. '1HG1') atmname = 'HG12' if (atmname .eq. 'HG11') atmname = 'HG13' if (atmname .eq. '2HG1') atmname = 'HG13' if (atmname .eq. '1HG2') atmname = 'HG21' if (atmname .eq. '2HG2') atmname = 'HG22' if (atmname .eq. '3HG2') atmname = 'HG23' if (atmname .eq. '1HD1') atmname = 'HD11' if (atmname .eq. ' HD1') atmname = 'HD11' if (atmname .eq. '2HD1') atmname = 'HD12' if (atmname .eq. ' HD2') atmname = 'HD12' if (atmname .eq. '3HD1') atmname = 'HD13' if (atmname .eq. ' HD3') atmname = 'HD13' c c serine residue (SER) c else if (resname .eq. 'SER') then if (atmname .eq. ' OG1') atmname = ' OG ' if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. ' HG1') atmname = ' HG ' if (atmname .eq. ' HOG') atmname = ' HG ' c c threonine residue (THR) c else if (resname .eq. 'THR') then if (atmname .eq. ' OG ') atmname = ' OG1' if (atmname .eq. ' CG ') atmname = ' CG2' if (atmname .eq. ' HOG') atmname = ' HG1' if (atmname .eq. 'HOG1') atmname = ' HG1' if (atmname .eq. '1HG2') atmname = 'HG21' if (atmname .eq. '2HG2') atmname = 'HG22' if (atmname .eq. '3HG2') atmname = 'HG23' c c cysteine residue (CYS) c else if (resname .eq. 'CYS') then if (atmname .eq. ' SG1') atmname = ' SG ' if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. ' HG1') atmname = ' HG ' if (atmname .eq. ' HSG') atmname = ' HG ' c c proline residue (PRO) c else if (resname .eq. 'PRO') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. '1HG ') atmname = ' HG2' if (atmname .eq. ' HG1') atmname = ' HG3' if (atmname .eq. '2HG ') atmname = ' HG3' if (atmname .eq. '1HD ') atmname = ' HD2' if (atmname .eq. ' HD1') atmname = ' HD3' if (atmname .eq. '2HD ') atmname = ' HD3' if (atmname .eq. ' HT1') atmname = ' H2 ' if (atmname .eq. ' HT2') atmname = ' H3 ' c c phenylalanine residue (PHE) c else if (resname .eq. 'PHE') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' c c tyrosine residue (TYR) c else if (resname .eq. 'TYR') then if (atmname .eq. ' HOH') atmname = ' HH ' if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' c c tryptophan residue (TRP) c else if (resname .eq. 'TRP') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. ' HNE') atmname = ' HE1' c c histidine (HD and HE) residue (HIS) c else if (resname .eq. 'HIS') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. ' HD ') atmname = ' HD2' if (atmname .eq. ' HE ') atmname = ' HE1' if (atmname .eq. ' HND') atmname = ' HD1' if (atmname .eq. 'HND1') atmname = ' HD1' if (atmname .eq. ' HNE') atmname = ' HE2' if (atmname .eq. 'HNE2') atmname = ' HE2' c c histidine (HD only) residue (HID) c else if (resname .eq. 'HID') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. ' HD ') atmname = ' HD2' if (atmname .eq. ' HE ') atmname = ' HE1' if (atmname .eq. ' HND') atmname = ' HD1' if (atmname .eq. 'HND1') atmname = ' HD1' c c histidine (HE only) residue (HIE) c else if (resname .eq. 'HIE') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. ' HD ') atmname = ' HD2' if (atmname .eq. ' HE ') atmname = ' HE1' if (atmname .eq. ' HNE') atmname = ' HE2' if (atmname .eq. 'HNE2') atmname = ' HE2' c c aspartic acid residue (ASP) c else if (resname .eq. 'ASP') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' c c asparagine residue (ASN) c else if (resname .eq. 'ASN') then if (atmname .eq. ' OD ') atmname = ' OD1' if (atmname .eq. ' ND ') atmname = ' ND2' if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. '1HD2') atmname = 'HD21' if (atmname .eq. 'HND1') atmname = 'HD21' if (atmname .eq. '2HD2') atmname = 'HD22' if (atmname .eq. 'HND2') atmname = 'HD22' c c glutamic acid residue (GLU) c else if (resname .eq. 'GLU') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. '1HG ') atmname = ' HG2' if (atmname .eq. ' HG1') atmname = ' HG3' if (atmname .eq. '2HG ') atmname = ' HG3' c c glutamine residue (GLN) c else if (resname .eq. 'GLN') then if (atmname .eq. ' OE ') atmname = ' OE1' if (atmname .eq. ' NE ') atmname = ' NE2' if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. '1HG ') atmname = ' HG2' if (atmname .eq. ' HG1') atmname = ' HG3' if (atmname .eq. '2HG ') atmname = ' HG3' if (atmname .eq. '1HE2') atmname = 'HE21' if (atmname .eq. 'HNE1') atmname = 'HE21' if (atmname .eq. '2HE2') atmname = 'HE22' if (atmname .eq. 'HNE2') atmname = 'HE22' c c methionine residue (MET) c else if (resname .eq. 'MET') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. '1HG ') atmname = ' HG2' if (atmname .eq. ' HG1') atmname = ' HG3' if (atmname .eq. '2HG ') atmname = ' HG3' if (atmname .eq. '1HE ') atmname = ' HE1' if (atmname .eq. '2HE ') atmname = ' HE2' if (atmname .eq. '3HE ') atmname = ' HE3' c c lysine residue (LYS) c else if (resname .eq. 'LYS') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. '1HG ') atmname = ' HG2' if (atmname .eq. ' HG1') atmname = ' HG3' if (atmname .eq. '2HG ') atmname = ' HG3' if (atmname .eq. '1HD ') atmname = ' HD2' if (atmname .eq. ' HD1') atmname = ' HD3' if (atmname .eq. '2HD ') atmname = ' HD3' if (atmname .eq. '1HE ') atmname = ' HE2' if (atmname .eq. ' HE1') atmname = ' HE3' if (atmname .eq. '2HE ') atmname = ' HE3' if (atmname .eq. '1HZ ') atmname = ' HZ1' if (atmname .eq. 'HNZ1') atmname = ' HZ1' if (atmname .eq. '2HZ ') atmname = ' HZ2' if (atmname .eq. 'HNZ2') atmname = ' HZ2' if (atmname .eq. '3HZ ') atmname = ' HZ3' if (atmname .eq. 'HNZ3') atmname = ' HZ3' c c arginine residue (ARG) c else if (resname .eq. 'ARG') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. '1HG ') atmname = ' HG2' if (atmname .eq. ' HG1') atmname = ' HG3' if (atmname .eq. '2HG ') atmname = ' HG3' if (atmname .eq. '1HD ') atmname = ' HD2' if (atmname .eq. ' HD1') atmname = ' HD3' if (atmname .eq. '2HD ') atmname = ' HD3' if (atmname .eq. '1HH1') atmname = 'HH11' if (atmname .eq. 'HN11') atmname = 'HH11' if (atmname .eq. '2HH1') atmname = 'HH12' if (atmname .eq. 'HN12') atmname = 'HH12' if (atmname .eq. '1HH2') atmname = 'HH21' if (atmname .eq. 'HN21') atmname = 'HH21' if (atmname .eq. '2HH2') atmname = 'HH22' if (atmname .eq. 'HN22') atmname = 'HH22' c c ornithine residue (ORN) c else if (resname .eq. 'ORN') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. '1HG ') atmname = ' HG2' if (atmname .eq. ' HG1') atmname = ' HG3' if (atmname .eq. '2HG ') atmname = ' HG3' if (atmname .eq. '1HD ') atmname = ' HD2' if (atmname .eq. ' HD1') atmname = ' HD3' if (atmname .eq. '2HD ') atmname = ' HD3' if (atmname .eq. '1HE ') atmname = ' HE1' if (atmname .eq. 'HNE1') atmname = ' HE1' if (atmname .eq. '2HE ') atmname = ' HE2' if (atmname .eq. 'HNE2') atmname = ' HE2' if (atmname .eq. '3HE ') atmname = ' HE3' if (atmname .eq. 'HNE3') atmname = ' HE3' c c methylalanine residue (AIB) c else if (resname .eq. 'AIB') then if (atmname .eq. '1HB1') atmname = 'HB11' if (atmname .eq. '2HB1') atmname = 'HB12' if (atmname .eq. '3HB1') atmname = 'HB13' if (atmname .eq. '1HB2') atmname = 'HB21' if (atmname .eq. '2HB2') atmname = 'HB22' if (atmname .eq. '3HB2') atmname = 'HB23' c c pyroglutamic acid residue (PCA) c else if (resname .eq. 'PCA') then if (atmname .eq. '1HB ') atmname = ' HB2' if (atmname .eq. ' HB1') atmname = ' HB3' if (atmname .eq. '2HB ') atmname = ' HB3' if (atmname .eq. '1HG ') atmname = ' HG2' if (atmname .eq. ' HG1') atmname = ' HG3' if (atmname .eq. '2HG ') atmname = ' HG3' c c N-terminal acetyl residue (ACE) c else if (resname .eq. 'ACE') then if (atmname .eq. ' CY ') atmname = ' C ' if (atmname .eq. ' CAY') atmname = ' CH3' if (atmname .eq. ' CA ') atmname = ' CH3' if (atmname .eq. ' OY ') atmname = ' O ' if (atmname .eq. '1H ') atmname = ' H1 ' if (atmname .eq. ' HY1') atmname = ' H1 ' if (atmname .eq. '1HH3') atmname = ' H1 ' if (atmname .eq. 'HH31') atmname = ' H1 ' if (atmname .eq. '2H ') atmname = ' H2 ' if (atmname .eq. ' HY2') atmname = ' H2 ' if (atmname .eq. '2HH3') atmname = ' H2 ' if (atmname .eq. 'HH32') atmname = ' H2 ' if (atmname .eq. '3H ') atmname = ' H3 ' if (atmname .eq. ' HY3') atmname = ' H3 ' if (atmname .eq. '3HH3') atmname = ' H3 ' if (atmname .eq. 'HH33') atmname = ' H3 ' c c N-terminal formyl residue (FOR) c else if (resname .eq. 'FOR') then if (atmname .eq. ' CY ') atmname = ' C ' if (atmname .eq. ' OY ') atmname = ' O ' if (atmname .eq. ' HY ') atmname = ' H ' c c C-terminal N-methylamide residue (NME) c else if (resname .eq. 'NME') then if (atmname .eq. ' NT ') atmname = ' N ' if (atmname .eq. ' CT ') atmname = ' CH3' if (atmname .eq. ' CAT') atmname = ' CH3' if (atmname .eq. ' CA ') atmname = ' CH3' if (atmname .eq. ' HNT') atmname = ' H ' if (atmname .eq. '1H ') atmname = ' H1 ' if (atmname .eq. '1HA ') atmname = ' H1 ' if (atmname .eq. ' HT1') atmname = ' H1 ' if (atmname .eq. '1HH3') atmname = ' H1 ' if (atmname .eq. 'HH31') atmname = ' H1 ' if (atmname .eq. '2H ') atmname = ' H2 ' if (atmname .eq. '2HA ') atmname = ' H2 ' if (atmname .eq. ' HT2') atmname = ' H2 ' if (atmname .eq. '2HH3') atmname = ' H2 ' if (atmname .eq. 'HH32') atmname = ' H2 ' if (atmname .eq. '3H ') atmname = ' H3 ' if (atmname .eq. '3HA ') atmname = ' H3 ' if (atmname .eq. ' HT3') atmname = ' H3 ' if (atmname .eq. '3HH3') atmname = ' H3 ' if (atmname .eq. 'HH33') atmname = ' H3 ' c c C-terminal amide residue (NH2) c else if (resname .eq. 'NH2') then if (atmname .eq. ' NT ') atmname = ' N ' if (atmname .eq. '1H ') atmname = ' H1 ' if (atmname .eq. '2H ') atmname = ' H2 ' if (atmname .eq. ' HT1') atmname = ' H1 ' if (atmname .eq. ' HT2') atmname = ' H2 ' c c adenosine residue (A) c else if (resname .eq. ' A') then if (atmname .eq. '1H6 ') atmname = ' H61' if (atmname .eq. '2H6 ') atmname = ' H62' c c guanosine residue (G) c else if (resname .eq. ' G') then if (atmname .eq. '1H2 ') atmname = ' H21' if (atmname .eq. '2H2 ') atmname = ' H22' c c cytidine residue (C) c else if (resname .eq. ' C') then if (atmname .eq. '1H4 ') atmname = ' H41' if (atmname .eq. '2H4 ') atmname = ' H42' c c deoxyadenosine residue (DA) c else if (resname .eq. ' DA') then if (atmname .eq. '1H6 ') atmname = ' H61' if (atmname .eq. '2H6 ') atmname = ' H62' c c deoxyguanosine residue (DG) c else if (resname .eq. ' DG') then if (atmname .eq. '1H2 ') atmname = ' H21' if (atmname .eq. '2H2 ') atmname = ' H22' c c deoxycytidine residue (DC) c else if (resname .eq. ' DC') then if (atmname .eq. '1H4 ') atmname = ' H41' if (atmname .eq. '2H4 ') atmname = ' H42' c c deoxythymidine residue (DT) c else if (resname .eq. ' DT') then if (atmname .eq. ' C5M') atmname = ' C7 ' if (atmname .eq. '1H5M') atmname = ' H71' if (atmname .eq. '2H5M') atmname = ' H72' if (atmname .eq. '3H5M') atmname = ' H73' c c water molecules (HOH) c else if (resname .eq. 'HOH') then if (atmname .eq. ' OT ') atmname = ' O ' if (atmname .eq. ' OW ') atmname = ' O ' if (atmname .eq. ' OH2') atmname = ' O ' if (atmname .eq. ' OD2') atmname = ' O ' if (atmname .eq. ' HT ') atmname = ' H ' if (atmname .eq. ' HW ') atmname = ' H ' if (atmname .eq. ' HW1') atmname = ' H ' if (atmname .eq. ' HW2') atmname = ' H ' if (atmname .eq. ' H1 ') atmname = ' H ' if (atmname .eq. ' H2 ') atmname = ' H ' if (atmname .eq. ' DT ') atmname = ' H ' if (atmname .eq. ' DW ') atmname = ' H ' if (atmname .eq. ' DW1') atmname = ' H ' if (atmname .eq. ' DW2') atmname = ' H ' if (atmname .eq. ' D1 ') atmname = ' H ' if (atmname .eq. ' D2 ') atmname = ' H ' 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 readprm -- input of force field parameters ## c ## ## c ############################################################### c c c "readprm" processes the potential energy parameter file c in order to define the default force field parameters c c subroutine readprm use fields use iounit use kanang use kangs use kantor use katoms use kbonds use kcflux use kchrge use kcpen use kctrn use kdipol use kdsp use kexpl use khbond use kiprop use kitors use kmulti use kopbnd use kopdst use korbs use kpitor use kpolpr use kpolr use krepl use ksolut use kstbnd use ksttor use ktorsn use ktrtor use kurybr use kvdws use kvdwpr use merck use params implicit none integer i,j,iprm integer ia,ib,ic,id integer ie,if,ig,ih integer ii,imin integer size,next integer length,trimtext integer nb,nb5,nb4 integer nb3,nel integer na,na5,na4 integer na3,nap,naf integer nsb,nu,nopb,nopd integer ndi,nti,nt,nt5,nt4 integer npt,nbt,nat,ntt,nvp integer nhb,nd,nd5,nd4,nd3 integer nmp,npp,ncfb,ncfa integer npi,npi5,npi4 integer cls,atn,lig integer nx,ny,nxy integer bt,at,sbt,tt integer ilpr integer ft(6),pg(maxval) real*8 wght,rd real*8 ep,rdn real*8 spr,apr,epr real*8 cdp,adp real*8 an1,an2,an3 real*8 ba1,ba2 real*8 aa1,aa2,aa3 real*8 bt1,bt2,bt3 real*8 bt4,bt5,bt6 real*8 bt7,bt8,bt9 real*8 at1,at2,at3 real*8 at4,at5,at6 real*8 an,pr,ds,dk real*8 vd,cg,dp,ps real*8 fc,bd,dl real*8 pt,pel,pal real*8 pol,thl,thd real*8 kpr,ppr,dpr real*8 ctrn,atrn real*8 cfb,cfb1,cfb2 real*8 cfa1,cfa2 real*8 pbrd,csrd real*8 gkrd,snek real*8 el,iz,rp real*8 ss,ts real*8 abc,cba real*8 gi,alphi real*8 nni,factor real*8 vt(6),st(6) real*8 pl(13) real*8 tx(maxtgrd2) real*8 ty(maxtgrd2) real*8 tf(maxtgrd2) logical header,swap character*1 da1 character*4 pa,pb,pc character*4 pd,pe character*8 axt character*20 keyword character*20 text character*240 record character*240 string c c c initialize the counters for some parameter types c nb = 0 nb5 = 0 nb4 = 0 nb3 = 0 nel = 0 na = 0 na5 = 0 na4 = 0 na3 = 0 nap = 0 naf = 0 nsb = 0 nu = 0 nopb = 0 nopd = 0 ndi = 0 nti = 0 nt = 0 nt5 = 0 nt4 = 0 npt = 0 nbt = 0 nat = 0 ntt = 0 nvp = 0 nhb = 0 nd = 0 nd5 = 0 nd4 = 0 nd3 = 0 nmp = 0 npp = 0 ncfb = 0 ncfa = 0 npi = 0 npi5 = 0 npi4 = 0 c c number of characters in an atom number text string c size = 4 c c set blank line header before echoed comment lines c header = .true. c c process each line of the parameter file, first c extract the keyword at the start of each line c iprm = 0 do while (iprm .lt. nprm) iprm = iprm + 1 record = prmline(iprm) next = 1 call gettext (record,keyword,next) call upcase (keyword) c c check for a force field modification keyword c call prmkey (record) c c comment line to be echoed to the output c if (keyword(1:5) .eq. 'ECHO ') then string = record(next:240) length = trimtext (string) if (header) then header = .false. write (iout,10) 10 format () end if if (length .eq. 0) then write (iout,20) 20 format () else write (iout,30) string(1:length) 30 format (a) end if c c atom type definitions and parameters c else if (keyword(1:5) .eq. 'ATOM ') then ia = 0 cls = 0 atn = 0 wght = 0.0d0 lig = 0 call getnumb (record,ia,next) call getnumb (record,cls,next) if (cls .eq. 0) cls = ia atmcls(ia) = cls if (ia .ge. maxtyp) then write (iout,40) 40 format (/,' READPRM -- Too many Atom Types;', & ' Increase MAXTYP') call fatal else if (cls .ge. maxclass) then write (iout,50) 50 format (/,' READPRM -- Too many Atom Classes;', & ' Increase MAXCLASS') call fatal end if if (ia .ne. 0) then call gettext (record,symbol(ia),next) call getstring (record,describe(ia),next) string = record(next:240) read (string,*,err=60,end=60) atn,wght,lig 60 continue atmnum(ia) = atn weight(ia) = wght ligand(ia) = lig end if c c bond stretching parameters c else if (keyword(1:5) .eq. 'BOND ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 string = record(next:240) read (string,*,err=70,end=70) ia,ib,fc,bd 70 continue call numeral (ia,pa,size) call numeral (ib,pb,size) nb = nb + 1 if (ia .le. ib) then kb(nb) = pa//pb else kb(nb) = pb//pa end if bcon(nb) = fc blen(nb) = bd c c bond stretching parameters for 5-membered rings c else if (keyword(1:6) .eq. 'BOND5 ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 string = record(next:240) read (string,*,err=80,end=80) ia,ib,fc,bd 80 continue call numeral (ia,pa,size) call numeral (ib,pb,size) nb5 = nb5 + 1 if (ia .le. ib) then kb5(nb5) = pa//pb else kb5(nb5) = pb//pa end if bcon5(nb5) = fc blen5(nb5) = bd c c bond stretching parameters for 4-membered rings c else if (keyword(1:6) .eq. 'BOND4 ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 string = record(next:240) read (string,*,err=90,end=90) ia,ib,fc,bd 90 continue call numeral (ia,pa,size) call numeral (ib,pb,size) nb4 = nb4 + 1 if (ia .le. ib) then kb4(nb4) = pa//pb else kb4(nb4) = pb//pa end if bcon4(nb4) = fc blen4(nb4) = bd c c bond stretching parameters for 3-membered rings c else if (keyword(1:6) .eq. 'BOND3 ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 string = record(next:240) read (string,*,err=100,end=100) ia,ib,fc,bd 100 continue call numeral (ia,pa,size) call numeral (ib,pb,size) nb3 = nb3 + 1 if (ia .le. ib) then kb3(nb3) = pa//pb else kb3(nb3) = pb//pa end if bcon3(nb3) = fc blen3(nb3) = bd c c electronegativity bond length correction parameters c else if (keyword(1:9) .eq. 'ELECTNEG ') then ia = 0 ib = 0 ic = 0 dl = 0.0d0 string = record(next:240) read (string,*,err=110,end=110) ia,ib,ic,dl 110 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) nel = nel + 1 if (ia .le. ic) then kel(nel) = pa//pb//pc else kel(nel) = pc//pb//pa end if dlen(nel) = dl c c bond angle bending parameters c else if (keyword(1:6) .eq. 'ANGLE ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 an3 = 0.0d0 string = record(next:240) read (string,*,err=120,end=120) ia,ib,ic,fc,an1,an2,an3 120 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) na = na + 1 if (ia .le. ic) then ka(na) = pa//pb//pc else ka(na) = pc//pb//pa end if acon(na) = fc ang(1,na) = an1 ang(2,na) = an2 ang(3,na) = an3 c c angle bending parameters for 5-membered rings c else if (keyword(1:7) .eq. 'ANGLE5 ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 an3 = 0.0d0 string = record(next:240) read (string,*,err=130,end=130) ia,ib,ic,fc,an1,an2,an3 130 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) na5 = na5 + 1 if (ia .le. ic) then ka5(na5) = pa//pb//pc else ka5(na5) = pc//pb//pa end if acon5(na5) = fc ang5(1,na5) = an1 ang5(2,na5) = an2 ang5(3,na5) = an3 c c angle bending parameters for 4-membered rings c else if (keyword(1:7) .eq. 'ANGLE4 ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 an3 = 0.0d0 string = record(next:240) read (string,*,err=140,end=140) ia,ib,ic,fc,an1,an2,an3 140 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) na4 = na4 + 1 if (ia .le. ic) then ka4(na4) = pa//pb//pc else ka4(na4) = pc//pb//pa end if acon4(na4) = fc ang4(1,na4) = an1 ang4(2,na4) = an2 ang4(3,na4) = an3 c c angle bending parameters for 3-membered rings c else if (keyword(1:7) .eq. 'ANGLE3 ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 an3 = 0.0d0 string = record(next:240) read (string,*,err=150,end=150) ia,ib,ic,fc,an1,an2,an3 150 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) na3 = na3 + 1 if (ia .le. ic) then ka3(na3) = pa//pb//pc else ka3(na3) = pc//pb//pa end if acon3(na3) = fc ang3(1,na3) = an1 ang3(2,na3) = an2 ang3(3,na3) = an3 c c in-plane projected angle bending parameters c else if (keyword(1:7) .eq. 'ANGLEP ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 an2 = 0.0d0 string = record(next:240) read (string,*,err=160,end=160) ia,ib,ic,fc,an1,an2 160 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) nap = nap + 1 if (ia .le. ic) then kap(nap) = pa//pb//pc else kap(nap) = pc//pb//pa end if aconp(nap) = fc angp(1,nap) = an1 angp(2,nap) = an2 c c Fourier bond angle bending parameters c else if (keyword(1:7) .eq. 'ANGLEF ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an = 0.0d0 pr = 0.0d0 string = record(next:240) read (string,*,err=170,end=170) ia,ib,ic,fc,an,pr 170 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) naf = naf + 1 if (ia .le. ic) then kaf(naf) = pa//pb//pc else kaf(naf) = pc//pb//pa end if aconf(naf) = fc angf(1,naf) = an angf(2,naf) = pr c c stretch-bend parameters c else if (keyword(1:7) .eq. 'STRBND ') then ia = 0 ib = 0 ic = 0 ba1 = 0.0d0 ba2 = 0.0d0 string = record(next:240) read (string,*,err=180,end=180) ia,ib,ic,ba1,ba2 180 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) nsb = nsb + 1 if (ia .le. ic) then ksb(nsb) = pa//pb//pc stbn(1,nsb) = ba1 stbn(2,nsb) = ba2 else ksb(nsb) = pc//pb//pa stbn(1,nsb) = ba2 stbn(2,nsb) = ba1 end if c c Urey-Bradley parameters c else if (keyword(1:9) .eq. 'UREYBRAD ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 ds = 0.0d0 string = record(next:240) read (string,*,err=190,end=190) ia,ib,ic,fc,ds 190 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) nu = nu + 1 if (ia .le. ic) then ku(nu) = pa//pb//pc else ku(nu) = pc//pb//pa end if ucon(nu) = fc dst13(nu) = ds c c angle-angle parameters c else if (keyword(1:7) .eq. 'ANGANG ') then ia = 0 aa1 = 0.0d0 aa2 = 0.0d0 aa3 = 0.0d0 string = record(next:240) read (string,*,err=200,end=200) ia,aa1,aa2,aa3 200 continue if (ia .ne. 0) then anan(1,ia) = aa1 anan(2,ia) = aa2 anan(3,ia) = aa3 end if c c out-of-plane bend parameters c else if (keyword(1:7) .eq. 'OPBEND ') then ia = 0 ib = 0 ic = 0 id = 0 fc = 0.0d0 string = record(next:240) read (string,*,err=210,end=210) ia,ib,ic,id,fc 210 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nopb = nopb + 1 if (ic .le. id) then kopb(nopb) = pa//pb//pc//pd else kopb(nopb) = pa//pb//pd//pc end if opbn(nopb) = fc c c out-of-plane distance parameters c else if (keyword(1:7) .eq. 'OPDIST ') then ia = 0 ib = 0 ic = 0 id = 0 fc = 0.0d0 string = record(next:240) read (string,*,err=220,end=220) ia,ib,ic,id,fc 220 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nopd = nopd + 1 imin = min(ib,ic,id) if (ib .eq. imin) then if (ic .le. id) then kopd(nopd) = pa//pb//pc//pd else kopd(nopd) = pa//pb//pd//pc end if else if (ic .eq. imin) then if (ib .le. id) then kopd(nopd) = pa//pc//pb//pd else kopd(nopd) = pa//pc//pd//pb end if else if (id .eq. imin) then if (ib .le. ic) then kopd(nopd) = pa//pd//pb//pc else kopd(nopd) = pa//pd//pc//pb end if end if opds(nopd) = fc c c improper dihedral parameters c else if (keyword(1:9) .eq. 'IMPROPER ') then ia = 0 ib = 0 ic = 0 id = 0 dk = 0.0d0 vd = 0.0d0 string = record(next:240) read (string,*,err=230,end=230) ia,ib,ic,id,dk,vd 230 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) ndi = ndi + 1 kdi(ndi) = pa//pb//pc//pd dcon(ndi) = dk tdi(ndi) = vd c c improper torsional parameters c else if (keyword(1:8) .eq. 'IMPTORS ') then ia = 0 ib = 0 ic = 0 id = 0 do i = 1, 6 vt(i) = 0.0d0 st(i) = 0.0d0 ft(i) = 0 end do string = record(next:240) read (string,*,err=240,end=240) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,6) 240 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nti = nti + 1 kti(nti) = pa//pb//pc//pd call torphase (ft,vt,st) ti1(1,nti) = vt(1) ti1(2,nti) = st(1) ti2(1,nti) = vt(2) ti2(2,nti) = st(2) ti3(1,nti) = vt(3) ti3(2,nti) = st(3) c c torsional parameters c else if (keyword(1:8) .eq. 'TORSION ') then ia = 0 ib = 0 ic = 0 id = 0 do i = 1, 6 vt(i) = 0.0d0 st(i) = 0.0d0 ft(i) = 0 end do string = record(next:240) read (string,*,err=250,end=250) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,6) 250 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nt = nt + 1 if (ib .lt. ic) then kt(nt) = pa//pb//pc//pd else if (ic .lt. ib) then kt(nt) = pd//pc//pb//pa else if (ia .le. id) then kt(nt) = pa//pb//pc//pd else if (id .lt. ia) then kt(nt) = pd//pc//pb//pa end if call torphase (ft,vt,st) t1(1,nt) = vt(1) t1(2,nt) = st(1) t2(1,nt) = vt(2) t2(2,nt) = st(2) t3(1,nt) = vt(3) t3(2,nt) = st(3) t4(1,nt) = vt(4) t4(2,nt) = st(4) t5(1,nt) = vt(5) t5(2,nt) = st(5) t6(1,nt) = vt(6) t6(2,nt) = st(6) c c torsional parameters for 5-membered rings c else if (keyword(1:9) .eq. 'TORSION5 ') then ia = 0 ib = 0 ic = 0 id = 0 do i = 1, 6 vt(i) = 0.0d0 st(i) = 0.0d0 ft(i) = 0 end do string = record(next:240) read (string,*,err=260,end=260) ia,ib,ic,id, & (vt(j),st(j),ft(j),j=1,6) 260 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nt5 = nt5 + 1 if (ib .lt. ic) then kt5(nt5) = pa//pb//pc//pd else if (ic .lt. ib) then kt5(nt5) = pd//pc//pb//pa else if (ia .le. id) then kt5(nt5) = pa//pb//pc//pd else if (id .lt. ia) then kt5(nt5) = pd//pc//pb//pa end if call torphase (ft,vt,st) t15(1,nt5) = vt(1) t15(2,nt5) = st(1) t25(1,nt5) = vt(2) t25(2,nt5) = st(2) t35(1,nt5) = vt(3) t35(2,nt5) = st(3) t45(1,nt5) = vt(4) t45(2,nt5) = st(4) t55(1,nt5) = vt(5) t55(2,nt5) = st(5) t65(1,nt5) = vt(6) t65(2,nt5) = st(6) c c torsional parameters for 4-membered rings c else if (keyword(1:9) .eq. 'TORSION4 ') then ia = 0 ib = 0 ic = 0 id = 0 do i = 1, 6 vt(i) = 0.0d0 st(i) = 0.0d0 ft(i) = 0 end do string = record(next:240) read (string,*,err=270,end=270) ia,ib,ic,id, & (vt(i),st(i),ft(i),i=1,6) 270 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nt4 = nt4 + 1 if (ib .lt. ic) then kt4(nt4) = pa//pb//pc//pd else if (ic .lt. ib) then kt4(nt4) = pd//pc//pb//pa else if (ia .le. id) then kt4(nt4) = pa//pb//pc//pd else if (id .lt. ia) then kt4(nt4) = pd//pc//pb//pa end if call torphase (ft,vt,st) t14(1,nt4) = vt(1) t14(2,nt4) = st(1) t24(1,nt4) = vt(2) t24(2,nt4) = st(2) t34(1,nt4) = vt(3) t34(2,nt4) = st(3) t44(1,nt4) = vt(4) t44(2,nt4) = st(4) t54(1,nt4) = vt(5) t54(2,nt4) = st(5) t64(1,nt4) = vt(6) t64(2,nt4) = st(6) c c pi-system torsion parameters c else if (keyword(1:7) .eq. 'PITORS ') then ia = 0 ib = 0 pt = 0.0d0 string = record(next:240) read (string,*,err=280,end=280) ia,ib,pt 280 continue call numeral (ia,pa,size) call numeral (ib,pb,size) npt = npt + 1 if (ia .le. ib) then kpt(npt) = pa//pb else kpt(npt) = pb//pa end if ptcon(npt) = pt c c stretch-torsion parameters c else if (keyword(1:8) .eq. 'STRTORS ') then ia = 0 ib = 0 ic = 0 id = 0 bt1 = 0.0d0 bt2 = 0.0d0 bt3 = 0.0d0 bt4 = 0.0d0 bt5 = 0.0d0 bt6 = 0.0d0 bt7 = 0.0d0 bt8 = 0.0d0 bt9 = 0.0d0 string = record(next:240) read (string,*,err=290,end=290) ia,ib,ic,id,bt1,bt2,bt3, & bt4,bt5,bt6,bt7,bt8,bt9 290 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nbt = nbt + 1 if (ib .lt. ic) then kbt(nbt) = pa//pb//pc//pd swap = .false. else if (ic .lt. ib) then kbt(nbt) = pd//pc//pb//pa swap = .true. else if (ia .le. id) then kbt(nbt) = pa//pb//pc//pd swap = .false. else if (id .lt. ia) then kbt(nbt) = pd//pc//pb//pa swap = .true. end if btcon(4,nbt) = bt4 btcon(5,nbt) = bt5 btcon(6,nbt) = bt6 if (swap) then btcon(1,nbt) = bt7 btcon(2,nbt) = bt8 btcon(3,nbt) = bt9 btcon(7,nbt) = bt1 btcon(8,nbt) = bt2 btcon(9,nbt) = bt3 else btcon(1,nbt) = bt1 btcon(2,nbt) = bt2 btcon(3,nbt) = bt3 btcon(7,nbt) = bt7 btcon(8,nbt) = bt8 btcon(9,nbt) = bt9 end if c c angle-torsion parameters c else if (keyword(1:8) .eq. 'ANGTORS ') then ia = 0 ib = 0 ic = 0 id = 0 at1 = 0.0d0 at2 = 0.0d0 at3 = 0.0d0 at4 = 0.0d0 at5 = 0.0d0 at6 = 0.0d0 string = record(next:240) read (string,*,err=300,end=300) ia,ib,ic,id,at1,at2, & at3,at4,at5,at6 300 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nat = nat + 1 if (ib .lt. ic) then kat(nat) = pa//pb//pc//pd swap = .false. else if (ic .lt. ib) then kat(nat) = pd//pc//pb//pa swap = .true. else if (ia .le. id) then kat(nat) = pa//pb//pc//pd swap = .false. else if (id .lt. ia) then kat(nat) = pd//pc//pb//pa swap = .true. end if if (swap) then atcon(1,nat) = at4 atcon(2,nat) = at5 atcon(3,nat) = at6 atcon(4,nat) = at1 atcon(5,nat) = at2 atcon(6,nat) = at3 else atcon(1,nat) = at1 atcon(2,nat) = at2 atcon(3,nat) = at3 atcon(4,nat) = at4 atcon(5,nat) = at5 atcon(6,nat) = at6 end if c c torsion-torsion parameters c else if (keyword(1:8) .eq. 'TORTORS ') then ia = 0 ib = 0 ic = 0 id = 0 ie = 0 nx = 0 ny = 0 nxy = 0 do i = 1, maxtgrd2 tx(i) = 0.0d0 ty(i) = 0.0d0 tf(i) = 0.0d0 end do string = record(next:240) read (string,*,err=310,end=310) ia,ib,ic,id,ie,nx,ny nxy = nx * ny do i = 1, nxy iprm = iprm + 1 record = prmline(iprm) read (record,*,err=310,end=310) tx(i),ty(i),tf(i) end do 310 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) call numeral (ie,pe,size) ntt = ntt + 1 ktt(ntt) = pa//pb//pc//pd//pe nx = nxy call sort9 (nx,tx) ny = nxy call sort9 (ny,ty) tnx(ntt) = nx tny(ntt) = ny do i = 1, nx ttx(i,ntt) = tx(i) end do do i = 1, ny tty(i,ntt) = ty(i) end do do i = 1, nxy tbf(i,ntt) = tf(i) end do c c van der Waals parameters for individual atom types c else if (keyword(1:4) .eq. 'VDW ') then ia = 0 rd = 0.0d0 ep = 0.0d0 rdn = 0.0d0 string = record(next:240) read (string,*,err=320,end=320) ia,rd,ep,rdn 320 continue if (ia .ne. 0) then rad(ia) = rd eps(ia) = ep reduct(ia) = rdn end if c c van der Waals 1-4 parameters for individual atom types c else if (keyword(1:6) .eq. 'VDW14 ') then ia = 0 rd = 0.0d0 ep = 0.0d0 string = record(next:240) read (string,*,err=330,end=330) ia,rd,ep 330 continue if (ia .ne. 0) then rad4(ia) = rd eps4(ia) = ep end if c c van der Waals parameters for specific atom pairs c else if (keyword(1:8) .eq. 'VDWPAIR ' .or. & keyword(1:6) .eq. 'VDWPR ') then ia = 0 ib = 0 rd = 0.0d0 ep = 0.0d0 string = record(next:240) read (string,*,err=340,end=340) ia,ib,rd,ep 340 continue call numeral (ia,pa,size) call numeral (ib,pb,size) nvp = nvp + 1 if (ia .le. ib) then kvpr(nvp) = pa//pb else kvpr(nvp) = pb//pa end if radpr(nvp) = rd epspr(nvp) = ep c c van der Waals parameters for hydrogen bonding pairs c else if (keyword(1:6) .eq. 'HBOND ') then ia = 0 ib = 0 rd = 0.0d0 ep = 0.0d0 string = record(next:240) read (string,*,err=350,end=350) ia,ib,rd,ep 350 continue call numeral (ia,pa,size) call numeral (ib,pb,size) nhb = nhb + 1 if (ia .le. ib) then khb(nhb) = pa//pb else khb(nhb) = pb//pa end if radhb(nhb) = rd epshb(nhb) = ep c c Pauli repulsion parameters c else if (keyword(1:10) .eq. 'REPULSION ') then ia = 0 spr = 0.0d0 apr = 0.0d0 epr = 0.0d0 string = record(next:240) read (string,*,err=360,end=360) ia,spr,apr,epr 360 continue if (ia .ne. 0) then prsiz(ia) = spr prdmp(ia) = apr prele(ia) = -abs(epr) end if c c damped dispersion parameters c else if (keyword(1:11) .eq. 'DISPERSION ') then ia = 0 cdp = 0.0d0 adp = 0.0d0 string = record(next:240) read (string,*,err=370,end=370) ia,cdp,adp 370 continue if (ia .ne. 0) then dspsix(ia) = cdp dspdmp(ia) = adp end if c c atomic partial charge parameters c else if (keyword(1:7) .eq. 'CHARGE ') then ia = 0 cg = 0.0d0 string = record(next:240) read (string,*,err=380,end=380) ia,cg 380 continue if (ia .ne. 0) chg(ia) = cg c c bond dipole moment parameters c else if (keyword(1:7) .eq. 'DIPOLE ') then ia = 0 ib = 0 dp = 0.0d0 ps = 0.5d0 string = record(next:240) read (string,*,err=390,end=390) ia,ib,dp,ps 390 continue call numeral (ia,pa,size) call numeral (ib,pb,size) nd = nd + 1 if (ia .le. ib) then kd(nd) = pa//pb dpl(nd) = dp pos(nd) = ps else kd(nd) = pb//pa dpl(nd) = -dp pos(nd) = 1.0d0 - ps end if c c bond dipole moment parameters for 5-membered rings c else if (keyword(1:8) .eq. 'DIPOLE5 ') then ia = 0 ib = 0 dp = 0.0d0 ps = 0.5d0 string = record(next:240) read (string,*,err=400,end=400) ia,ib,dp,ps 400 continue call numeral (ia,pa,size) call numeral (ib,pb,size) nd5 = nd5 + 1 if (ia .le. ib) then kd5(nd5) = pa//pb dpl5(nd5) = dp pos5(nd5) = ps else kd5(nd5) = pb//pa dpl5(nd5) = -dp pos5(nd5) = 1.0d0 - ps end if c c bond dipole moment parameters for 4-membered rings c else if (keyword(1:8) .eq. 'DIPOLE4 ') then ia = 0 ib = 0 dp = 0.0d0 ps = 0.5d0 string = record(next:240) read (string,*,err=410,end=410) ia,ib,dp,ps 410 continue call numeral (ia,pa,size) call numeral (ib,pb,size) nd4 = nd4 + 1 if (ia .le. ib) then kd4(nd4) = pa//pb dpl4(nd4) = dp pos4(nd4) = ps else kd4(nd4) = pb//pa dpl4(nd4) = -dp pos4(nd4) = 1.0d0 - ps end if c c bond dipole moment parameters for 3-membered rings c else if (keyword(1:8) .eq. 'DIPOLE3 ') then ia = 0 ib = 0 dp = 0.0d0 ps = 0.5d0 string = record(next:240) read (string,*,err=420,end=420) ia,ib,dp,ps 420 continue call numeral (ia,pa,size) call numeral (ib,pb,size) nd3 = nd3 + 1 if (ia .le. ib) then kd3(nd3) = pa//pb dpl3(nd3) = dp pos3(nd3) = ps else kd3(nd3) = pb//pa dpl3(nd3) = -dp pos3(nd3) = 1.0d0 - ps end if c c atomic multipole moment parameters c else if (keyword(1:10) .eq. 'MULTIPOLE ') then ia = 0 ib = 0 ic = 0 id = 0 axt = 'Z-then-X' do i = 1, 13 pl(i) = 0.0d0 end do string = record(next:240) read (string,*,err=430,end=430) ia,ib,ic,id,pl(1) goto 460 430 continue id = 0 read (string,*,err=440,end=440) ia,ib,ic,pl(1) goto 460 440 continue ic = 0 read (string,*,err=450,end=450) ia,ib,pl(1) goto 460 450 continue ib = 0 read (string,*,err=470,end=470) ia,pl(1) 460 continue iprm = iprm + 1 record = prmline(iprm) read (record,*,err=470,end=470) pl(2),pl(3),pl(4) iprm = iprm + 1 record = prmline(iprm) read (record,*,err=470,end=470) pl(5) iprm = iprm + 1 record = prmline(iprm) read (record,*,err=470,end=470) pl(8),pl(9) iprm = iprm + 1 record = prmline(iprm) read (record,*,err=470,end=470) pl(11),pl(12),pl(13) 470 continue if (ib .eq. 0) axt = 'None' if (ib.ne.0 .and. ic.eq.0) axt = 'Z-Only' if (ib.lt.0 .or. ic.lt.0) axt = 'Bisector' if (ic.lt.0 .and. id.lt.0) axt = 'Z-Bisect' if (max(ib,ic,id) .lt. 0) axt = '3-Fold' ib = abs(ib) ic = abs(ic) id = abs(id) call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nmp = nmp + 1 kmp(nmp) = pa//pb//pc//pd mpaxis(nmp) = axt multip(1,nmp) = pl(1) multip(2,nmp) = pl(2) multip(3,nmp) = pl(3) multip(4,nmp) = pl(4) multip(5,nmp) = pl(5) multip(6,nmp) = pl(8) multip(7,nmp) = pl(11) multip(8,nmp) = pl(8) multip(9,nmp) = pl(9) multip(10,nmp) = pl(12) multip(11,nmp) = pl(11) multip(12,nmp) = pl(12) multip(13,nmp) = pl(13) c c charge penetration parameters c else if (keyword(1:7) .eq. 'CHGPEN ') then ia = 0 pel = 0.0d0 pal = 0.0d0 string = record(next:240) read (string,*,err=480,end=480) ia,pel,pal 480 continue if (ia .ne. 0) then cpele(ia) = abs(pel) cpalp(ia) = pal end if c c atomic dipole polarizability parameters c else if (keyword(1:9) .eq. 'POLARIZE ') then ia = 0 pol = 0.0d0 thl = 0.0d0 thd = 0.0d0 do i = 1, maxval pg(i) = 0 end do string = record(1:240) call getnumb (string,ia,next) call gettext (string,text,next) read (text,*,err=490,end=490) pol call gettext (string,text,next) i = 1 call getnumb (text,pg(1),i) if (pg(1) .eq. 0) then read (text,*,err=490,end=490) thl call gettext (string,text,next) i = 1 call getnumb (text,pg(1),i) string = string(next:240) if (pg(1) .eq. 0) then read (text,*,err=490,end=490) thd read (string,*,err=490,end=490) (pg(i),i=1,maxval) else read (string,*,err=490,end=490) (pg(i),i=2,maxval) end if else string = string(next:240) read (string,*,err=490,end=490) (pg(i),i=2,maxval) end if 490 continue if (ia .ne. 0) then polr(ia) = pol athl(ia) = thl dthl(ia) = thd do i = 1, maxval pgrp(i,ia) = pg(i) end do end if c c polarization parameters for specific atom pairs c else if (keyword(1:8) .eq. 'POLPAIR ') then ia = 0 ib = 0 thl = 0.0d0 thd = 0.0d0 string = record(next:240) read (string,*,err=500,end=500) ia,ib,thl,thd 500 continue call numeral (ia,pa,size) call numeral (ib,pb,size) npp = npp + 1 if (ia .le. ib) then kppr(npp) = pa//pb else kppr(npp) = pb//pa end if thlpr(npp) = thl thdpr(npp) = thd c c exchange polarization parameters c else if (keyword(1:8) .eq. 'EXCHPOL ') then ia = 0 kpr = 0.0d0 ppr = 0.0d0 dpr = 0.0d0 ilpr = 0 string = record(next:240) read (string,*,err=510,end=510) ia,kpr,ppr,dpr,ilpr 510 continue if (ia .ne. 0) then pepk(ia) = kpr peppre(ia) = ppr pepdmp(ia) = dpr if (ilpr .ne. 0) then pepl(ia) = .true. else pepl(ia) = .false. end if end if c c charge transfer parameters c else if (keyword(1:7) .eq. 'CHGTRN ') then ia = 0 ctrn = 0.0d0 atrn = 0.0d0 string = record(next:240) read (string,*,err=520,end=520) ia,ctrn,atrn 520 continue if (ia .ne. 0) then ctchg(ia) = ctrn ctdmp(ia) = atrn end if c c bond charge flux parameters c else if (keyword(1:9) .eq. 'BNDCFLUX ') then ia = 0 ib = 0 cfb = 0.0d0 string = record(next:240) read (string,*,err=530,end=530) ia,ib,cfb 530 continue call numeral (ia,pa,size) call numeral (ib,pb,size) ncfb = ncfb + 1 if (ia .lt. ib) then kcfb(ncfb) = pa//pb cflb(ncfb) = cfb else if (ib .lt. ia) then kcfb(ncfb) = pb//pa cflb(ncfb) = -cfb else kcfb(ncfb) = pa//pb cflb(ncfb) = 0.0d0 end if c c angle charge flux parameters c else if (keyword(1:9) .eq. 'ANGCFLUX ') then ia = 0 ib = 0 ic = 0 cfa1 = 0.0d0 cfa2 = 0.0d0 cfb1 = 0.0d0 cfb2 = 0.0d0 string = record(next:240) read (string,*,err=540,end=540) ia,ib,ic,cfa1,cfa2, & cfb1,cfb2 540 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) ncfa = ncfa + 1 if (ia .le. ic) then kcfa(ncfa) = pa//pb//pc cfla(1,ncfa) = cfa1 cfla(2,ncfa) = cfa2 cflab(1,ncfa) = cfb1 cflab(2,ncfa) = cfb2 else kcfa(ncfa) = pc//pb//pa cfla(1,ncfa) = cfa2 cfla(2,ncfa) = cfa1 cflab(1,ncfa) = cfb2 cflab(2,ncfa) = cfb1 end if c c implicit solvation parameters c else if (keyword(1:7) .eq. 'SOLUTE ') then ia = 0 pbrd = 0.0d0 csrd = 0.0d0 gkrd = 0.0d0 snek = 0.0d0 string = record(next:240) read (string,*,err=550,end=550) ia,pbrd,csrd,gkrd,snek 550 continue if (ia .ne. 0) then pbr(ia) = 0.5d0 * pbrd csr(ia) = 0.5d0 * csrd gkr(ia) = 0.5d0 * gkrd snk(ia) = snek end if c c conjugated pisystem atom parameters c else if (keyword(1:7) .eq. 'PIATOM ') then ia = 0 el = 0.0d0 iz = 0.0d0 rp = 0.0d0 string = record(next:240) read (string,*,err=560,end=560) ia,el,iz,rp 560 continue if (ia .ne. 0) then electron(ia) = el ionize(ia) = iz repulse(ia) = rp end if c c conjugated pisystem bond parameters c else if (keyword(1:7) .eq. 'PIBOND ') then ia = 0 ib = 0 ss = 0.0d0 ts = 0.0d0 string = record(next:240) read (string,*,err=570,end=570) ia,ib,ss,ts 570 continue call numeral (ia,pa,size) call numeral (ib,pb,size) npi = npi + 1 if (ia .le. ib) then kpi(npi) = pa//pb else kpi(npi) = pb//pa end if sslope(npi) = ss tslope(npi) = ts c c conjugated pisystem bond parameters for 5-membered rings c else if (keyword(1:8) .eq. 'PIBOND5 ') then ia = 0 ib = 0 ss = 0.0d0 ts = 0.0d0 string = record(next:240) read (string,*,err=580,end=580) ia,ib,ss,ts 580 continue call numeral (ia,pa,size) call numeral (ib,pb,size) npi5 = npi5 + 1 if (ia .le. ib) then kpi5(npi5) = pa//pb else kpi5(npi5) = pb//pa end if sslope5(npi5) = ss tslope5(npi5) = ts c c conjugated pisystem bond parameters for 4-membered rings c else if (keyword(1:8) .eq. 'PIBOND4 ') then ia = 0 ib = 0 ss = 0.0d0 ts = 0.0d0 string = record(next:240) read (string,*,err=590,end=590) ia,ib,ss,ts 590 continue call numeral (ia,pa,size) call numeral (ib,pb,size) npi4 = npi4 + 1 if (ia .le. ib) then kpi4(npi4) = pa//pb else kpi4(npi4) = pb//pa end if sslope4(npi4) = ss tslope4(npi4) = ts c c metal ligand field splitting parameters c else if (keyword(1:6) .eq. 'METAL ') then string = record(next:240) read (string,*,err=600,end=600) ia 600 continue c c biopolymer atom type conversion definitions c else if (keyword(1:8) .eq. 'BIOTYPE ') then ia = 0 ib = 0 string = record(next:240) read (string,*,err=610,end=610) ia call getword (record,string,next) call getstring (record,string,next) string = record(next:240) read (string,*,err=610,end=610) ib 610 continue if (ia .ge. maxbio) then write (iout,620) 620 format (/,' READPRM -- Too many Biopolymer Types;', & ' Increase MAXBIO') call fatal end if if (ia .gt. 0) biotyp(ia) = ib c c MMFF atom class equivalency parameters c else if (keyword(1:10) .eq. 'MMFFEQUIV ') then string = record(next:240) ia = 1000 ib = 1000 ic = 1000 id = 1000 ie = 1000 if = 0 read (string,*,err=630,end=630) ia,ib,ic,id,ie,if 630 continue eqclass(if,1) = ia eqclass(if,2) = ib eqclass(if,3) = ic eqclass(if,4) = id eqclass(if,5) = ie c c MMFF covalent radius and electronegativity parameters c else if (keyword(1:11) .eq. 'MMFFCOVRAD ') then ia = 0 fc = 0.0d0 bd = 0.0d0 string = record(next:240) read (string,*,err=640,end=640) ia,fc,bd 640 continue rad0(ia) = fc paulel(ia) = bd c c MMFF atom class property parameters c else if (keyword(1:9) .eq. 'MMFFPROP ') then string = record(next:240) ia = 1000 ib = 1000 ic = 1000 id = 1000 ie = 1000 if = 1000 ig = 1000 ih = 1000 ii = 1000 read (string,*,err=650,end=650) ia,ib,ic,id,ie, & if,ig,ih,ii 650 continue crd(ia) = ic val(ia) = id pilp(ia) = ie mltb(ia) = if arom(ia) = ig lin(ia) = ih sbmb(ia) = ii c c MMFF bond stretching parameters c else if (keyword(1:9) .eq. 'MMFFBOND ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 bt = 2 string = record(next:240) read (string,*,err=660,end=660) ia,ib,fc,bd,bt 660 continue nb = nb + 1 if (bt .eq. 0) then mmff_kb(ia,ib) = fc mmff_kb(ib,ia) = fc mmff_b0(ia,ib) = bd mmff_b0(ib,ia) = bd else if (bt .eq. 1) then mmff_kb1(ia,ib) = fc mmff_kb1(ib,ia) = fc mmff_b1(ia,ib) = bd mmff_b1(ib,ia) = bd end if c c MMFF bond stretching empirical rule parameters c else if (keyword(1:11) .eq. 'MMFFBONDER ') then ia = 0 ib = 0 fc = 0.0d0 bd = 0.0d0 string = record(next:240) read (string,*,err=670,end=670) ia,ib,fc,bd 670 continue r0ref(ia,ib) = fc r0ref(ib,ia) = fc kbref(ia,ib) = bd kbref(ib,ia) = bd c c MMFF bond angle bending parameters c else if (keyword(1:10) .eq. 'MMFFANGLE ') then ia = 0 ib = 0 ic = 0 fc = 0.0d0 an1 = 0.0d0 at = 3 string = record(next:240) read (string,*,err=680,end=680) ia,ib,ic,fc,an1,at 680 continue na = na + 1 if (an1 .ne. 0.0d0) then if (at .eq. 0) then mmff_ka(ia,ib,ic) = fc mmff_ka(ic,ib,ia) = fc mmff_ang0(ia,ib,ic) = an1 mmff_ang0(ic,ib,ia) = an1 else if (at .eq. 1) then mmff_ka1(ia,ib,ic) = fc mmff_ka1(ic,ib,ia) = fc mmff_ang1(ia,ib,ic) = an1 mmff_ang1(ic,ib,ia) = an1 else if (at .eq. 2) then mmff_ka2(ia,ib,ic) = fc mmff_ka2(ic,ib,ia) = fc mmff_ang2(ia,ib,ic) = an1 mmff_ang2(ic,ib,ia) = an1 else if (at .eq. 3) then mmff_ka3(ia,ib,ic) = fc mmff_ka3(ic,ib,ia) = fc mmff_ang3(ia,ib,ic) = an1 mmff_ang3(ic,ib,ia) = an1 else if (at .eq. 4) then mmff_ka4(ia,ib,ic) = fc mmff_ka4(ic,ib,ia) = fc mmff_ang4(ia,ib,ic) = an1 mmff_ang4(ic,ib,ia) = an1 else if (at .eq. 5) then mmff_ka5(ia,ib,ic) = fc mmff_ka5(ic,ib,ia) = fc mmff_ang5(ia,ib,ic) = an1 mmff_ang5(ic,ib,ia) = an1 else if (at .eq. 6) then mmff_ka6(ia,ib,ic) = fc mmff_ka6(ic,ib,ia) = fc mmff_ang6(ia,ib,ic) = an1 mmff_ang6(ic,ib,ia) = an1 else if (at .eq. 7) then mmff_ka7(ia,ib,ic) = fc mmff_ka7(ic,ib,ia) = fc mmff_ang7(ia,ib,ic) = an1 mmff_ang7(ic,ib,ia) = an1 else if (at .eq. 8) then mmff_ka8(ia,ib,ic) = fc mmff_ka8(ic,ib,ia) = fc mmff_ang8(ia,ib,ic) = an1 mmff_ang8(ic,ib,ia) = an1 end if end if c c MMFF stretch-bend parameters c else if (keyword(1:11) .eq. 'MMFFSTRBND ') then ia = 0 ib = 0 ic = 0 abc = 0.0d0 cba = 0.0d0 sbt = 4 string = record(next:240) read (string,*,err=690,end=690) ia,ib,ic,abc,cba,sbt 690 continue if (ia .ne. 0) then if (sbt .eq. 0) then stbn_abc(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc(ic,ib,ia) = cba stbn_cba(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba(ic,ib,ia) = abc else if (sbt .eq. 1) then stbn_abc1(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc1(ic,ib,ia) = cba stbn_cba1(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba1(ic,ib,ia) = abc else if (sbt .eq. 2) then stbn_abc2(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc2(ic,ib,ia) = cba stbn_cba2(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba2(ic,ib,ia) = abc else if (sbt .eq. 3) then stbn_abc3(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc3(ic,ib,ia) = cba stbn_cba3(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba3(ic,ib,ia) = abc else if (sbt .eq. 4) then stbn_abc4(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc4(ic,ib,ia) = cba stbn_cba4(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba4(ic,ib,ia) = abc else if (sbt .eq. 5) then stbn_abc5(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc5(ic,ib,ia) = cba stbn_cba5(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba5(ic,ib,ia) = abc else if (sbt .eq. 6) then stbn_abc6(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc6(ic,ib,ia) = cba stbn_cba6(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba6(ic,ib,ia) = abc else if (sbt .eq. 7) then stbn_abc7(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc7(ic,ib,ia) = cba stbn_cba7(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba7(ic,ib,ia) = abc else if (sbt .eq. 8) then stbn_abc8(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc8(ic,ib,ia) = cba stbn_cba8(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba8(ic,ib,ia) = abc else if (sbt .eq. 9) then stbn_abc9(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc9(ic,ib,ia) = cba stbn_cba9(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba9(ic,ib,ia) = abc else if (sbt .eq. 10) then stbn_abc10(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc10(ic,ib,ia) = cba stbn_cba10(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba10(ic,ib,ia) = abc else if (sbt .eq. 11) then stbn_abc11(ia,ib,ic) = abc if (ic .ne. ia) stbn_abc11(ic,ib,ia) = cba stbn_cba11(ia,ib,ic) = cba if (ic .ne. ia) stbn_cba11(ic,ib,ia) = abc end if end if c c MMFF default stretch-bend parameters c else if (keyword(1:12) .eq. 'MMFFDEFSTBN ') then string = record(next:240) ia = 1000 ib = 1000 ic = 1000 abc = 0.0d0 cba = 0.0d0 read (string,*,err=700,end=700) ia,ib,ic,abc,cba 700 continue defstbn_abc(ia,ib,ic) = abc defstbn_cba(ia,ib,ic) = cba defstbn_abc(ic,ib,ia) = cba defstbn_cba(ic,ib,ia) = abc c c MMFF out-of-plane bend parameters c else if (keyword(1:11) .eq. 'MMFFOPBEND ') then ia = 0 ib = 0 ic = 0 id = 0 fc = 0.0d0 string = record(next:240) read (string,*,err=710,end=710) ia,ib,ic,id,fc 710 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nopb = nopb + 1 if (ic .le. id) then kopb(nopb) = pa//pb//pc//pd else kopb(nopb) = pa//pb//pd//pc end if opbn(nopb) = fc c if (ic.gt.0 .or. id.gt.0) then c nopb = nopb + 1 c if (ib .le. id) then c kopb(nopb) = pc//pb//pb//pd c else c kopb(nopb) = pc//pb//pd//pb c end if c opbn(nopb) = fc c nopb = nopb + 1 c if (ia .le. ic) then c kopb(nopb) = pd//pb//pa//pc c else c kopb(nopb) = pd//pb//pc//pa c end if c opbn(nopb) = fc c end if c c MMFF torsional parameters c else if (keyword(1:12) .eq. 'MMFFTORSION ') then ia = 0 ib = 0 ic = 0 id = 0 do i = 1, 6 vt(i) = 0.0d0 st(i) = 0.0d0 ft(i) = 0 end do tt = 3 string = record(next:240) read (string,*,err=720,end=720) ia,ib,ic,id,(vt(j), & st(j),ft(j),j=1,3),tt 720 continue call numeral (ia,pa,size) call numeral (ib,pb,size) call numeral (ic,pc,size) call numeral (id,pd,size) nt = nt + 1 if (tt .eq. 0) then if (ib .lt. ic) then kt(nt) = pa//pb//pc//pd else if (ic .lt. ib) then kt(nt) = pd//pc//pb//pa else if (ia .le. id) then kt(nt) = pa//pb//pc//pd else if (id .lt. ia) then kt(nt) = pd//pc//pb//pa end if call torphase (ft,vt,st) t1(1,nt) = vt(1) t1(2,nt) = st(1) t2(1,nt) = vt(2) t2(2,nt) = st(2) t3(1,nt) = vt(3) t3(2,nt) = st(3) else if (tt .eq. 1) then if (ib .lt. ic) then kt_1(nt) = pa//pb//pc//pd else if (ic .lt. ib) then kt_1(nt) = pd//pc//pb//pa else if (ia .le. id) then kt_1(nt) = pa//pb//pc//pd else if (id .lt. ia) then kt_1(nt) = pd//pc//pb//pa end if call torphase (ft,vt,st) t1_1(1,nt) = vt(1) t1_1(2,nt) = st(1) t2_1(1,nt) = vt(2) t2_1(2,nt) = st(2) t3_1(1,nt) = vt(3) t3_1(2,nt) = st(3) else if (tt .eq. 2) then if (ib .lt. ic) then kt_2(nt) = pa//pb//pc//pd else if (ic .lt. ib) then kt_2(nt) = pd//pc//pb//pa else if (ia .le. id) then kt_2(nt) = pa//pb//pc//pd else if (id .lt. ia) then kt_2(nt) = pd//pc//pb//pa end if call torphase (ft,vt,st) t1_2(1,nt) = vt(1) t1_2(2,nt) = st(1) t2_2(1,nt) = vt(2) t2_2(2,nt) = st(2) t3_2(1,nt) = vt(3) t3_2(2,nt) = st(3) else if (tt .eq. 4) then nt4 = nt4 + 1 if (ib .lt. ic) then kt4(nt4) = pa//pb//pc//pd else if (ic .lt. ib) then kt4(nt4) = pd//pc//pb//pa else if (ia .le. id) then kt4(nt4) = pa//pb//pc//pd else if (id .lt. ia) then kt4(nt4) = pd//pc//pb//pa end if call torphase (ft,vt,st) t14(1,nt4) = vt(1) t14(2,nt4) = st(1) t24(1,nt4) = vt(2) t24(2,nt4) = st(2) t34(1,nt4) = vt(3) t34(2,nt4) = st(3) else if (tt .eq. 5) then nt5 = nt5 + 1 if (ib .lt. ic) then kt5(nt5) = pa//pb//pc//pd else if (ic .lt. ib) then kt5(nt5) = pd//pc//pb//pa else if (ia .le. id) then kt5(nt5) = pa//pb//pc//pd else if (id .lt. ia) then kt5(nt5) = pd//pc//pb//pa end if call torphase (ft,vt,st) t15(1,nt5) = vt(1) t15(2,nt5) = st(1) t25(1,nt5) = vt(2) t25(2,nt5) = st(2) t35(1,nt5) = vt(3) t35(2,nt5) = st(3) end if c c MMFF van der Waals parameters c else if (keyword(1:8) .eq. 'MMFFVDW ') then ia = 0 rd = 0.0d0 ep = 0.0d0 rdn = 0.0d0 da1 = 'C' string = record(next:240) read (string,*,err=730,end=730) ia,rd,alphi,nni,gi,da1 730 continue if (ia .ne. 0) then rad(ia) = rd g(ia) = gi alph(ia) = alphi nn(ia) = nni da(ia) = da1 end if c c MMFF bond charge increment parameters c else if (keyword(1:8) .eq. 'MMFFBCI ') then ia = 0 ib = 0 cg = 1000.0d0 bt = 2 string = record(next:240) read (string,*,err=740,end=740) ia,ib,cg,bt 740 continue if (ia .ne. 0) then if (bt .eq. 0) then bci(ia,ib) = cg bci(ib,ia) = -cg else if (bt .eq. 1) then bci_1(ia,ib) = cg bci_1(ib,ia) = -cg end if end if c c MMFF partial bond charge increment parameters c else if (keyword(1:9) .eq. 'MMFFPBCI ') then ia = 0 string = record(next:240) read (string,*,err=750,end=750) ia,cg,factor 750 continue if (ia .ne. 0) then pbci(ia) = cg fcadj(ia) = factor end if c c MMFF aromatic ion parameters c else if (keyword(1:9) .eq. 'MMFFAROM ') then string = record(next:240) read (string,*,err=760,end=760) ia,ib,ic,id,ie,if 760 continue if (ie.eq.0 .and. id.eq.0) then mmffarom(ia,if) = ic else if (id .eq. 1) then mmffaromc(ia,if) = ic else if (ie .eq. 1) then mmffaroma(ia,if) = ic 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 readseq -- read biopolymer sequence file ## c ## ## c ############################################################# c c c "readseq" gets a biopolymer sequence containing one or more c separate chains from an external file; all lines containing c sequence must begin with the starting sequence number, the c actual sequence is read from subsequent nonblank characters c c subroutine readseq (iseq) use files use iounit use resdue use sequen implicit none integer i,j,k,iseq integer length,number integer start,stop integer next,trimtext logical exist,opened,done character*1 letter character*3 word character*240 seqfile character*240 record c c c open the input file if it has not already been done c inquire (unit=iseq,opened=opened) if (.not. opened) then seqfile = filename(1:leng)//'.seq' call version (seqfile,'old') inquire (file=seqfile,exist=exist) if (exist) then open (unit=iseq,file=seqfile,status='old') rewind (unit=iseq) else write (iout,10) 10 format (/,' READSEQ -- Unable to Find the Biopolymer', & ' Sequence File') call fatal end if end if c c zero out the number and type of residues c nseq = 0 nchain = 0 do i = 1, maxres seq(i) = ' ' end do c c read in the biopolymer sequence file c do while (.true.) read (iseq,20,err=30,end=30) record 20 format (a240) length = trimtext (record) next = 1 call gettext (record,letter,next) if (letter.ge.'0' .and. letter.le.'9') then next = 1 letter = ' ' end if call getnumb (record,number,next) if (number .eq. 1) then nchain = nchain + 1 ichain(1,nchain) = nseq + 1 chnnam(nchain) = letter end if done = .false. do while (.not. done) call getword (record,word,next) call justify (word) if (word .eq. ' ') then done = .true. else nseq = nseq + 1 seq(nseq) = word end if end do end do 30 continue c c set the last residue in each sequence chain c do i = 1, nchain-1 ichain(2,i) = ichain(1,i+1) - 1 end do if (nchain .ne. 0) ichain(2,nchain) = nseq c c find residue types and species present in each chain c do i = 1, nchain start = ichain(1,i) stop = ichain(2,i) chntyp(i) = 'GENERIC' do j = start, stop do k = 1, maxamino if (seq(j) .eq. amino(k)) then seqtyp(j) = k chntyp(i) = 'PEPTIDE' goto 40 end if end do chntyp(i) = 'GENERIC' goto 50 40 continue end do 50 continue if (chntyp(i) .eq. 'GENERIC') then do j = start, stop do k = 1, maxnuc if (seq(j) .eq. nuclz(k)) then seqtyp(j) = k chntyp(i) = 'NUCLEIC' goto 60 end if end do chntyp(i) = 'GENERIC' goto 70 60 continue end do 70 continue end if if (chntyp(i) .eq. 'GENERIC') then do j = start, stop seqtyp(j) = 0 end do end if end do if (.not. opened) close (unit=iseq) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine readxyz -- input of XYZ-format coordinates ## c ## ## c ############################################################### c c c "readxyz" gets a set of Cartesian coordinates from c an external disk file c c subroutine readxyz (ixyz) use atomid use atoms use boxes use couple use files use inform use iounit use titles implicit none integer i,j,k,m integer ixyz,nmax integer next,size integer first,last integer nexttext integer trimtext integer, allocatable :: list(:) logical exist,opened logical quit,reorder logical clash character*240 xyzfile character*240 record character*240 string c c c initialize the total number of atoms in the system c n = 0 c c open the input file if it has not already been done c inquire (unit=ixyz,opened=opened) if (.not. opened) then xyzfile = filename(1:leng)//'.xyz' call version (xyzfile,'old') inquire (file=xyzfile,exist=exist) if (exist) then open (unit=ixyz,file=xyzfile,status='old') rewind (unit=ixyz) else write (iout,10) 10 format (/,' READXYZ -- Unable to Find the Cartesian', & ' Coordinates File') call fatal end if end if c c read first line and return if already at end of file c quit = .false. abort = .true. size = 0 do while (size .eq. 0) read (ixyz,20,err=80,end=80) record 20 format (a240) size = trimtext (record) end do abort = .false. quit = .true. c c parse the title line to get the number of atoms c i = 0 next = 1 call gettext (record,string,next) read (string,*,err=80,end=80) n c c extract the title and determine its length c string = record(next:240) first = nexttext (string) last = trimtext (string) if (last .eq. 0) then title = ' ' ltitle = 0 else title = string(first:last) ltitle = trimtext (title) end if c c check for too few or too many total atoms in the file c if (n .le. 0) then write (iout,30) 30 format (/,' READXYZ -- The Coordinate File Does Not', & ' Contain Any Atoms') call fatal else if (n .gt. maxatm) then write (iout,40) maxatm 40 format (/,' READXYZ -- The Maximum of',i9,' Atoms', & ' has been Exceeded') call fatal end if c c initialize coordinates and connectivities for each atom c do i = 1, n tag(i) = 0 name(i) = ' ' x(i) = 0.0d0 y(i) = 0.0d0 z(i) = 0.0d0 type(i) = 0 n12(i) = 0 do j = 1, maxval i12(j,i) = 0 end do end do c c read the coordinates and connectivities for each atom c do i = 1, n size = 0 do while (size .eq. 0) call unitcell read (ixyz,50,err=80,end=80) record 50 format (a240) size = trimtext (record) if (i .eq. 1) then next = 1 call getword (record,name(i),next) if (name(i) .ne. ' ') goto 60 read (record,*,err=60,end=60) xbox,ybox,zbox, & alpha,beta,gamma size = 0 end if 60 continue call lattice end do read (record,*,err=80,end=80) tag(i) next = 1 call getword (record,name(i),next) string = record(next:240) read (string,*,err=70,end=70) x(i),y(i),z(i),type(i), & (i12(j,i),j=1,maxval) 70 continue end do quit = .false. 80 continue if (.not. opened) close (unit=ixyz) c c an error occurred in reading the coordinate file c if (quit) then write (iout,90) i 90 format (/,' READXYZ -- Error in Coordinate File at Atom',i9) call fatal end if c c for each atom, count and sort its attached atoms c do i = 1, n do j = maxval, 1, -1 if (i12(j,i) .ne. 0) then n12(i) = j goto 100 end if end do 100 continue call sort (n12(i),i12(1,i)) end do c c perform dynamic allocation of some local arrays c nmax = 0 do i = 1, n nmax = max(tag(i),nmax) do j = 1, n12(i) nmax = max(i12(j,i),nmax) end do end do allocate (list(nmax)) c c check for scrambled atom order and attempt to renumber c reorder = .false. do i = 1, n list(tag(i)) = i if (tag(i) .ne. i) reorder = .true. end do if (reorder) then write (iout,110) 110 format (/,' READXYZ -- Atom Labels not Sequential,', & ' Attempting to Renumber') do i = 1, n tag(i) = i do j = 1, n12(i) i12(j,i) = list(i12(j,i)) end do call sort (n12(i),i12(1,i)) end do end if c c perform deallocation of some local arrays c deallocate (list) c c check for atom pairs with identical coordinates c clash = .false. if (n .le. 10000) call chkxyz (clash) c c make sure all atom connectivities are bidirectional c do i = 1, n do j = 1, n12(i) k = i12(j,i) do m = 1, n12(k) if (i12(m,k) .eq. i) goto 130 end do write (iout,120) k,i 120 format (/,' READXYZ -- Check Connection of Atoms', & i9,' and',i9) call fatal 130 continue 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 refer -- reference atomic coordinate storage ## c ## ## c ############################################################# c c c nref total number of atoms in each reference system c refltitle length in characters of reference title lines c refleng length in characters of reference base filenames c reftyp atom types of the atoms in each reference system c n12ref number of atoms bonded to each reference atom c i12ref atom numbers of atoms 1-2 connected to each atom c xboxref reference a-axis length of periodic box c yboxref reference b-axis length of periodic box c zboxref reference c-axis length of periodic box c alpharef reference angle between b- and c-axes of box c betaref reference angle between a- and c-axes of box c gammaref reference angle between a- and b-axes of box c xref reference x-coordinates for atoms in each system c yref reference y-coordinates for atoms in each system c zref reference z-coordinates for atoms in each system c refnam atom names of the atoms in each reference system c reffile full filename for each reference system c reftitle title used to describe each reference system c c module refer use sizes implicit none integer nref(maxref) integer refltitle(maxref) integer refleng(maxref) integer, allocatable :: reftyp(:,:) integer, allocatable :: n12ref(:,:) integer, allocatable :: i12ref(:,:,:) real*8 xboxref(maxref) real*8 yboxref(maxref) real*8 zboxref(maxref) real*8 alpharef(maxref) real*8 betaref(maxref) real*8 gammaref(maxref) real*8, allocatable :: xref(:,:) real*8, allocatable :: yref(:,:) real*8, allocatable :: zref(:,:) character*3, allocatable :: refnam(:,:) character*240 reffile(maxref) character*240 reftitle(maxref) 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 repel -- Pauli repulsion for current structure ## c ## ## c ############################################################### c c c nrep total number of repulsion sites in the system c irep number of the atom for each repulsion site c replist repulsion multipole site for each atom (0=none) c sizpr Pauli repulsion size parameter value for each atom c dmppr Pauli repulsion alpha damping value for each atom c elepr Pauli repulsion valence electrons for each atom c repole repulsion Cartesian multipoles in the local frame c rrepole repulsion Cartesian multipoles in the global frame c c module repel implicit none integer nrep integer, allocatable :: irep(:) integer, allocatable :: replist(:) real*8, allocatable :: sizpr(:) real*8, allocatable :: dmppr(:) real*8, allocatable :: elepr(:) real*8, allocatable :: repole(:,:) real*8, allocatable :: rrepole(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 2000 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine replica -- periodicity via cell replication ## c ## ## c ################################################################ c c c "replica" decides between images and replicates for generation c of periodic boundary conditions, and sets the cell replicate c list if the replicates method is to be used c c subroutine replica (cutoff) use bound use boxes use cell use inform use iounit use math implicit none integer i,j,k integer nx,ny,nz real*8 cutoff,maximage real*8 xlimit,ylimit,zlimit c c c only necessary if periodic boundaries are in use c ncell = 1 if (.not. use_bounds) return c c find the maximum sphere radius inscribed in periodic box c if (orthogonal) then xlimit = xbox2 ylimit = ybox2 zlimit = zbox2 else if (monoclinic) then xlimit = xbox2 * beta_sin ylimit = ybox2 zlimit = zbox2 * beta_sin else if (triclinic) then xlimit = volbox / (2.0d0*ybox*zbox*alpha_sin) ylimit = volbox / (2.0d0*xbox*zbox*beta_sin) zlimit = volbox / (2.0d0*xbox*ybox*gamma_sin) else if (octahedron) then xlimit = 0.5d0 * root3 * xbox2 ylimit = xlimit zlimit = xlimit else if (dodecadron) then xlimit = xbox2 ylimit = xlimit zlimit = xlimit end if maximage = min(xlimit,ylimit,zlimit) c c use replicate method to handle cutoffs too large for images c if (cutoff .le. maximage) then use_replica = .false. else use_replica = .true. end if c c non-prism periodic cells cannot use the replicates method c if (use_replica) then if (nonprism) then write (iout,10) 10 format (/,' REPLICA -- Non-Parallelepiped Cells', & ' cannot be Replicated') call fatal end if end if c c find the number of replicates needed based on cutoff c nx = int(cutoff/xlimit) ny = int(cutoff/ylimit) nz = int(cutoff/zlimit) if (cutoff .gt. dble(nx)*xlimit) nx = nx + 1 if (cutoff .gt. dble(ny)*ylimit) ny = ny + 1 if (cutoff .gt. dble(nz)*zlimit) nz = nz + 1 if (nx .lt. 1) nx = 1 if (ny .lt. 1) ny = 1 if (nz .lt. 1) nz = 1 c c set the replicated cell length and the half width c xcell = dble(nx) * xbox ycell = dble(ny) * ybox zcell = dble(nz) * zbox xcell2 = 0.5d0 * xcell ycell2 = 0.5d0 * ycell zcell2 = 0.5d0 * zcell c c perform dynamic allocation of some global arrays c ncell = nx*ny*nz if (allocated(icell)) then if (size(icell) .lt. 3*ncell) then deallocate (icell) allocate (icell(3,ncell)) end if else allocate (icell(3,ncell)) end if c c assign indices to the required cell replicates c ncell = 0 do k = 0, nz-1 do j = 0, ny-1 do i = 0, nx-1 ncell = ncell + 1 icell(1,ncell) = i icell(2,ncell) = j icell(3,ncell) = k end do end do end do c c print a message indicating the number of replicates used c if (debug .and. ncell.gt.1) then if (max(nx,ny,nz) .lt. 10) then write (iout,20) nx,ny,nz 20 format (/,' REPLICA -- Period Boundaries via',i2,' x', & i2,' x',i2,' Cell Replicate Set') else if (max(nx,ny,nz) .lt. 100) then write (iout,30) nx,ny,nz 30 format (/,' REPLICA -- Period Boundaries via',i3,' x', & i3,' x',i3,' Cell Replicate Set') else write (iout,40) nx,ny,nz 40 format (/,' REPLICA -- Period Boundaries via',i4,' x', & i4,' x',i4,' Cell Replicate Set') end if 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 ## module reppot -- repulsion functional form details ## c ## ## c ############################################################ c c c r2scale scale factor for 1-2 repulsion energy interactions c r3scale scale factor for 1-3 repulsion energy interactions c r4scale scale factor for 1-4 repulsion energy interactions c r5scale scale factor for 1-5 repulsion energy interactions c c module reppot implicit none real*8 r2scale real*8 r3scale real*8 r4scale real*8 r5scale save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module resdue -- amino acid & nucleotide residue names ## c ## ## c ################################################################ c c c maxamino maximum number of amino acid residue types c maxnuc maximum number of nucleic acid residue types c c ntyp biotypes for mid-chain peptide backbone N atoms c catyp biotypes for mid-chain peptide backbone CA atoms c ctyp biotypes for mid-chain peptide backbone C atoms c hntyp biotypes for mid-chain peptide backbone HN atoms c otyp biotypes for mid-chain peptide backbone O atoms c hatyp biotypes for mid-chain peptide backbone HA atoms c cbtyp biotypes for mid-chain peptide backbone CB atoms c nntyp biotypes for N-terminal peptide backbone N atoms c cantyp biotypes for N-terminal peptide backbone CA atoms c cntyp biotypes for N-terminal peptide backbone C atoms c hnntyp biotypes for N-terminal peptide backbone HN atoms c ontyp biotypes for N-terminal peptide backbone O atoms c hantyp biotypes for N-terminal peptide backbone HA atoms c nctyp biotypes for C-terminal peptide backbone N atoms c cactyp biotypes for C-terminal peptide backbone CA atoms c cctyp biotypes for C-terminal peptide backbone C atoms c hnctyp biotypes for C-terminal peptide backbone HN atoms c octyp biotypes for C-terminal peptide backbone O atoms c hactyp biotypes for C-terminal peptide backbone HA atoms c o5typ biotypes for nucleotide backbone and sugar O5' atoms c c5typ biotypes for nucleotide backbone and sugar C5' atoms c h51typ biotypes for nucleotide backbone and sugar H5' atoms c h52typ biotypes for nucleotide backbone and sugar H5'' atoms c c4typ biotypes for nucleotide backbone and sugar C4' atoms c h4typ biotypes for nucleotide backbone and sugar H4' atoms c o4typ biotypes for nucleotide backbone and sugar O4' atoms c c1typ biotypes for nucleotide backbone and sugar C1' atoms c h1typ biotypes for nucleotide backbone and sugar H1' atoms c c3typ biotypes for nucleotide backbone and sugar C3' atoms c h3typ biotypes for nucleotide backbone and sugar H3' atoms c c2typ biotypes for nucleotide backbone and sugar C2' atoms c h21typ biotypes for nucleotide backbone and sugar H2' atoms c o2typ biotypes for nucleotide backbone and sugar O2' atoms c h22typ biotypes for nucleotide backbone and sugar H2'' atoms c o3typ biotypes for nucleotide backbone and sugar O3' atoms c ptyp biotypes for nucleotide backbone and sugar P atoms c optyp biotypes for nucleotide backbone and sugar OP atoms c h5ttyp biotypes for nucleotide backbone and sugar H5T atoms c h3ttyp biotypes for nucleotide backbone and sugar H3T atoms c amino three-letter abbreviations for amino acids types c nuclz three-letter abbreviations for nucleic acids types c amino1 one-letter abbreviations for amino acids types c nuclz1 one-letter abbreviations for nucleic acids types c c module resdue implicit none integer maxamino integer maxnuc parameter (maxamino=38) parameter (maxnuc=12) integer ntyp(maxamino) integer catyp(maxamino) integer ctyp(maxamino) integer hntyp(maxamino) integer otyp(maxamino) integer hatyp(maxamino) integer cbtyp(maxamino) integer nntyp(maxamino) integer cantyp(maxamino) integer cntyp(maxamino) integer hnntyp(maxamino) integer ontyp(maxamino) integer hantyp(maxamino) integer nctyp(maxamino) integer cactyp(maxamino) integer cctyp(maxamino) integer hnctyp(maxamino) integer octyp(maxamino) integer hactyp(maxamino) integer o5typ(maxnuc) integer c5typ(maxnuc) integer h51typ(maxnuc) integer h52typ(maxnuc) integer c4typ(maxnuc) integer h4typ(maxnuc) integer o4typ(maxnuc) integer c1typ(maxnuc) integer h1typ(maxnuc) integer c3typ(maxnuc) integer h3typ(maxnuc) integer c2typ(maxnuc) integer h21typ(maxnuc) integer o2typ(maxnuc) integer h22typ(maxnuc) integer o3typ(maxnuc) integer ptyp(maxnuc) integer optyp(maxnuc) integer h5ttyp(maxnuc) integer h3ttyp(maxnuc) character*1 amino1(maxamino) character*1 nuclz1(maxnuc) character*3 amino(maxamino) character*3 nuclz(maxnuc) save end c c c ################################################### c ## COPYRIGHT (C) 2011 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine respa -- r-RESPA molecular dynamics step ## c ## ## c ############################################################# c c c "respa" performs a single multiple time step molecular dynamics c step using the reversible reference system propagation algorithm c (r-RESPA) via a Verlet core with the potential split into fast- c and slow-evolving portions c c literature references: c c D. D. Humphreys, R. A. Friesner and B. J. Berne, "A Multiple- c Time-Step Molecular Dynamics Algorithm for Macromolecules", c Journal of Physical Chemistry, 98, 6885-6892 (1994) c c X. Qian and T. Schlick, "Efficient Multiple-Time-Step Integrators c with Distance-Based Force Splitting for Particle-Mesh-Ewald c Molecular Dynamics Simulations", Journal of Chemical Physics, c 115, 4019-4029 (2001) c c subroutine respa (istep,dt) use atomid use atoms use freeze use ielscf use mdstuf use moldyn use polar use units use usage use virial implicit none integer i,j,k,m integer istep real*8 dt,dt_2 real*8 dta,dta_2 real*8 epot,etot real*8 eksum real*8 temp,pres real*8 drespa real*8 erespa real*8 term real*8 ekin(3,3) real*8 stress(3,3) real*8 vrespa(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 for the dynamics integration c drespa = dble(nrespa) dt_2 = 0.5d0 * dt dta = dt / drespa dta_2 = 0.5d0 * dta c c store the current atom positions, then find half-step c velocities via velocity Verlet recursion c do i = 1, nuse m = iuse(i) do j = 1, 3 v(j,m) = v(j,m) + a(j,m)*dt_2 end do end do c c initialize virial from fast-evolving potential energy terms c do i = 1, 3 do j = 1, 3 vrespa(j,i) = 0.0d0 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 find fast-evolving velocities and positions via Verlet recursion c do k = 1, nrespa do i = 1, nuse m = iuse(i) do j = 1, 3 v(j,m) = v(j,m) + aalt(j,m)*dta_2 end do xold(m) = x(m) yold(m) = y(m) zold(m) = z(m) x(m) = x(m) + v(1,m)*dta y(m) = y(m) + v(2,m)*dta z(m) = z(m) + v(3,m)*dta end do if (use_rattle) call rattle (dta,xold,yold,zold) c c get the fast-evolving potential energy and atomic forces c call gradfast (erespa,derivs) c c use Newton's second law to get fast-evolving accelerations; c update fast-evolving velocities using the Verlet recursion c do i = 1, nuse m = iuse(i) do j = 1, 3 aalt(j,m) = -ekcal * derivs(j,m) / mass(m) v(j,m) = v(j,m) + aalt(j,m)*dta_2 end do end do if (use_rattle) call rattle2 (dta) c c find average virial from fast-evolving potential terms c do i = 1, 3 do j = 1, 3 vrespa(j,i) = vrespa(j,i) + vir(j,i)/drespa end do end do end do c c apply Verlet half-step updates for any auxiliary dipoles c if (use_ielscf) then do i = 1, nuse m = iuse(i) do j = 1, 3 vaux(j,m) = vaux(j,m) + aaux(j,m)*dt_2 vpaux(j,m) = vpaux(j,m) + apaux(j,m)*dt_2 uaux(j,m) = uaux(j,m) + vaux(j,m)*dt upaux(j,m) = upaux(j,m) + vpaux(j,m)*dt end do end do end if c c get the slow-evolving potential energy and atomic forces c call gradslow (epot,derivs) epot = epot + erespa 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 slow accelerations; c find full-step velocities using velocity Verlet recursion c do i = 1, nuse m = iuse(i) do j = 1, 3 a(j,m) = -ekcal * derivs(j,m) / mass(m) v(j,m) = v(j,m) + a(j,m)*dt_2 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 m = iuse(i) do j = 1, 3 aaux(j,m) = term * (uind(j,m)-uaux(j,m)) apaux(j,m) = term * (uinp(j,m)-upaux(j,m)) vaux(j,m) = vaux(j,m) + aaux(j,m)*dt_2 vpaux(j,m) = vpaux(j,m) + apaux(j,m)*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 increment total virial from sum of fast and slow parts c do i = 1, 3 do j = 1, 3 vir(j,i) = vir(j,i) + vrespa(j,i) end do end do 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 ## ## c ## subroutine gradfast -- fast energy & gradient components ## c ## ## c ################################################################## c c c "gradfast" calculates the potential energy and first derivatives c for the fast-evolving local valence potential energy terms c c subroutine gradfast (energy,derivs) use limits use potent implicit none real*8 energy real*8 derivs(3,*) logical save_vdw,save_repel logical save_disp,save_charge logical save_chgdpl,save_dipole logical save_mpole,save_polar logical save_chgtrn,save_rxnfld logical save_solv,save_list c c c save the original state of slow-evolving potentials c save_vdw = use_vdw save_repel = use_repel save_disp = use_disp save_charge = use_charge save_chgdpl = use_chgdpl save_dipole = use_dipole save_mpole = use_mpole save_polar = use_polar save_chgtrn = use_chgtrn save_rxnfld = use_rxnfld save_solv = use_solv save_list = use_list c c turn off slow-evolving nonbonded potential energy terms c use_vdw = .false. use_repel = .false. use_disp = .false. use_charge = .false. use_chgdpl = .false. use_dipole = .false. use_mpole = .false. use_polar = .false. use_chgtrn = .false. use_rxnfld = .false. use_solv = .false. use_list = .false. c c get energy and gradient for fast-evolving potential terms c call gradient (energy,derivs) c c restore the original state of slow-evolving potentials c use_vdw = save_vdw use_repel = save_repel use_disp = save_disp use_charge = save_charge use_chgdpl = save_chgdpl use_dipole = save_dipole use_mpole = save_mpole use_polar = save_polar use_chgtrn = save_chgtrn use_rxnfld = save_rxnfld use_solv = save_solv use_list = save_list return end c c c ################################################################## c ## ## c ## subroutine gradslow -- slow energy & gradient components ## c ## ## c ################################################################## c c c "gradslow" calculates the potential energy and first derivatives c for the slow-evolving nonbonded potential energy terms c c subroutine gradslow (energy,derivs) use potent implicit none real*8 energy real*8 derivs(3,*) logical save_bond,save_angle logical save_strbnd,save_urey logical save_angang,save_opbend logical save_opdist,save_improp logical save_imptor,save_tors logical save_pitors,save_strtor logical save_angtor,save_tortor logical save_geom,save_metal logical save_extra c c c save the original state of fast-evolving potentials c save_bond = use_bond save_angle = use_angle save_strbnd = use_strbnd save_urey = use_urey save_angang = use_angang save_opbend = use_opbend save_opdist = use_opdist save_improp = use_improp save_imptor = use_imptor save_tors = use_tors save_pitors = use_pitors save_strtor = use_strtor save_angtor = use_angtor save_tortor = use_tortor save_geom = use_geom save_metal = use_metal save_extra = use_extra c c turn off fast-evolving valence potential energy terms c use_bond = .false. use_angle = .false. use_strbnd = .false. use_urey = .false. use_angang = .false. use_opbend = .false. use_opdist = .false. use_improp = .false. use_imptor = .false. use_tors = .false. use_pitors = .false. use_strtor = .false. use_angtor = .false. use_tortor = .false. use_geom = .false. use_metal = .false. use_extra = .false. c c get energy and gradient for slow-evolving potential terms c call gradient (energy,derivs) c c restore the original state of fast-evolving potentials c use_bond = save_bond use_angle = save_angle use_strbnd = save_strbnd use_urey = save_urey use_angang = save_angang use_opbend = save_opbend use_opdist = save_opdist use_improp = save_improp use_imptor = save_imptor use_tors = save_tors use_pitors = save_pitors use_strtor = save_strtor use_angtor = save_angtor use_tortor = save_tortor use_geom = save_geom use_metal = save_metal use_extra = save_extra return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module restrn -- parameters for geometrical restraints ## c ## ## c ################################################################ c c c maxfix maximum number of geometric restraint entries c c npfix number of position restraints to be applied c ndfix number of distance restraints to be applied c nafix number of angle restraints to be applied c ntfix number of torsional restraints to be applied c ngfix number of group distance restraints to be applied c nchir number of chirality restraints to be applied c ipfix atom number involved in each position restraint c kpfix flags to use x-, y-, z-coordinate position restraints c idfix atom numbers defining each distance restraint c iafix atom numbers defining each angle restraint c itfix atom numbers defining each torsional restraint c igfix group numbers defining each group distance restraint c ichir atom numbers defining each chirality restraint c depth depth of shallow Gaussian basin restraint c width exponential width coefficient of Gaussian basin c rflat flat bottom radius for Gaussian basin restraint c rwall radius of spherical droplet boundary restraint c xpfix x-coordinate target for each restrained position c ypfix y-coordinate target for each restrained position c zpfix z-coordinate target for each restrained position c pfix force constant and flat-well range for each position c dfix force constant and target range for each distance c afix force constant and target range for each angle c tfix force constant and target range for each torsion c gfix force constant and target range for each group distance c chir force constant and target range for chiral centers c use_basin logical flag governing use of Gaussian basin c use_wall logical flag governing use of droplet boundary c c module restrn implicit none integer maxfix integer npfix,ndfix integer nafix,ntfix integer ngfix,nchir integer, allocatable :: ipfix(:) integer, allocatable :: kpfix(:,:) integer, allocatable :: idfix(:,:) integer, allocatable :: iafix(:,:) integer, allocatable :: itfix(:,:) integer, allocatable :: igfix(:,:) integer, allocatable :: ichir(:,:) real*8 depth,width real*8 rflat,rwall real*8, allocatable :: xpfix(:) real*8, allocatable :: ypfix(:) real*8, allocatable :: zpfix(:) real*8, allocatable :: pfix(:,:) real*8, allocatable :: dfix(:,:) real*8, allocatable :: afix(:,:) real*8, allocatable :: tfix(:,:) real*8, allocatable :: gfix(:,:) real*8, allocatable :: chir(:,:) logical use_basin,use_wall save end c c c ################################################### c ## COPYRIGHT (C) 2001 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module rgddyn -- rigid body MD velocities and momenta ## c ## ## c ############################################################### c c c xcmo x-component from each atom to center of rigid body c ycmo y-component from each atom to center of rigid body c zcmo z-component from each atom to center of rigid body c vcm current translational velocity of each rigid body c wcm current angular velocity of each rigid body c lm current angular momentum of each rigid body c vc half-step translational velocity for kinetic energy c wc half-step angular velocity for kinetic energy c linear logical flag to mark group as linear or nonlinear c c module rgddyn implicit none real*8, allocatable :: xcmo(:) real*8, allocatable :: ycmo(:) real*8, allocatable :: zcmo(:) real*8, allocatable :: vcm(:,:) real*8, allocatable :: wcm(:,:) real*8, allocatable :: lm(:,:) real*8, allocatable :: vc(:,:) real*8, allocatable :: wc(:,:) logical, allocatable :: linear(:) save end c c c ########################################################### c ## COPYRIGHT (C) 2001 by ## c ## Andrey Kutepov, Marina A. Vorobieva & Jay W. Ponder ## c ## All Rights Reserved ## c ########################################################### c c ################################################################## c ## ## c ## subroutine rgdstep -- rigid body molecular dynamics step ## c ## ## c ################################################################## c c c "rgdstep" performs a single molecular dynamics time step c via a rigid body integration algorithm c c literature reference: c c W. Smith, "Hail Euler and Farewell: Rotational Motion in the c Laboratory Frame", CCP5 Newsletter, February 2005 c c based on an original algorithm developed by Andrey Kutapov c and Marina A. Vorobieva, VNIITF, Russian Federal Nuclear c Center, Chelyabinsk, Russia, February 2001 c c subroutine rgdstep (istep,dt) use atomid use atoms use bound use group use iounit use rgddyn use units use virial implicit none integer i,j,k integer istep,size integer start,stop integer iter,maxiter real*8 dt,epot,etot real*8 eksum,weigh real*8 eps,delta real*8 temp,pres real*8 xr,yr,zr real*8 x2,y2,z2 real*8 fx,fy,fz real*8 fc(3),tc(3) real*8 inert(6) real*8 rc(3),rcold(3) real*8 dfi(3),dfiold(3) real*8 vcp(3),wcp(3) real*8 ekin(3,3) real*8 stress(3,3) real*8 arot(3,3) real*8, allocatable :: xp(:) real*8, allocatable :: yp(:) real*8, allocatable :: zp(:) real*8, allocatable :: derivs(:,:) c c c set iteration limit and tolerance for angular momenta c maxiter = 15 eps = 1.0d-12 c c perform dynamic allocation of some local arrays c allocate (xp(n)) allocate (yp(n)) allocate (zp(n)) allocate (derivs(3,n)) c c get the energy and atomic forces prior to the step c call gradient (epot,derivs) c c perform the integration step for each rigid body c do i = 1, ngrp start = igrp(1,i) stop = igrp(2,i) size = stop - start + 1 do j = 1, 3 rc(j) = 0.0d0 end do do j = start, stop k = kgrp(j) weigh = mass(k) rc(1) = rc(1) + x(k)*weigh rc(2) = rc(2) + y(k)*weigh rc(3) = rc(3) + z(k)*weigh end do do j = 1, 3 rc(j) = rc(j) / grpmass(i) end do c c find center of mass offsets only for first step c if (istep .eq. 1) then do j = start, stop k = kgrp(j) xcmo(k) = x(k) - rc(1) ycmo(k) = y(k) - rc(2) zcmo(k) = z(k) - rc(3) end do end if c c compute the force and torque components for rigid body c do j = 1, 3 fc(j) = 0.0d0 tc(j) = 0.0d0 end do do j = start, stop k = kgrp(j) xr = x(k) - rc(1) yr = y(k) - rc(2) zr = z(k) - rc(3) fx = -ekcal * derivs(1,k) fy = -ekcal * derivs(2,k) fz = -ekcal * derivs(3,k) fc(1) = fc(1) + fx fc(2) = fc(2) + fy fc(3) = fc(3) + fz tc(1) = tc(1) + yr*fz - zr*fy tc(2) = tc(2) + zr*fx - xr*fz tc(3) = tc(3) + xr*fy - yr*fx end do c c update the translational velocity of the center of mass c do j = 1, 3 vcp(j) = vcm(j,i) + dt*fc(j)/grpmass(i) vc(j,i) = 0.5d0 * (vcm(j,i)+vcp(j)) vcm(j,i) = vcp(j) end do c c update the coordinates of the group center of mass c do j = 1, 3 rcold(j) = rc(j) rc(j) = rc(j) + dt*vcp(j) end do c c single atom groups are treated as a separate case c if (size .eq. 1) then k = kgrp(igrp(1,i)) x(k) = rc(1) y(k) = rc(2) z(k) = rc(3) do j = 1, 3 wcm(j,i) = 0.0d0 lm(j,i) = 0.0d0 end do c c get impulse moment in fixed space coordinate system c else do j = 1, 3 lm(j,i) = lm(j,i) + dt*tc(j) dfi(j) = dt * wcm(j,i) dfiold(j) = dfi(j) end do c c use iterative scheme to converge the angular momenta c iter = 0 delta = 1.0d0 do while (delta.gt.eps .and. iter.lt.maxiter) iter = iter + 1 call rotrgd (dfi,arot) c c calculate the inertia tensor from rotated coordinates c do j = 1, 6 inert(j) = 0.0d0 end do do j = start, stop k = kgrp(j) xr = arot(1,1)*xcmo(k) + arot(1,2)*ycmo(k) & + arot(1,3)*zcmo(k) yr = arot(2,1)*xcmo(k) + arot(2,2)*ycmo(k) & + arot(2,3)*zcmo(k) zr = arot(3,1)*xcmo(k) + arot(3,2)*ycmo(k) & + arot(3,3)*zcmo(k) x2 = xr * xr y2 = yr * yr z2 = zr * zr weigh = mass(k) inert(1) = inert(1) + weigh*(y2+z2) inert(2) = inert(2) - weigh*xr*yr inert(3) = inert(3) - weigh*xr*zr inert(4) = inert(4) + weigh*(x2+z2) inert(5) = inert(5) - weigh*yr*zr inert(6) = inert(6) + weigh*(x2+y2) xp(k) = xr yp(k) = yr zp(k) = zr end do c c compute the angular velocity from the relation L=Iw c do j = 1, 3 wcp(j) = lm(j,i) end do if (linear(i)) then call linbody (i,inert,wcp) else call cholesky (3,inert,wcp) end if delta = 0.d0 do j = 1, 3 dfi(j) = 0.5d0 * dt * (wcm(j,i)+wcp(j)) delta = delta + abs(dfi(j)-dfiold(j)) dfiold(j) = dfi(j) end do end do c c check to make sure the angular momenta converged c if (delta .gt. eps) then write (iout,10) 10 format (/,' RGDSTEP -- Angular Momentum Convergence', & ' Failure') call prterr call fatal end if c c set the final angular velocity and atomic coordinates c do j = 1, 3 dfi(j) = dt * wcp(j) end do call rotrgd (dfi,arot) do j = start, stop k = kgrp(j) xr = x(k) - rcold(1) yr = y(k) - rcold(2) zr = z(k) - rcold(3) x(k) = arot(1,1)*xr + arot(1,2)*yr + arot(1,3)*zr + rc(1) y(k) = arot(2,1)*xr + arot(2,2)*yr + arot(2,3)*zr + rc(2) z(k) = arot(3,1)*xr + arot(3,2)*yr + arot(3,3)*zr + rc(3) end do do j = 1, 3 wc(j,i) = 0.5d0 * (wcm(j,i)+wcp(j)) wcm(j,i) = wcp(j) end do end if end do c c update the distance to center of mass for each atom c do i = 1, n xcmo(i) = xp(i) ycmo(i) = yp(i) zcmo(i) = zp(i) end do c c make center of mass correction to virial for rigid body c do i = 1, n vir(1,1) = vir(1,1) - xcmo(i)*derivs(1,i) vir(2,1) = vir(2,1) - ycmo(i)*derivs(1,i) vir(3,1) = vir(3,1) - zcmo(i)*derivs(1,i) vir(1,2) = vir(1,2) - xcmo(i)*derivs(2,i) vir(2,2) = vir(2,2) - ycmo(i)*derivs(2,i) vir(3,2) = vir(3,2) - zcmo(i)*derivs(2,i) vir(1,3) = vir(1,3) - xcmo(i)*derivs(3,i) vir(2,3) = vir(2,3) - ycmo(i)*derivs(3,i) vir(3,3) = vir(3,3) - zcmo(i)*derivs(3,i) end do c c perform deallocation of some local arrays c deallocate (xp) deallocate (yp) deallocate (zp) deallocate (derivs) c c make any temperature and pressure corrections c call temper2 (dt,temp) call pressure2 (epot,temp) 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 ## ## c ## subroutine rotrgd -- rigid dynamics rotation matrix ## c ## ## c ############################################################# c c c "rotrgd" finds the rotation matrix for a rigid body due c to a single step of dynamics c c subroutine rotrgd (dfi,arot) implicit none real*8 x,xc,xs real*8 y,yc,ys real*8 z,zc,zs real*8 cosine,sine real*8 anorm,coterm real*8 dfi(3) real*8 arot(3,3) c c c construct rotation matrix from angular distance c anorm = sqrt(dfi(1)**2 + dfi(2)**2 + dfi(3)**2) cosine = cos(anorm) sine = sin(anorm) coterm = 1.0d0 - cosine if (anorm .le. 0.0d0) anorm = 1.0d0 x = dfi(1) / anorm y = dfi(2) / anorm z = dfi(3) / anorm xc = x * coterm yc = y * coterm zc = z * coterm xs = x * sine ys = y * sine zs = z * sine arot(1,1) = xc*x + cosine arot(2,1) = xc*y + zs arot(3,1) = xc*z - ys arot(1,2) = yc*x - zs arot(2,2) = yc*y + cosine arot(3,2) = yc*z + xs arot(1,3) = zc*x + ys arot(2,3) = zc*y - xs arot(3,3) = zc*z + cosine return end c c c ############################################################### c ## ## c ## subroutine linbody -- angular velocity of linear body ## c ## ## c ############################################################### c c c "linbody" finds the angular velocity of a linear rigid body c given the inertia tensor and angular momentum c c subroutine linbody (i,inert,wcp) use atoms use group implicit none integer i,j,k real*8 rinv,rmin real*8 a11,a12,a22 real*8 b1,b2,w1,w2 real*8 wcp(3),rmol(3) real*8 r1(3),r2(3),r3(3) real*8 inert(6) c c c construct a normalized vector along the molecular axis c j = kgrp(igrp(1,i)) k = kgrp(igrp(2,i)) rmol(1) = x(k) - x(j) rmol(2) = y(k) - y(j) rmol(3) = z(k) - z(j) rinv = 1.0d0 / sqrt(rmol(1)**2+rmol(2)**2+rmol(3)**2) do j = 1, 3 rmol(j) = rmol(j) * rinv end do c c find two orthogonal vectors to complete coordinate frame c k = 1 rmin = abs(rmol(1)) do j = 2, 3 if (abs(rmol(j)) .lt. rmin) then k = j rmin = abs(rmol(j)) end if end do do j = 1, 3 r1(j) = -rmol(k) * rmol(j) end do r1(k) = 1.0d0 + r1(k) rinv = 1.0d0 / sqrt(r1(1)**2+r1(2)**2+r1(3)**2) do j = 1, 3 r1(j) = r1(j) * rinv end do r2(1) = r1(2)*rmol(3) - r1(3)*rmol(2) r2(2) = r1(3)*rmol(1) - r1(1)*rmol(3) r2(3) = r1(1)*rmol(2) - r1(2)*rmol(1) c c solve the 2-by-2 linear system for angular velocity c r3(1) = inert(1)*r1(1) + inert(2)*r1(2) + inert(3)*r1(3) r3(2) = inert(2)*r1(1) + inert(4)*r1(2) + inert(5)*r1(3) r3(3) = inert(3)*r1(1) + inert(5)*r1(2) + inert(6)*r1(3) a11 = r1(1)*r3(1) + r1(2)*r3(2) + r1(3)*r3(3) r3(1) = inert(1)*r2(1) + inert(2)*r2(2) + inert(3)*r2(3) r3(2) = inert(2)*r2(1) + inert(4)*r2(2) + inert(5)*r2(3) r3(3) = inert(3)*r2(1) + inert(5)*r2(2) + inert(6)*r2(3) a12 = r1(1)*r3(1) + r1(2)*r3(2) + r1(3)*r3(3) a22 = r2(1)*r3(1) + r2(2)*r3(2) + r2(3)*r3(3) b1 = r1(1)*wcp(1) + r1(2)*wcp(2) + r1(3)*wcp(3) b2 = r2(1)*wcp(1) + r2(2)*wcp(2) + r2(3)*wcp(3) w1 = (a12*b2-a22*b1) / (a12*a12-a11*a22) w2 = (b2-a12*w1) / a22 do j = 1, 3 wcp(j) = w1*r1(j) + w2*r2(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 richmond -- find the accessible surface area ## c ## ## c ################################################################# c c c "richmond" performs an analytical computation of the weighted c solvent accessible surface area of each atom and the first c derivatives of the area with respect to Cartesian coordinates c using the method of Tim Richmond c c literature references: c c T. J. Richmond, "Solvent Accessible Surface Area and c Excluded Volume in Proteins", Journal of Molecular Biology, c 178, 63-89 (1984) c c L. Wesson and D. Eisenberg, "Atomic Solvation Parameters c Applied to Molecular Dynamics of Proteins in Solution", c Protein Science, 1, 227-235 (1992) c c variables and parameters: c c n total number of atoms in the current 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 rad radius value in Angstroms for each sphere c weight weight value for each sphere in the system c probe radius value in Angstroms of the probe sphere c total total surface area of the whole structure c area accessible surface area of each atom c c delta tolerance used in the tests for sphere overlaps c and for colinearity c reps connectivity errors can usually be avoided if the c offending atom is shifted by this small amount c c subroutine richmond (n,x,y,z,rad,weight,probe,total,area) use inform use iounit use math use usage implicit none integer maxarc parameter (maxarc=1000) integer i,j,k,l,m,n integer ii,ib,jb integer io,ir integer mi,ni,narc integer key(maxarc) integer intag(maxarc) integer intag1(maxarc) integer lt(maxarc) integer kent(maxarc) integer kout(maxarc) real*8 total,wght real*8 delta,delta2 real*8 eps,reps,dsql real*8 probe,arcsum real*8 cosine real*8 axx,axy,axz real*8 ayx,ayy,azx real*8 azy,azz real*8 uxl,uyl,uzl real*8 tx,ty,tz real*8 txb,tyb,td real*8 tr2,tr,txr,tyr real*8 tk1,tk2 real*8 thec,the real*8 t,tb,txk,tyk,tzk real*8 t1,ti,tf,tt real*8 txl,tyl,tzl real*8 arclen,exang real*8 xr,yr,zr real*8 rr,rrx2,rrsq real*8 rplus,rminus real*8 ccsq,cc,xysq real*8 bk,gi,bsqk real*8 pix2,pix4,pid2 real*8 therk,dk,gk real*8 risqk,rik real*8 rvec(3) real*8 x(*) real*8 y(*) real*8 z(*) real*8 rad(*) real*8 weight(*) real*8 area(*) real*8 ri(maxarc),risq(maxarc) real*8 bsq(maxarc),bsq1(maxarc) real*8 dsq(maxarc),dsq1(maxarc) real*8 arci(maxarc),arcf(maxarc) real*8 ex(maxarc),gr(maxarc) real*8 b(maxarc),b1(maxarc) real*8 bg(maxarc),ther(maxarc) real*8 xc(maxarc),xc1(maxarc) real*8 yc(maxarc),yc1(maxarc) real*8 zc(maxarc),zc1(maxarc) real*8 ux(maxarc),uy(maxarc) real*8 uz(maxarc) real*8, allocatable :: r(:) logical moved,top,komit logical omit(maxarc) logical, allocatable :: skip(:) c c c perform dynamic allocation of some local arrays c allocate (r(n)) allocate (skip(n)) c c zero the area and derivatives, and set the sphere radii c total = 0.0d0 do i = 1, n area(i) = 0.0d0 r(i) = rad(i) if (r(i) .ne. 0.0d0) r(i) = r(i) + probe end do c c set pi multiples, overlap criterion and tolerances c pix2 = 2.0d0 * pi pix4 = 4.0d0 * pi pid2 = 0.5d0 * pi delta = 1.0d-8 delta2 = delta * delta eps = 1.0d-8 reps = 1.0d-6 c c exclude atoms that do not overlap any active atom c do i = 1, n skip(i) = .true. end do do i = 1, n if (use(i)) then xr = x(i) yr = y(i) zr = z(i) rr = r(i) do k = 1, n rplus = (rr + r(k))**2 ccsq = (x(k)-xr)**2 + (y(k)-yr)**2 + (z(k)-zr)**2 if (ccsq .le. rplus) skip(k) = .false. end do end if end do c c compute the accessible surface area of current "ir" sphere c do ir = 1, n if (skip(ir)) goto 180 xr = x(ir) yr = y(ir) zr = z(ir) rr = r(ir) rrx2 = 2.0d0 * rr rrsq = rr * rr wght = weight(ir) moved = .false. c c initialize some counters and sums for the "ir" sphere c 10 continue io = 0 jb = 0 ib = 0 arclen = 0.0d0 exang = 0.0d0 c c test each sphere to see if it overlaps the "ir" sphere c do i = 1, n if (i .eq. ir) goto 30 rplus = rr + r(i) tx = x(i) - xr if (abs(tx) .ge. rplus) goto 30 ty = y(i) - yr if (abs(ty) .ge. rplus) goto 30 tz = z(i) - zr if (abs(tz) .ge. rplus) goto 30 c c check for sphere overlap by testing interatomic c distance against sum and difference of radii c xysq = tx**2 + ty**2 if (xysq .lt. delta2) then tx = delta ty = 0.0d0 xysq = delta2 end if ccsq = xysq + tz**2 cc = sqrt(ccsq) if (rplus-cc .le. delta) goto 30 rminus = rr - r(i) c c check for a completely buried "ir" sphere c if (cc-abs(rminus) .le. delta) then if (rminus .le. 0.0d0) goto 180 goto 30 end if c c calculate overlap parameters between "i" and "ir" sphere c io = io + 1 xc1(io) = tx yc1(io) = ty zc1(io) = tz dsq1(io) = xysq bsq1(io) = ccsq b1(io) = cc gr(io) = (ccsq+rplus*rminus) / (rrx2*b1(io)) intag1(io) = i if (io .gt. maxarc) then write (iout,20) 20 format (/,' RICHMOND -- Increase the Value of MAXARC') call fatal end if 30 continue end do c c case where no other spheres overlap the current sphere c if (io .eq. 0) then area(ir) = pix4 goto 160 end if c c case where only one sphere overlaps the current sphere c if (io .eq. 1) then k = 1 txk = xc1(1) tyk = yc1(1) tzk = zc1(1) bsqk = bsq1(1) bk = b1(1) intag(1) = intag1(1) arcsum = pix2 ib = ib + 1 arclen = arclen + gr(k)*arcsum goto 150 end if c c general case where more than one sphere intersects the c current sphere; sort intersecting spheres by their degree c of overlap with the current main sphere c call sort2 (io,gr,key) do i = 1, io k = key(i) intag(i) = intag1(k) xc(i) = xc1(k) yc(i) = yc1(k) zc(i) = zc1(k) dsq(i) = dsq1(k) b(i) = b1(k) bsq(i) = bsq1(k) omit(i) = .false. end do c c radius of the each circle on the surface of the "ir" sphere c do i = 1, io gi = gr(i) * rr bg(i) = b(i) * gi risq(i) = rrsq - gi**2 ri(i) = sqrt(risq(i)) ther(i) = pid2 - asin(min(1.0d0,max(-1.0d0,gr(i)))) end do c c find boundary of inaccessible area on "ir" sphere c do k = 1, io-1 if (.not. omit(k)) then txk = xc(k) tyk = yc(k) tzk = zc(k) bk = b(k) therk = ther(k) do j = k+1, io if (omit(j)) goto 60 c c check to see if J circle is intersecting K circle; c get distance between circle centers and sum of radii c cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j)) cc = acos(min(1.0d0,max(-1.0d0,cc))) td = therk + ther(j) c c check to see if circles enclose separate regions c if (cc .ge. td) goto 60 c c check for circle J completely inside circle K c if (cc+ther(j) .lt. therk) goto 40 c c check for circles essentially parallel c if (cc .gt. delta) goto 50 40 continue omit(j) = .true. goto 60 c c check for "ir" sphere completely buried c 50 continue if (pix2-cc .le. td) goto 180 60 continue end do end if end do c c find T value of circle intersections c do k = 1, io if (omit(k)) goto 110 komit = omit(k) omit(k) = .true. narc = 0 top = .false. txk = xc(k) tyk = yc(k) tzk = zc(k) dk = sqrt(dsq(k)) bsqk = bsq(k) bk = b(k) gk = gr(k) * rr risqk = risq(k) rik = ri(k) therk = ther(k) c c rotation matrix elements c t1 = tzk / (bk*dk) axx = txk * t1 axy = tyk * t1 axz = dk / bk ayx = tyk / dk ayy = txk / dk azx = txk / bk azy = tyk / bk azz = tzk / bk do l = 1, io if (.not. omit(l)) then txl = xc(l) tyl = yc(l) tzl = zc(l) c c rotate spheres so K vector colinear with z-axis c uxl = txl*axx + tyl*axy - tzl*axz uyl = tyl*ayy - txl*ayx uzl = txl*azx + tyl*azy + tzl*azz cosine = min(1.0d0,max(-1.0d0,uzl/b(l))) if (acos(cosine) .lt. therk+ther(l)) then dsql = uxl**2 + uyl**2 tb = uzl*gk - bg(l) txb = uxl * tb tyb = uyl * tb td = rik * dsql tr2 = risqk*dsql - tb**2 tr2 = max(eps,tr2) tr = sqrt(tr2) txr = uxl * tr tyr = uyl * tr c c get T values of intersection for K circle c tb = (txb+tyr) / td tb = min(1.0d0,max(-1.0d0,tb)) tk1 = acos(tb) if (tyb-txr .lt. 0.0d0) tk1 = pix2 - tk1 tb = (txb-tyr) / td tb = min(1.0d0,max(-1.0d0,tb)) tk2 = acos(tb) if (tyb+txr .lt. 0.0d0) tk2 = pix2 - tk2 thec = (rrsq*uzl-gk*bg(l)) / (rik*ri(l)*b(l)) if (abs(thec) .lt. 1.0d0) then the = -acos(thec) else if (thec .ge. 1.0d0) then the = 0.0d0 else if (thec .le. -1.0d0) then the = -pi end if c c see if "tk1" is entry or exit point; check t=0 point; c "ti" is exit point, "tf" is entry point c cosine = min(1.0d0,max(-1.0d0, & (uzl*gk-uxl*rik)/(b(l)*rr))) if ((acos(cosine)-ther(l))*(tk2-tk1) & .le. 0.0d0) then ti = tk2 tf = tk1 else ti = tk1 tf = tk2 end if narc = narc + 1 if (narc .ge. maxarc) then write (iout,70) 70 format (/,' RICHMOND -- Increase the Value', & ' of MAXARC') call fatal end if if (tf .le. ti) then arcf(narc) = tf arci(narc) = 0.0d0 tf = pix2 lt(narc) = l ex(narc) = the top = .true. narc = narc + 1 end if arcf(narc) = tf arci(narc) = ti lt(narc) = l ex(narc) = the ux(l) = uxl uy(l) = uyl uz(l) = uzl end if end if end do omit(k) = komit c c special case; K circle without intersections c if (narc .le. 0) goto 90 c c general case; sum up arclength and set connectivity code c call sort2 (narc,arci,key) arcsum = arci(1) mi = key(1) t = arcf(mi) ni = mi if (narc .gt. 1) then do j = 2, narc m = key(j) if (t .lt. arci(j)) then arcsum = arcsum + arci(j) - t exang = exang + ex(ni) jb = jb + 1 if (jb .ge. maxarc) then write (iout,80) 80 format (/,' RICHMOND -- Increase the Value', & ' of MAXARC') call fatal end if l = lt(ni) kent(jb) = maxarc*l + k l = lt(m) kout(jb) = maxarc*k + l end if tt = arcf(m) if (tt .ge. t) then t = tt ni = m end if end do end if arcsum = arcsum + pix2 - t if (.not. top) then exang = exang + ex(ni) jb = jb + 1 l = lt(ni) kent(jb) = maxarc*l + k l = lt(mi) kout(jb) = maxarc*k + l end if goto 100 90 continue arcsum = pix2 ib = ib + 1 100 continue arclen = arclen + gr(k)*arcsum 110 continue end do if (arclen .eq. 0.0d0) goto 180 if (jb .eq. 0) goto 150 c c find number of independent boundaries and check connectivity c j = 0 do k = 1, jb if (kout(k) .ne. 0) then i = k 120 continue m = kout(i) kout(i) = 0 j = j + 1 do ii = 1, jb if (m .eq. kent(ii)) then if (ii .eq. k) then ib = ib + 1 if (j .eq. jb) goto 150 goto 130 end if i = ii goto 120 end if end do 130 continue end if end do ib = ib + 1 c c attempt to fix connectivity error by moving atom slightly c if (moved) then write (iout,140) ir 140 format (/,' RICHMOND -- Connectivity Error at Atom',i6) call fatal else moved = .true. call ranvec (rvec) xr = xr + reps*rvec(1) yr = yr + reps*rvec(2) zr = zr + reps*rvec(3) goto 10 end if c c form the accessible area for the current atom c 150 continue area(ir) = ib*pix2 + exang + arclen area(ir) = mod(area(ir),pix4) 160 continue area(ir) = area(ir) * rrsq c c attempt to fix negative area by moving atom slightly c if (area(ir) .lt. 0.0d0) then if (moved) then write (iout,170) ir 170 format (/,' RICHMOND -- Negative Area at Atom',i6) call fatal else moved = .true. call ranvec (rvec) xr = xr + reps*rvec(1) yr = yr + reps*rvec(2) zr = zr + reps*rvec(3) goto 10 end if end if c c weight the accessible area by the scale factor c area(ir) = area(ir) * wght total = total + area(ir) 180 continue end do c c print out the surface area values for each atom c if (debug) then write (iout,190) 190 format (/,' Weighted Atomic Surface Areas Values :', & //,4x,'Atom',7x,'Area Term',6x,'Weight',/) do i = 1, n if (.not. skip(i)) then write (iout,200) i,area(i),weight(i) 200 format (i8,4x,2f12.4) end if end do write (iout,210) total 210 format (/,' Total Weighted Surface Area :',5x,f16.4) end if c c perform deallocation of some local arrays c deallocate (r) deallocate (skip) return end c c c ################################################################## c ## ## c ## subroutine richmond1 -- accessible surface area & derivs ## c ## ## c ################################################################## c c c "richmond1" performs an analytical computation of the weighted c solvent accessible surface area of each atom and the first c derivatives of the area with respect to Cartesian coordinates c using the method of Tim Richmond c c literature references: c c T. J. Richmond, "Solvent Accessible Surface Area and c Excluded Volume in Proteins", Journal of Molecular Biology, c 178, 63-89 (1984) c c L. Wesson and D. Eisenberg, "Atomic Solvation Parameters c Applied to Molecular Dynamics of Proteins in Solution", c Protein Science, 1, 227-235 (1992) c c variables and parameters: c c n total number of atoms in the current 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 rad radius value in Angstroms for each sphere c weight weight value for each sphere in the system c probe radius value in Angstroms of the probe sphere c total total surface area of the whole structure c area accessible surface area of each atom c darea x,y,z components of the gradient of the area of c the molecule with respect to atomic coordinates c c delta tolerance used in the tests for sphere overlaps c and for colinearity c reps connectivity errors can usually be avoided if the c offending atom is shifted by this small amount c c subroutine richmond1 (n,x,y,z,rad,weight,probe, & total,area,darea) use inform use iounit use math use usage implicit none integer maxarc parameter (maxarc=1000) integer i,j,k,l,m,n integer ii,ib,jb integer in,io,ir integer mi,ni,narc integer key(maxarc) integer intag(maxarc) integer intag1(maxarc) integer lt(maxarc) integer kent(maxarc) integer kout(maxarc) integer ider(maxarc) integer sign_yder(maxarc) real*8 total,wght real*8 delta,delta2 real*8 eps,reps,dsql real*8 probe,arcsum real*8 cosine real*8 wxl,wxlsq real*8 p,s,v,rcn real*8 axx,axy,axz real*8 ayx,ayy,azx real*8 azy,azz real*8 uxl,uyl,uzl real*8 tx,ty,tz real*8 txb,tyb,t2,td real*8 tr2,tr,txr,tyr real*8 tk1,tk2 real*8 thec,the real*8 t,tb,txk,tyk,tzk real*8 t1,ti,tf,tt real*8 txl,tyl,tzl real*8 arclen,exang real*8 xr,yr,zr real*8 rr,rrx2,rrsq real*8 rplus,rminus real*8 ccsq,cc,xysq real*8 bgl,bsqk,bsql real*8 bk,gi,gl real*8 pix2,pix4,pid2 real*8 dax,day,daz real*8 deal,decl real*8 dtkal,dtkcl real*8 dtlal,dtlcl real*8 therk,dk,gk real*8 risqk,rik,risql real*8 faca,facb,facc real*8 gaca,gacb real*8 rvec(3) real*8 x(*) real*8 y(*) real*8 z(*) real*8 rad(*) real*8 weight(*) real*8 area(*) real*8 darea(3,*) real*8 ri(maxarc),risq(maxarc) real*8 bsq(maxarc),bsq1(maxarc) real*8 dsq(maxarc),dsq1(maxarc) real*8 arci(maxarc),arcf(maxarc) real*8 ex(maxarc),gr(maxarc) real*8 b(maxarc),b1(maxarc) real*8 bg(maxarc),ther(maxarc) real*8 xc(maxarc),xc1(maxarc) real*8 yc(maxarc),yc1(maxarc) real*8 zc(maxarc),zc1(maxarc) real*8 ux(maxarc),uy(maxarc) real*8 uz(maxarc) real*8, allocatable :: r(:) logical moved,top,komit logical omit(maxarc) logical, allocatable :: skip(:) c c c perform dynamic allocation of some local arrays c allocate (r(n)) allocate (skip(n)) c c zero the area and derivatives, and set the sphere radii c total = 0.0d0 do i = 1, n area(i) = 0.0d0 darea(1,i) = 0.0d0 darea(2,i) = 0.0d0 darea(3,i) = 0.0d0 r(i) = rad(i) if (r(i) .ne. 0.0d0) r(i) = r(i) + probe end do c c set pi multiples, overlap criterion and tolerances c pix2 = 2.0d0 * pi pix4 = 4.0d0 * pi pid2 = 0.5d0 * pi delta = 1.0d-8 delta2 = delta * delta eps = 1.0d-8 reps = 1.0d-6 do i = 1, maxarc ider(i) = 0 sign_yder(i) = 0 end do c c exclude atoms that do not overlap any active atom c do i = 1, n skip(i) = .true. end do do i = 1, n if (use(i)) then xr = x(i) yr = y(i) zr = z(i) rr = r(i) do k = 1, n rplus = (rr + r(k))**2 ccsq = (x(k)-xr)**2 + (y(k)-yr)**2 + (z(k)-zr)**2 if (ccsq .le. rplus) skip(k) = .false. end do end if end do c c compute the area and derivatives of current "ir" sphere c do ir = 1, n if (skip(ir)) goto 180 xr = x(ir) yr = y(ir) zr = z(ir) rr = r(ir) rrx2 = 2.0d0 * rr rrsq = rr * rr wght = weight(ir) moved = .false. c c initialize some counters and sums for the "ir" sphere c 10 continue io = 0 jb = 0 ib = 0 arclen = 0.0d0 exang = 0.0d0 c c test each sphere to see if it overlaps the "ir" sphere c do i = 1, n if (i .eq. ir) goto 30 rplus = rr + r(i) tx = x(i) - xr if (abs(tx) .ge. rplus) goto 30 ty = y(i) - yr if (abs(ty) .ge. rplus) goto 30 tz = z(i) - zr if (abs(tz) .ge. rplus) goto 30 c c check for sphere overlap by testing interatomic c distance against sum and difference of radii c xysq = tx**2 + ty**2 if (xysq .lt. delta2) then tx = delta ty = 0.0d0 xysq = delta2 end if ccsq = xysq + tz**2 cc = sqrt(ccsq) if (rplus-cc .le. delta) goto 30 rminus = rr - r(i) c c check for a completely buried "ir" sphere c if (cc-abs(rminus) .le. delta) then if (rminus .le. 0.0d0) goto 180 goto 30 end if c c calculate overlap parameters between "i" and "ir" sphere c io = io + 1 xc1(io) = tx yc1(io) = ty zc1(io) = tz dsq1(io) = xysq bsq1(io) = ccsq b1(io) = cc gr(io) = (ccsq+rplus*rminus) / (rrx2*b1(io)) intag1(io) = i if (io .gt. maxarc) then write (iout,20) 20 format (/,' RICHMOND1 -- Increase the Value of MAXARC') call fatal end if 30 continue end do c c case where no other spheres overlap the current sphere c if (io .eq. 0) then area(ir) = pix4 goto 160 end if c c case where only one sphere overlaps the current sphere c if (io .eq. 1) then k = 1 txk = xc1(1) tyk = yc1(1) tzk = zc1(1) bsqk = bsq1(1) bk = b1(1) intag(1) = intag1(1) arcsum = pix2 ib = ib + 1 arclen = arclen + gr(k)*arcsum if (.not. moved) then in = intag(k) t1 = arcsum*rrsq*(bsqk-rrsq+r(in)**2) / (rrx2*bsqk*bk) darea(1,ir) = darea(1,ir) - txk*t1*wght darea(2,ir) = darea(2,ir) - tyk*t1*wght darea(3,ir) = darea(3,ir) - tzk*t1*wght darea(1,in) = darea(1,in) + txk*t1*wght darea(2,in) = darea(2,in) + tyk*t1*wght darea(3,in) = darea(3,in) + tzk*t1*wght end if goto 150 end if c c general case where more than one sphere intersects the c current sphere; sort intersecting spheres by their degree c of overlap with the current main sphere c call sort2 (io,gr,key) do i = 1, io k = key(i) intag(i) = intag1(k) xc(i) = xc1(k) yc(i) = yc1(k) zc(i) = zc1(k) dsq(i) = dsq1(k) b(i) = b1(k) bsq(i) = bsq1(k) omit(i) = .false. end do c c radius of the each circle on the surface of the "ir" sphere c do i = 1, io gi = gr(i) * rr bg(i) = b(i) * gi risq(i) = rrsq - gi**2 ri(i) = sqrt(risq(i)) ther(i) = pid2 - asin(min(1.0d0,max(-1.0d0,gr(i)))) end do c c find boundary of inaccessible area on "ir" sphere c do k = 1, io-1 if (.not. omit(k)) then txk = xc(k) tyk = yc(k) tzk = zc(k) bk = b(k) therk = ther(k) do j = k+1, io if (omit(j)) goto 60 c c check to see if J circle is intersecting K circle; c get distance between circle centers and sum of radii c cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j)) cc = acos(min(1.0d0,max(-1.0d0,cc))) td = therk + ther(j) c c check to see if circles enclose separate regions c if (cc .ge. td) goto 60 c c check for circle J completely inside circle K c if (cc+ther(j) .lt. therk) goto 40 c c check for circles essentially parallel c if (cc .gt. delta) goto 50 40 continue omit(j) = .true. goto 60 c c check for "ir" sphere completely buried c 50 continue if (pix2-cc .le. td) goto 180 60 continue end do end if end do c c find T value of circle intersections c do k = 1, io if (omit(k)) goto 110 komit = omit(k) omit(k) = .true. narc = 0 top = .false. txk = xc(k) tyk = yc(k) tzk = zc(k) dk = sqrt(dsq(k)) bsqk = bsq(k) bk = b(k) gk = gr(k) * rr risqk = risq(k) rik = ri(k) therk = ther(k) c c rotation matrix elements c t1 = tzk / (bk*dk) axx = txk * t1 axy = tyk * t1 axz = dk / bk ayx = tyk / dk ayy = txk / dk azx = txk / bk azy = tyk / bk azz = tzk / bk do l = 1, io if (.not. omit(l)) then txl = xc(l) tyl = yc(l) tzl = zc(l) c c rotate spheres so K vector colinear with z-axis c uxl = txl*axx + tyl*axy - tzl*axz uyl = tyl*ayy - txl*ayx uzl = txl*azx + tyl*azy + tzl*azz cosine = min(1.0d0,max(-1.0d0,uzl/b(l))) if (acos(cosine) .lt. therk+ther(l)) then dsql = uxl**2 + uyl**2 tb = uzl*gk - bg(l) txb = uxl * tb tyb = uyl * tb td = rik * dsql tr2 = risqk*dsql - tb**2 tr2 = max(eps,tr2) tr = sqrt(tr2) txr = uxl * tr tyr = uyl * tr c c get T values of intersection for K circle c tb = (txb+tyr) / td tb = min(1.0d0,max(-1.0d0,tb)) tk1 = acos(tb) if (tyb-txr .lt. 0.0d0) tk1 = pix2 - tk1 tb = (txb-tyr) / td tb = min(1.0d0,max(-1.0d0,tb)) tk2 = acos(tb) if (tyb+txr .lt. 0.0d0) tk2 = pix2 - tk2 thec = (rrsq*uzl-gk*bg(l)) / (rik*ri(l)*b(l)) if (abs(thec) .lt. 1.0d0) then the = -acos(thec) else if (thec .ge. 1.0d0) then the = 0.0d0 else if (thec .le. -1.0d0) then the = -pi end if c c see if "tk1" is entry or exit point; check t=0 point; c "ti" is exit point, "tf" is entry point c cosine = min(1.0d0,max(-1.0d0, & (uzl*gk-uxl*rik)/(b(l)*rr))) if ((acos(cosine)-ther(l))*(tk2-tk1) & .le. 0.0d0) then ti = tk2 tf = tk1 else ti = tk1 tf = tk2 end if narc = narc + 1 if (narc .ge. maxarc) then write (iout,70) 70 format (/,' RICHMOND1 -- Increase the Value', & ' of MAXARC') call fatal end if if (tf .le. ti) then arcf(narc) = tf arci(narc) = 0.0d0 tf = pix2 lt(narc) = l ex(narc) = the top = .true. narc = narc + 1 end if arcf(narc) = tf arci(narc) = ti lt(narc) = l ex(narc) = the ux(l) = uxl uy(l) = uyl uz(l) = uzl end if end if end do omit(k) = komit c c special case; K circle without intersections c if (narc .le. 0) goto 90 c c general case; sum up arclength and set connectivity code c call sort2 (narc,arci,key) arcsum = arci(1) mi = key(1) t = arcf(mi) ni = mi if (narc .gt. 1) then do j = 2, narc m = key(j) if (t .lt. arci(j)) then arcsum = arcsum + arci(j) - t exang = exang + ex(ni) jb = jb + 1 if (jb .ge. maxarc) then write (iout,80) 80 format (/,' RICHMOND1 -- Increase the Value', & ' of MAXARC') call fatal end if l = lt(ni) ider(l) = ider(l) + 1 sign_yder(l) = sign_yder(l) + 1 kent(jb) = maxarc*l + k l = lt(m) ider(l) = ider(l) + 1 sign_yder(l) = sign_yder(l) - 1 kout(jb) = maxarc*k + l end if tt = arcf(m) if (tt .ge. t) then t = tt ni = m end if end do end if arcsum = arcsum + pix2 - t if (.not. top) then exang = exang + ex(ni) jb = jb + 1 l = lt(ni) ider(l) = ider(l) + 1 sign_yder(l) = sign_yder(l) + 1 kent(jb) = maxarc*l + k l = lt(mi) ider(l) = ider(l) + 1 sign_yder(l) = sign_yder(l) - 1 kout(jb) = maxarc*k + l end if c c calculate the surface area derivatives c do l = 1, io if (ider(l) .ne. 0) then rcn = ider(l) * rrsq ider(l) = 0 uzl = uz(l) gl = gr(l) * rr bgl = bg(l) bsql = bsq(l) risql = risq(l) wxlsq = bsql - uzl**2 wxl = sqrt(wxlsq) p = bgl - gk*uzl v = risqk*wxlsq - p**2 v = max(eps,v) v = sqrt(v) t1 = rr * (gk*(bgl-bsql)+uzl*(bgl-rrsq)) & / (v*risql*bsql) deal = -wxl*t1 decl = -uzl*t1 - rr/v dtkal = (wxlsq-p) / (wxl*v) dtkcl = (uzl-gk) / v s = gk*b(l) - gl*uzl t1 = 2.0d0*gk - uzl t2 = rrsq - bgl dtlal = -(risql*wxlsq*b(l)*t1 & -s*(wxlsq*t2+risql*bsql)) & / (risql*wxl*bsql*v) dtlcl = -(risql*b(l)*(uzl*t1-bgl)-uzl*t2*s) & / (risql*bsql*v) gaca = rcn * (deal-(gk*dtkal-gl*dtlal)/rr) / wxl gacb = (gk-uzl*gl/b(l)) * sign_yder(l) * rr / wxlsq sign_yder(l) = 0 if (.not. moved) then faca = ux(l)*gaca - uy(l)*gacb facb = uy(l)*gaca + ux(l)*gacb facc = rcn * (decl-(gk*dtkcl-gl*dtlcl)/rr) dax = axx*faca - ayx*facb + azx*facc day = axy*faca + ayy*facb + azy*facc daz = azz*facc - axz*faca in = intag(l) darea(1,ir) = darea(1,ir) + dax*wght darea(2,ir) = darea(2,ir) + day*wght darea(3,ir) = darea(3,ir) + daz*wght darea(1,in) = darea(1,in) - dax*wght darea(2,in) = darea(2,in) - day*wght darea(3,in) = darea(3,in) - daz*wght end if end if end do goto 100 90 continue arcsum = pix2 ib = ib + 1 100 continue arclen = arclen + gr(k)*arcsum if (.not. moved) then in = intag(k) t1 = arcsum*rrsq*(bsqk-rrsq+r(in)**2) / (rrx2*bsqk*bk) darea(1,ir) = darea(1,ir) - txk*t1*wght darea(2,ir) = darea(2,ir) - tyk*t1*wght darea(3,ir) = darea(3,ir) - tzk*t1*wght darea(1,in) = darea(1,in) + txk*t1*wght darea(2,in) = darea(2,in) + tyk*t1*wght darea(3,in) = darea(3,in) + tzk*t1*wght end if 110 continue end do if (arclen .eq. 0.0d0) goto 180 if (jb .eq. 0) goto 150 c c find number of independent boundaries and check connectivity c j = 0 do k = 1, jb if (kout(k) .ne. 0) then i = k 120 continue m = kout(i) kout(i) = 0 j = j + 1 do ii = 1, jb if (m .eq. kent(ii)) then if (ii .eq. k) then ib = ib + 1 if (j .eq. jb) goto 150 goto 130 end if i = ii goto 120 end if end do 130 continue end if end do ib = ib + 1 c c attempt to fix connectivity error by moving atom slightly c if (moved) then write (iout,140) ir 140 format (/,' RICHMOND1 -- Connectivity Error at Atom',i6) call fatal else moved = .true. call ranvec (rvec) xr = xr + reps*rvec(1) yr = yr + reps*rvec(2) zr = zr + reps*rvec(3) goto 10 end if c c form the accessible area for the current atom c 150 continue area(ir) = ib*pix2 + exang + arclen area(ir) = mod(area(ir),pix4) 160 continue area(ir) = area(ir) * rrsq c c attempt to fix negative area by moving atom slightly c if (area(ir) .lt. 0.0d0) then if (moved) then write (iout,170) ir 170 format (/,' RICHMOND1 -- Negative Area at Atom',i6) call fatal else moved = .true. call ranvec (rvec) xr = xr + reps*rvec(1) yr = yr + reps*rvec(2) zr = zr + reps*rvec(3) goto 10 end if end if c c weight the accessible area by the scale factor c area(ir) = area(ir) * wght total = total + area(ir) 180 continue end do c c zero out the area derivatives for the inactive atoms c do i = 1, n if (.not. use(i)) then darea(1,i) = 0.0d0 darea(2,i) = 0.0d0 darea(3,i) = 0.0d0 end if end do c c print out the surface area and derivatives for each atom c if (debug) then write (iout,190) 190 format (/,' Weighted Atomic Surface Areas and Derivatives :', & //,4x,'Atom',7x,'Area Term',10x,'dA/dx', & 7x,'dA/dy',7x,'dA/dz',6x,'Weight',/) do i = 1, n if (.not. skip(i)) then write (iout,200) i,area(i),(darea(j,i),j=1,3),weight(i) 200 format (i8,4x,f12.4,3x,3f12.4,f12.4) end if end do write (iout,210) total 210 format (/,' Total Weighted Surface Area :',5x,f16.4) end if c c perform deallocation of some local arrays c deallocate (r) deallocate (skip) return end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module rigid -- rigid body coordinates for atom groups ## c ## ## c ################################################################ c c c xrb rigid body reference x-coordinate for each atom c yrb rigid body reference y-coordinate for each atom c zrb rigid body reference z-coordinate for each atom c rbc current rigid body coordinates for each group c use_rigid flag to mark use of rigid body coordinate system c c module rigid implicit none real*8, allocatable :: xrb(:) real*8, allocatable :: yrb(:) real*8, allocatable :: zrb(:) real*8, allocatable :: rbc(:,:) logical use_rigid save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module ring -- number and location of ring structures ## c ## ## c ############################################################### c c c nring3 total number of 3-membered rings in the system c nring4 total number of 4-membered rings in the system c nring5 total number of 5-membered rings in the system c nring6 total number of 6-membered rings in the system c nring7 total number of 7-membered rings in the system c iring3 numbers of the atoms involved in each 3-ring c iring4 numbers of the atoms involved in each 4-ring c iring5 numbers of the atoms involved in each 5-ring c iring6 numbers of the atoms involved in each 6-ring c iring7 numbers of the atoms involved in each 7-ring c c module ring implicit none integer nring3 integer nring4 integer nring5 integer nring6 integer nring7 integer, allocatable :: iring3(:,:) integer, allocatable :: iring4(:,:) integer, allocatable :: iring5(:,:) integer, allocatable :: iring6(:,:) integer, allocatable :: iring7(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################## c ## ## c ## subroutine rings -- locate and store small rings ## c ## ## c ########################################################## c c c "rings" searches the structure for small rings and stores c their constituent atoms, and optionally reduces large rings c into their component smaller rings c c note by default reducible rings are not removed since they c are needed for force field parameter assignment c c subroutine rings use angbnd use atoms use bitor use bndstr use couple use inform use iounit use ring use tors implicit none integer i,j,k,m integer kk,imax integer ia,ib,ic,id integer ie,ig,ih integer list1,list2 integer list3,list4 integer maxring integer, allocatable :: list(:) logical reduce c c c zero out the number of small rings in the structure c reduce = .false. nring3 = 0 nring4 = 0 nring5 = 0 nring6 = 0 nring7 = 0 c c parse to find bonds, angles, torsions and bitorsions c if (nbond .eq. 0) call bonds if (nangle .eq. 0) call angles if (ntors .eq. 0) call torsions if (nbitor .eq. 0) call bitors c c perform dynamic allocation of some global arrays c maxring = 10000 if (.not. allocated(iring3)) allocate (iring3(3,maxring)) if (.not. allocated(iring4)) allocate (iring4(4,maxring)) if (.not. allocated(iring5)) allocate (iring5(5,maxring)) if (.not. allocated(iring6)) allocate (iring6(6,maxring)) if (.not. allocated(iring7)) allocate (iring7(7,maxring)) c c search for and store all of the 3-membered rings c do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) if (ib.lt.ia .and. ib.lt.ic) then do j = 1, n12(ia) if (i12(j,ia) .eq. ic) then nring3 = nring3 + 1 if (nring3 .gt. maxring) then write (iout,10) 10 format (/,' RINGS -- Too many 3-Membered Rings;', & ' Increase MAXRING') call fatal end if iring3(1,nring3) = ia iring3(2,nring3) = ib iring3(3,nring3) = ic goto 20 end if end do 20 continue end if end do c c perform dynamic allocation of some local arrays c allocate (list(n)) c c search for and store all of the 4-membered rings c do i = 1, n list(i) = 0 end do do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) if (ia.lt.ic .and. id.lt.ib) then do j = 1, n12(ia) if (i12(j,ia) .eq. id) then nring4 = nring4 + 1 if (nring4 .gt. maxring) then write (iout,30) 30 format (/,' RINGS -- Too many 4-Membered Rings;', & ' Increase MAXRING') call fatal end if iring4(1,nring4) = ia iring4(2,nring4) = ib iring4(3,nring4) = ic iring4(4,nring4) = id c c remove the ring if it is reducible into smaller rings c if (reduce) then list(ia) = nring4 list(ib) = nring4 list(ic) = nring4 list(id) = nring4 do m = 1, nring3 list1 = list(iring3(1,m)) list2 = list(iring3(2,m)) list3 = list(iring3(3,m)) if (list1.eq.nring4 .and. & list2.eq.nring4 .and. & list3.eq.nring4) then nring4 = nring4 - 1 list(ia) = 0 list(ib) = 0 list(ic) = 0 list(id) = 0 goto 40 end if end do end if goto 40 end if end do 40 continue end if end do c c search for and store all of the 5-membered rings c do i = 1, n list(i) = 0 end do do i = 1, nbitor ia = ibitor(1,i) ib = ibitor(2,i) ic = ibitor(3,i) id = ibitor(4,i) ie = ibitor(5,i) if (ia.lt.id .and. ie.lt.ib .and. min(ia,ie).lt.ic) then do j = 1, n12(ia) if (i12(j,ia) .eq. ie) then nring5 = nring5 + 1 if (nring5 .gt. maxring) then write (iout,50) 50 format (/,' RINGS -- Too many 5-Membered Rings;', & ' Increase MAXRING') call fatal end if iring5(1,nring5) = ia iring5(2,nring5) = ib iring5(3,nring5) = ic iring5(4,nring5) = id iring5(5,nring5) = ie c c remove the ring if it is reducible into smaller rings c if (reduce) then list(ia) = nring5 list(ib) = nring5 list(ic) = nring5 list(id) = nring5 list(ie) = nring5 do m = 1, nring3 list1 = list(iring3(1,m)) list2 = list(iring3(2,m)) list3 = list(iring3(3,m)) if (list1.eq.nring5 .and. & list2.eq.nring5 .and. & list3.eq.nring5) then nring5 = nring5 - 1 list(ia) = 0 list(ib) = 0 list(ic) = 0 list(id) = 0 list(ie) = 0 goto 60 end if end do end if goto 60 end if end do 60 continue end if end do c c search for and store all of the 6-membered rings c do i = 1, n list(i) = 0 end do do i = 1, nbitor ia = ibitor(1,i) ib = ibitor(2,i) ic = ibitor(3,i) id = ibitor(4,i) ie = ibitor(5,i) imax = max(ia,ib,ic,id,ie) do j = 1, n12(ia) ig = i12(j,ia) if (ig .gt. imax) then do k = 1, n12(ie) if (i12(k,ie) .eq. ig) then nring6 = nring6 + 1 if (nring6 .gt. maxring) then write (iout,70) 70 format (/,' RINGS -- Too many 6-Membered', & ' Rings; Increase MAXRING') call fatal end if iring6(1,nring6) = ia iring6(2,nring6) = ib iring6(3,nring6) = ic iring6(4,nring6) = id iring6(5,nring6) = ie iring6(6,nring6) = ig c c remove the ring if it is reducible into smaller rings c if (reduce) then list(ia) = nring6 list(ib) = nring6 list(ic) = nring6 list(id) = nring6 list(ie) = nring6 list(ig) = nring6 do m = 1, nring3 list1 = list(iring3(1,m)) list2 = list(iring3(2,m)) list3 = list(iring3(3,m)) if (list1.eq.nring6 .and. & list2.eq.nring6 .and. & list3.eq.nring6) then nring6 = nring6 - 1 list(ia) = 0 list(ib) = 0 list(ic) = 0 list(id) = 0 list(ie) = 0 list(ig) = 0 goto 80 end if end do do m = 1, nring4 list1 = list(iring4(1,m)) list2 = list(iring4(2,m)) list3 = list(iring4(3,m)) list4 = list(iring4(4,m)) if (list1.eq.nring6 .and. & list2.eq.nring6 .and. & list3.eq.nring6 .and. & list4.eq.nring6) then nring6 = nring6 - 1 list(ia) = 0 list(ib) = 0 list(ic) = 0 list(id) = 0 list(ie) = 0 list(ig) = 0 goto 80 end if end do end if 80 continue end if end do end if end do end do c c search for and store all of the 7-membered rings c do i = 1, n list(i) = 0 end do do i = 1, nbitor ia = ibitor(1,i) ib = ibitor(2,i) ic = ibitor(3,i) id = ibitor(4,i) ie = ibitor(5,i) imax = max(ia,ib,ic,id,ie) do j = 1, n12(ia) ih = i12(j,ia) do k = 1, n12(ie) ig = i12(k,ie) if (ig.ne.id .and. ih.ne.ib .and. & ((ig.gt.imax.and.ih.gt.ie) .or. & (ih.gt.imax.and.ig.gt.ia))) then do kk = 1, n12(ig) if (i12(kk,ig) .eq. ih) then nring7 = nring7 + 1 if (nring7 .gt. maxring) then write (iout,90) 90 format (/,' RINGS -- Too many 7-Membered', & ' Rings; Increase MAXRING') call fatal end if iring7(1,nring7) = ia iring7(2,nring7) = ib iring7(3,nring7) = ic iring7(4,nring7) = id iring7(5,nring7) = ie iring7(6,nring7) = ig iring7(7,nring7) = ih c c remove the ring if it is reducible into smaller rings c if (reduce) then list(ia) = nring7 list(ib) = nring7 list(ic) = nring7 list(id) = nring7 list(ie) = nring7 list(ig) = nring7 list(ih) = nring7 do m = 1, nring3 list1 = list(iring3(1,m)) list2 = list(iring3(2,m)) list3 = list(iring3(3,m)) if (list1.eq.nring7 .and. & list2.eq.nring7 .and. & list3.eq.nring7) then nring7 = nring7 - 1 list(ia) = 0 list(ib) = 0 list(ic) = 0 list(id) = 0 list(ie) = 0 list(ig) = 0 list(ih) = 0 goto 100 end if end do do m = 1, nring4 list1 = list(iring4(1,m)) list2 = list(iring4(2,m)) list3 = list(iring4(3,m)) list4 = list(iring4(4,m)) if (list1.eq.nring7 .and. & list2.eq.nring7 .and. & list3.eq.nring7 .and. & list4.eq.nring7) then nring7 = nring7 - 1 list(ia) = 0 list(ib) = 0 list(ic) = 0 list(id) = 0 list(ie) = 0 list(ig) = 0 list(ih) = 0 goto 100 end if end do end if 100 continue end if end do end if end do end do end do c c perform deallocation of some local arrays c deallocate (list) c c print out lists of the small rings in the structure c if (debug) then if (nring3 .gt. 0) then write (iout,110) 110 format (/,' Three-Membered Rings in the Structure :', & //,3x,'Ring',14x,'Atoms in Ring',/) do i = 1, nring3 write (iout,120) i,(iring3(j,i),j=1,3) 120 format (i6,7x,3i7) end do end if if (nring4 .gt. 0) then write (iout,130) 130 format (/,' Four-Membered Rings in the Structure :', & //,3x,'Ring',17x,'Atoms in Ring',/) do i = 1, nring4 write (iout,140) i,(iring4(j,i),j=1,4) 140 format (i6,7x,4i7) end do end if if (nring5 .gt. 0) then write (iout,150) 150 format (/,' Five-Membered Rings in the Structure :', & //,3x,'Ring',20x,'Atoms in Ring',/) do i = 1, nring5 write (iout,160) i,(iring5(j,i),j=1,5) 160 format (i6,7x,5i7) end do end if if (nring6 .gt. 0) then write (iout,170) 170 format (/,' Six-Membered Rings in the Structure :', & //,3x,'Ring',23x,'Atoms in Ring',/) do i = 1, nring6 write (iout,180) i,(iring6(j,i),j=1,6) 180 format (i6,7x,6i7) end do end if if (nring7 .gt. 0) then write (iout,190) 190 format (/,' Seven-Membered Rings in the Structure :', & //,3x,'Ring',26x,'Atoms in Ring',/) do i = 1, nring7 write (iout,200) i,(iring7(j,i),j=1,7) 200 format (i6,7x,7i7) end do end if end if return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################### c ## ## c ## function rmsfit -- rms deviation for paired atoms ## c ## ## c ########################################################### c c c "rmsfit" computes the rms fit of two coordinate sets c c function rmsfit (x1,y1,z1,x2,y2,z2) use align implicit none integer i,i1,i2 real*8 rmsfit,rmsterm real*8 xr,yr,zr,dist2 real*8 weigh,norm real*8 x1(*),x2(*) real*8 y1(*),y2(*) real*8 z1(*),z2(*) c c c compute the rms fit over superimposed atom pairs c rmsfit = 0.0d0 norm = 0.0d0 do i = 1, nfit i1 = ifit(1,i) i2 = ifit(2,i) weigh = wfit(i) xr = x1(i1) - x2(i2) yr = y1(i1) - y2(i2) zr = z1(i1) - z2(i2) dist2 = xr**2 + yr**2 + zr**2 norm = norm + weigh rmsterm = dist2 * weigh rmsfit = rmsfit + rmsterm end do rmsfit = sqrt(rmsfit/norm) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module rotbnd -- molecule partitions for bond rotation ## c ## ## c ################################################################ c c c nrot total number of atoms moving when bond rotates c rot atom numbers of atoms moving when bond rotates c use_short logical flag governing use of shortest atom list c c module rotbnd implicit none integer nrot integer, allocatable :: rot(:) logical use_short save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine rotlist -- find atoms on one side of a bond ## c ## ## c ################################################################ c c c "rotlist" generates the minimum list of all the atoms lying c to one side of a pair of directly bonded atoms; optionally c finds the minimal list by choosing the side with fewer atoms c c subroutine rotlist (base,partner) use atoms use couple use iounit use molcul use rotbnd use zclose implicit none integer i,k,ia,ib,swap integer base,partner integer mark,test integer nattach integer, allocatable :: list(:) logical bonded c c c initialize the number of atoms to one side of the bond c nrot = 0 c c remove any bonds needed for intramolecular ring closures c do i = 1, nadd ia = iadd(1,i) ib = iadd(2,i) if (molcule(ia) .eq. molcule(ib)) then do k = 1, n12(ia) if (i12(k,ia) .eq. ib) i12(k,ia) = 0 end do do k = 1, n12(ib) if (i12(k,ib) .eq. ia) i12(k,ib) = 0 end do end if end do c c add any links needed to make intermolecular connections c do i = 1, ndel ia = idel(1,i) ib = idel(2,i) if (molcule(ia) .ne. molcule(ib)) then if (n12(ia).eq.maxval .or. n12(ib).eq.maxval) then write (iout,10) 10 format (/,' ROTLIST -- Maximum Valence Exceeded;', & ' Increase MAXVAL') call fatal end if n12(ia) = n12(ia) + 1 i12(n12(ia),ia) = ib n12(ib) = n12(ib) + 1 i12(n12(ib),ib) = ia end if end do c c check to see if the two atoms are still directly bonded c bonded = .false. do i = 1, n12(base) if (i12(i,base) .eq. partner) bonded = .true. end do c c perform dynamic allocation of some global arrays c if (.not. allocated(rot)) allocate (rot(n)) c c perform dynamic allocation of some local arrays c allocate (list(0:n)) c c make a list of atoms to one side of this pair of atoms, c taking note of any rings in which the atom pair resides c if (bonded) then list(0) = 1 do i = 1, n rot(i) = 0 end do 20 continue nrot = 0 do i = 1, n list(i) = 0 end do list(base) = 1 list(partner) = 1 nattach = n12(base) do i = 1, nattach test = i12(i,base) if (list(test) .eq. 0) then nrot = nrot + 1 if (use_short .and. nrot.ge.n/2) goto 30 rot(nrot) = test list(test) = 1 end if end do do i = 1, n mark = rot(i) if (mark .eq. 0) goto 40 nattach = n12(mark) if (nattach .gt. 1) then do k = 1, nattach test = i12(k,mark) if (list(test) .eq. 0) then nrot = nrot + 1 if (use_short .and. nrot.ge.n/2) goto 30 rot(nrot) = test list(test) = 1 end if end do end if end do c c the list contains over half the total number of atoms, c so reverse the base and partner atoms, then start over c 30 continue swap = base base = partner partner = swap do i = 1, nrot rot(i) = 0 end do goto 20 end if 40 continue c c perform deallocation of some local arrays c deallocate (list) c c remove links added to make intermolecular connections c do i = 1, ndel ia = idel(1,i) ib = idel(2,i) if (molcule(ia) .ne. molcule(ib)) then n12(ia) = n12(ia) - 1 n12(ib) = n12(ib) - 1 end if end do c c add any bonds required for intramolecular ring closures c do i = 1, nadd ia = iadd(1,i) ib = iadd(2,i) if (molcule(ia) .eq. molcule(ib)) then do k = 1, n12(ia) if (i12(k,ia) .eq. 0) then i12(k,ia) = ib goto 50 end if end do 50 continue do k = 1, n12(ib) if (i12(k,ib) .eq. 0) then i12(k,ib) = ia goto 60 end if end do 60 continue end if end do return end c c c ############################################################ c ## COPYRIGHT (C) 1995 by Yong Kong & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################ c c ################################################################# c ## ## c ## subroutine rotpole -- rotate multipoles to global frame ## c ## ## c ################################################################# c c c "rotpole" constructs the global atomic multipoles by applying c a rotation matrix to convert from local to global frame c c subroutine rotpole (poltype) use atoms use mpole use repel implicit none integer i real*8 a(3,3) logical planar character*5 poltype c c c rotate local multipoles to global frame at each site c call upcase (poltype) if (poltype .eq. 'MPOLE') then do i = 1, n if (pollist(i) .ne. 0) then call rotmat (i,a,planar) call rotsite (i,a,planar,pole,rpole) end if end do else if (poltype .eq. 'REPEL') then do i = 1, n if (replist(i) .ne. 0) then call rotmat (i,a,planar) call rotsite (i,a,planar,repole,rrepole) end if end do end if return end c c c ################################################################# c ## ## c ## subroutine rotrpole -- rotate multipoles to local frame ## c ## ## c ################################################################# c c c "rotrpole" constructs the local atomic multipoles by applying c a rotation matrix to convert from global to local frame c c subroutine rotrpole (poltype) use atoms use mpole use repel implicit none integer i real*8 a(3,3) logical planar character*5 poltype c c c rotate global multipoles to local frame at each site c call upcase (poltype) if (poltype .eq. 'MPOLE') then do i = 1, n if (pollist(i) .ne. 0) then call rotmat (i,a,planar) call invert (3,a) planar = .false. call rotsite (i,a,planar,rpole,pole) end if end do else if (poltype .eq. 'REPEL') then do i = 1, n if (replist(i) .ne. 0) then call rotmat (i,a,planar) call invert (3,a) planar = .false. call rotsite (i,a,planar,rrepole,repole) end if end do end if return end c c c ############################################################## c ## ## c ## subroutine rotmat -- local-to-global rotation matrix ## c ## ## c ############################################################## c c c "rotmat" finds the rotation matrix that rotates the local c coordinate system into the global frame at a specified atom c c subroutine rotmat (i,a,planar) use atoms use math use mpole implicit none integer i,ix,iy,iz real*8 r,dot real*8 eps,angle real*8 xi,yi,zi real*8 dx,dy,dz real*8 dx1,dy1,dz1 real*8 dx2,dy2,dz2 real*8 dx3,dy3,dz3 real*8 dx4,dy4,dz4 real*8 a(3,3) logical planar character*8 axetyp c c c get coordinates and frame definition for multipole site c xi = x(i) yi = y(i) zi = z(i) iz = zaxis(i) ix = xaxis(i) iy = abs(yaxis(i)) axetyp = polaxe(i) planar = .false. c c use the identity matrix as the default rotation matrix c a(1,1) = 1.0d0 a(2,1) = 0.0d0 a(3,1) = 0.0d0 a(1,2) = 0.0d0 a(2,2) = 1.0d0 a(3,2) = 0.0d0 a(1,3) = 0.0d0 a(2,3) = 0.0d0 a(3,3) = 1.0d0 c c get Z-Only rotation matrix elements for z-axis only c if (axetyp .eq. 'Z-Only') then dx = x(iz) - xi dy = y(iz) - yi dz = z(iz) - zi r = sqrt(dx*dx + dy*dy + dz*dz) a(1,3) = dx / r a(2,3) = dy / r a(3,3) = dz / r dx = 1.0d0 dy = 0.0d0 dz = 0.0d0 dot = a(1,3) eps = 0.707d0 if (abs(dot) .gt. eps) then dx = 0.0d0 dy = 1.0d0 dot = a(2,3) end if dx = dx - dot*a(1,3) dy = dy - dot*a(2,3) dz = dz - dot*a(3,3) r = sqrt(dx*dx + dy*dy + dz*dz) a(1,1) = dx / r a(2,1) = dy / r a(3,1) = dz / r c c get Z-then-X rotation matrix elements for z- and x-axes c else if (axetyp .eq. 'Z-then-X') then dx = x(iz) - xi dy = y(iz) - yi dz = z(iz) - zi r = sqrt(dx*dx + dy*dy + dz*dz) a(1,3) = dx / r a(2,3) = dy / r a(3,3) = dz / r dx = x(ix) - xi dy = y(ix) - yi dz = z(ix) - zi dot = dx*a(1,3) + dy*a(2,3) + dz*a(3,3) dx = dx - dot*a(1,3) dy = dy - dot*a(2,3) dz = dz - dot*a(3,3) r = sqrt(dx*dx + dy*dy + dz*dz) a(1,1) = dx / r a(2,1) = dy / r a(3,1) = dz / r c c get Bisector rotation matrix elements for z- and x-axes c else if (axetyp .eq. 'Bisector') then dx = x(iz) - xi dy = y(iz) - yi dz = z(iz) - zi r = sqrt(dx*dx + dy*dy + dz*dz) dx1 = dx / r dy1 = dy / r dz1 = dz / r dx = x(ix) - xi dy = y(ix) - yi dz = z(ix) - zi r = sqrt(dx*dx + dy*dy + dz*dz) dx2 = dx / r dy2 = dy / r dz2 = dz / r dx = dx1 + dx2 dy = dy1 + dy2 dz = dz1 + dz2 r = sqrt(dx*dx + dy*dy + dz*dz) a(1,3) = dx / r a(2,3) = dy / r a(3,3) = dz / r dot = dx2*a(1,3) + dy2*a(2,3) + dz2*a(3,3) dx = dx2 - dot*a(1,3) dy = dy2 - dot*a(2,3) dz = dz2 - dot*a(3,3) r = sqrt(dx*dx + dy*dy + dz*dz) a(1,1) = dx / r a(2,1) = dy / r a(3,1) = dz / r c c get Z-Bisect rotation matrix elements for z- and x-axes; c use alternate x-axis if central atom is close to planar c else if (axetyp .eq. 'Z-Bisect') then dx = x(iz) - xi dy = y(iz) - yi dz = z(iz) - zi r = sqrt(dx*dx + dy*dy + dz*dz) a(1,3) = dx / r a(2,3) = dy / r a(3,3) = dz / r dx = x(ix) - xi dy = y(ix) - yi dz = z(ix) - zi r = sqrt(dx*dx + dy*dy + dz*dz) dx1 = dx / r dy1 = dy / r dz1 = dz / r dx = x(iy) - xi dy = y(iy) - yi dz = z(iy) - zi r = sqrt(dx*dx + dy*dy + dz*dz) dx2 = dx / r dy2 = dy / r dz2 = dz / r dx = dx1 + dx2 dy = dy1 + dy2 dz = dz1 + dz2 r = sqrt(dx*dx + dy*dy + dz*dz) dx = dx / r dy = dy / r dz = dz / r dot = dx*a(1,3) + dy*a(2,3) + dz*a(3,3) angle = 180.0d0 - radian*acos(dot) c eps = 15.0d0 eps = 0.0d0 if (angle .lt. eps) then planar = .true. dx = dy1*dz2 - dz1*dy2 dy = dz1*dx2 - dx1*dz2 dz = dx1*dy2 - dy1*dx2 dot = dx*a(1,3) + dy*a(2,3) + dz*a(3,3) if (dot .lt. 0.0d0) then dx = -dx dy = -dy dz = -dz dot = -dot end if end if dx = dx - dot*a(1,3) dy = dy - dot*a(2,3) dz = dz - dot*a(3,3) r = sqrt(dx*dx + dy*dy + dz*dz) a(1,1) = dx / r a(2,1) = dy / r a(3,1) = dz / r c c get 3-Fold rotation matrix elements for z- and x-axes; c use alternate z-axis if central atom is close to planar c else if (axetyp .eq. '3-Fold') then dx = x(iz) - xi dy = y(iz) - yi dz = z(iz) - zi r = sqrt(dx*dx + dy*dy + dz*dz) dx1 = dx / r dy1 = dy / r dz1 = dz / r dx = x(ix) - xi dy = y(ix) - yi dz = z(ix) - zi r = sqrt(dx*dx + dy*dy + dz*dz) dx2 = dx / r dy2 = dy / r dz2 = dz / r dx = x(iy) - xi dy = y(iy) - yi dz = z(iy) - zi r = sqrt(dx*dx + dy*dy + dz*dz) dx3 = dx / r dy3 = dy / r dz3 = dz / r dx = dx1 + dx2 + dx3 dy = dy1 + dy2 + dy3 dz = dz1 + dz2 + dz3 r = sqrt(dx*dx + dy*dy + dz*dz) c eps = 0.15d0 eps = 0.0d0 if (r .lt. eps) then planar = .true. dx2 = x(ix) - x(iz) dy2 = y(ix) - y(iz) dz2 = z(ix) - z(iz) dx3 = x(iy) - x(iz) dy3 = y(iy) - y(iz) dz3 = z(iy) - z(iz) dx4 = dy2*dz3 - dz2*dy3 dy4 = dz2*dx3 - dx2*dz3 dz4 = dx2*dy3 - dy2*dx3 dot = dx4*dx + dy4*dy + dz4*dz if (dot .gt. 0.0d0) then dx = dx4 dy = dy4 dz = dz4 else dx = -dx4 dy = -dy4 dz = -dz4 end if r = sqrt(dx*dx + dy*dy + dz*dz) end if a(1,3) = dx / r a(2,3) = dy / r a(3,3) = dz / r dot = dx1*a(1,3) + dy1*a(2,3) + dz1*a(3,3) dx = dx1 - dot*a(1,3) dy = dy1 - dot*a(2,3) dz = dz1 - dot*a(3,3) r = sqrt(dx*dx + dy*dy + dz*dz) a(1,1) = dx / r a(2,1) = dy / r a(3,1) = dz / r end if c c finally, find rotation matrix elements for the y-axis c a(1,2) = a(3,1)*a(2,3) - a(2,1)*a(3,3) a(2,2) = a(1,1)*a(3,3) - a(3,1)*a(1,3) a(3,2) = a(2,1)*a(1,3) - a(1,1)*a(2,3) return end c c c ################################################################ c ## ## c ## subroutine rotsite -- rotate input multipoles to final ## c ## ## c ################################################################ c c c "rotsite" rotates atomic multipoles from the input to final c frame at a specified atom by applying a rotation matrix c c subroutine rotsite (ii,a,planar,inpole,outpole) use mpole implicit none integer i,j,k,m,ii real*8 spole(maxpole) real*8 a(3,3) real*8 mp(3,3) real*8 rp(3,3) real*8 inpole(maxpole,*) real*8 outpole(maxpole,*) logical planar character*8 axetyp c c c copy input multipoles and modify at planar sites c do i = 1, maxpole spole(i) = inpole(i,ii) end do if (planar) then axetyp = polaxe(ii) if (axetyp .eq. 'Z-Bisect') then spole(2) = 0.0d0 spole(7) = 0.0d0 spole(11) = 0.0d0 spole(5) = 0.5d0 * (spole(5)+spole(9)) spole(9) = spole(5) else if (axetyp .eq. '3-Fold') then do i = 2, maxpole spole(i) = 0.0d0 end do end if end if c c monopoles are the same in any coordinate frame c outpole(1,ii) = spole(1) c c rotate input dipoles to final coordinate frame c do i = 2, 4 outpole(i,ii) = 0.0d0 do j = 2, 4 outpole(i,ii) = outpole(i,ii) + spole(j)*a(i-1,j-1) end do end do c c rotate input quadrupoles to final coordinate frame c k = 5 do i = 1, 3 do j = 1, 3 mp(i,j) = spole(k) rp(i,j) = 0.0d0 k = k + 1 end do end do do i = 1, 3 do j = 1, 3 if (j .lt. i) then rp(i,j) = rp(j,i) else do k = 1, 3 do m = 1, 3 rp(i,j) = rp(i,j) + a(i,k)*a(j,m)*mp(k,m) end do end do end if end do end do k = 5 do i = 1, 3 do j = 1, 3 outpole(k,ii) = rp(i,j) k = k + 1 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 rxnfld -- reaction field matrix and indices ## c ## ## c ############################################################ c c c ijk indices into the reaction field element arrays c b1 first reaction field matrix element array c b2 second reaction field matrix element array c c module rxnfld implicit none integer ijk(0:5,0:5,0:5) real*8 b1(40,13) real*8 b2(40,13) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module rxnpot -- reaction field functional form details ## c ## ## c ################################################################# c c c rfsize radius of reaction field sphere centered at origin c rfbulkd bulk dielectric constant of reaction field continuum c rfterms number of terms to use in reaction field summation c c module rxnpot implicit none integer rfterms real*8 rfsize real*8 rfbulkd save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## program saddle -- find conformational transition state ## c ## ## c ################################################################ c c c "saddle" finds a transition state between two conformational c minima using a combination of ideas from the synchronous transit c (Halgren-Lipscomb) and quadratic path (Bell-Crighton) methods c c program saddle use atoms use iounit use keys use linmin use syntrn use titles use zcoord implicit none integer i,its,next integer nvar,freeunit integer ncalls,niter integer ninner,nouter integer ncycle,maxcycle integer maxinner,maxouter real*8 f,g_rms,g_tan,g2 real*8 saddle1,grdmin real*8 reduce,diverge real*8 beta,sg,sg0 real*8 gamma,gammamin real*8 x_move,f_move real*8 hg,f_old,g2_old real*8 f_0,f_1,f_2,f_3 real*8 p,delta,epsilon real*8 angle,rmsvalue real*8 energy1,energy2 real*8, allocatable :: x1(:) real*8, allocatable :: y1(:) real*8, allocatable :: z1(:) real*8, allocatable :: zbond1(:) real*8, allocatable :: zang1(:) real*8, allocatable :: ztors1(:) real*8, allocatable :: x2(:) real*8, allocatable :: y2(:) real*8, allocatable :: z2(:) real*8, allocatable :: zbond2(:) real*8, allocatable :: zang2(:) real*8, allocatable :: ztors2(:) real*8, allocatable :: xx(:) real*8, allocatable :: g(:) real*8, allocatable :: x_old(:) real*8, allocatable :: g_old(:) real*8, allocatable :: tan(:) real*8, allocatable :: dgdt(:) real*8, allocatable :: s0(:) real*8, allocatable :: s(:) real*8, allocatable :: h0(:) logical exist,terminate logical scan,spanned logical done,newcycle character*1 answer character*9 status character*20 keyword character*240 tsfile character*240 record character*240 string external saddle1 c c c set default parameters for the saddle point method c call initial terminate = .false. ncalls = 0 nouter = 0 maxouter = 100 maxinner = 50 maxcycle = 4 epsilon = 0.5d0 gammamin = 0.00001d0 diverge = 0.005d0 reduce = 0.0d0 c c set default parameters for the line search c stpmin = 1.0d-16 stpmax = 2.0d0 cappa = 0.1d0 slpmax = 10000.0d0 angmax = 180.0d0 intmax = 5 c c get coordinates for the first endpoint structure c call getxyz c c perform dynamic allocation of some local arrays c allocate (x1(n)) allocate (y1(n)) allocate (z1(n)) allocate (zbond1(n)) allocate (zang1(n)) allocate (ztors1(n)) c c store coordinates for the first endpoint structure c do i = 1, n x1(i) = x(i) y1(i) = y(i) z1(i) = z(i) end do c c get coordinates for the second endpoint structure c call getxyz c c perform dynamic allocation of some local arrays c allocate (x2(n)) allocate (y2(n)) allocate (z2(n)) allocate (zbond2(n)) allocate (zang2(n)) allocate (ztors2(n)) c c store coordinates for the second endpoint structure c do i = 1, n x2(i) = x(i) y2(i) = y(i) z2(i) = z(i) end do c c setup for the subsequent energy computations c call mechanic c c get any altered values from the keyword file c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:8) .eq. 'DIVERGE ') then read (string,*,err=10,end=10) diverge else if (keyword(1:7) .eq. 'REDUCE ') then read (string,*,err=10,end=10) reduce else if (keyword(1:9) .eq. 'GAMMAMIN ') then read (string,*,err=10,end=10) gammamin 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 RMS Gradient per Atom Criterion [0.1] : ',$) read (input,40) grdmin 40 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.1d0 c c find out whether syncronous transit scans are desired c scan = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,50) 50 format (/,' Perform Synchronous Transit Pathway Scans', & ' [N] : ',$) read (input,60) record 60 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') scan = .true. c c superimpose the two conformational endpoints c call impose (n,x1,y1,z1,n,x2,y2,z2,rmsvalue) write (iout,70) rmsvalue 70 format (/,' RMS Fit for All Atoms of Both Structures :',f10.4) c c perform dynamic allocation of some global arrays c nvar = 3 * n if (.not. allocated(xmin1)) allocate (xmin1(nvar)) if (.not. allocated(xmin2)) allocate (xmin2(nvar)) if (.not. allocated(xm)) allocate (xm(nvar)) c c copy the superimposed structures into vectors c do i = 1, n xmin1(3*i-2) = x1(i) xmin1(3*i-1) = y1(i) xmin1(3*i) = z1(i) xmin2(3*i-2) = x2(i) xmin2(3*i-1) = y2(i) xmin2(3*i) = z2(i) end do c c get and store internal coordinates for first endpoint c do i = 1, n x(i) = x1(i) y(i) = y1(i) z(i) = z1(i) end do call makeint (0) do i = 1, n zbond1(i) = zbond(i) zang1(i) = zang(i) ztors1(i) = ztors(i) end do c c get and store internal coordinates for second endpoint c do i = 1, n x(i) = x2(i) y(i) = y2(i) z(i) = z2(i) end do call makeint (2) do i = 1, n zbond2(i) = zbond(i) zang2(i) = zang(i) ztors2(i) = ztors(i) if (ztors1(i)-ztors2(i) .gt. 180.0d0) then ztors2(i) = ztors2(i) + 360.0d0 else if (ztors1(i)-ztors2(i) .lt. -180.0d0) then ztors1(i) = ztors1(i) + 360.0d0 end if end do c c perform dynamic allocation of some local arrays c allocate (xx(nvar)) allocate (g(nvar)) allocate (x_old(nvar)) allocate (g_old(nvar)) allocate (tan(nvar)) allocate (dgdt(nvar)) allocate (s0(nvar)) allocate (s(nvar)) allocate (h0(nvar)) c c get the energies for the two endpoint structures c ncalls = ncalls + 2 energy1 = saddle1 (xmin1,g) energy2 = saddle1 (xmin2,g) write (iout,80) energy1,energy2 80 format (/,' Energy Value for Endpoint Structure 1 :',f13.4, & /,' Energy Value for Endpoint Structure 2 :',f13.4) c c make a guess at the transition state structure; c or use the current guess if one is around c inquire (file='tstate.xyz',exist=exist) if (exist) then write (iout,90) 90 format (/,' Using TSTATE.XYZ as the Transition State Estimate') its = freeunit () tsfile = 'tstate.xyz' call version (tsfile,'old') open (unit=its,file=tsfile,status='old') rewind (unit=its) call readxyz (its) close (unit=its) do i = 1, n xx(3*i-2) = x(i) xx(3*i-1) = y(i) xx(3*i) = z(i) end do else tpath = 0.5d0 do i = 1, n zbond(i) = (1.0d0-tpath)*zbond1(i) + tpath*zbond2(i) zang(i) = (1.0d0-tpath)*zang1(i) + tpath*zang2(i) ztors(i) = (1.0d0-tpath)*ztors1(i) + tpath*ztors2(i) end do call makexyz do i = 1, n xx(3*i-2) = x(i) xx(3*i-1) = y(i) xx(3*i) = z(i) end do end if c c perform deallocation of some local arrays c deallocate (x1) deallocate (y1) deallocate (z1) deallocate (zbond1) deallocate (zang1) deallocate (ztors1) deallocate (x2) deallocate (y2) deallocate (z2) deallocate (zbond2) deallocate (zang2) deallocate (ztors2) c c save the initial estimate of the transition state c do i = 1, n x(i) = xx(3*i-2) y(i) = xx(3*i-1) z(i) = xx(3*i) end do if (.not. exist) then title = 'Transition State Structure' ltitle = 26 end if its = freeunit () tsfile = 'tstate.xyz' call version (tsfile,'new') open (unit=its,file=tsfile,status='new') call prtxyz (its) close (unit=its) c c start of the major loop for transition state location; c first, find the value of the transit path coordinate c 100 continue nouter = nouter + 1 call pathval (nvar,xx) c c make a scan along the synchronous transit pathway c if (scan) then call pathscan (nvar,xmin1,xmin2,ncalls) end if c c set parameters for use in quadratic line maximization c done = .false. niter = 1 ncycle = 1 delta = 0.01d0 c c compute initial point for quadratic line maximization c tpath = ppath call pathpnt (nvar,tpath,xx,xmin1,xmin2) ncalls = ncalls + 3 f = saddle1 (xx,g) call tangent (nvar,xx,g,g_rms,tan,g_tan,gamma,dgdt) write (iout,110) 110 format (/,' Search for a Maximum along Synchronous Transit :', & /' ST Iter F Value Path RMS G', & ' G Tan Gamma FG Call',/) write (iout,120) niter,f,tpath,g_rms,g_tan,gamma,ncalls 120 format (i6,f13.4,f11.4,f11.4,f11.4,f11.5,i8) c c make an iterative search for quadratic line maximum c do while (.not. done) f_0 = f tpath = tpath + delta call pathpnt (nvar,tpath,xx,xmin1,xmin2) ncalls = ncalls + 1 f_1 = saddle1 (xx,g) tpath = tpath - 2.0d0*delta call pathpnt (nvar,tpath,xx,xmin1,xmin2) tpath = tpath + delta ncalls = ncalls + 1 f_2 = saddle1 (xx,g) if (f_1.gt.f_0 .and. f_2.gt.f_0) then goto 150 else if (f_1 .gt. f_0) then tpath = tpath + delta p = 1.0d0 else if (f_2 .gt. f_0) then tpath = tpath - delta p = -1.0d0 f_1 = f_2 else tpath = tpath + 0.5d0*delta*(f_2-f_1)/(f_1-2.0d0*f_0+f_2) goto 130 end if spanned = .false. do while (.not. spanned) p = 2.0d0 * p tpath = tpath + p*delta if (tpath .le. 0.0d0) then tpath = 0.0d0 f_2 = energy1 else if (tpath .ge. 1.0d0) then tpath = 1.0d0 f_2 = energy2 else call pathpnt (nvar,tpath,xx,xmin1,xmin2) ncalls = ncalls + 1 f_2 = saddle1 (xx,g) end if if (f_2 .gt. f_1) then f_0 = f_1 f_1 = f_2 else spanned = .true. end if end do p = 0.5d0 * p tpath = tpath - p*delta if (tpath .le. 0.0d0) then tpath = 0.0d0 f_3 = energy1 else if (tpath .ge. 1.0d0) then tpath = 1.0d0 f_3 = energy2 else call pathpnt (nvar,tpath,xx,xmin1,xmin2) ncalls = ncalls + 1 f_3 = saddle1 (xx,g) end if if (f_3 .gt. f_1) then tpath = tpath + 0.5d0*abs(p)*delta*(f_1-f_2) & / (f_2-2.0d0*f_3+f_1) else tpath = tpath - p*delta tpath = tpath + 0.5d0*abs(p)*delta*(f_0-f_3) & / (f_3-2.0d0*f_1+f_0) end if 130 continue niter = niter + 1 call pathpnt (nvar,tpath,xx,xmin1,xmin2) ncalls = ncalls + 3 f = saddle1 (xx,g) call tangent (nvar,xx,g,g_rms,tan,g_tan,gamma,dgdt) write (iout,140) niter,f,tpath,g_rms,g_tan,gamma,ncalls 140 format (i6,f13.4,f11.4,f11.4,f11.4,f11.5,i8) if (ncycle.ge.maxcycle .or. gamma.lt.gammamin) then done = .true. end if 150 continue ncycle = ncycle + 1 delta = delta * epsilon end do c c if the path maximum is too near to an endpoint, c then negative curvature has probably been lost c if (tpath.le.0.05d0 .or. tpath.ge.0.95d0) then if (.not. scan) call pathscan (nvar,xmin1,xmin2,ncalls) write (iout,160) 160 format (/,' SADDLE -- Termination due to Loss', & ' of Negative Curvature') call fatal end if c c save the current maximum as the transition state estimate c do i = 1, n x(i) = xx(3*i-2) y(i) = xx(3*i-1) z(i) = xx(3*i) end do its = freeunit () tsfile = 'tstate.xyz' call version (tsfile,'old') open (unit=its,file=tsfile,status='old') rewind (unit=its) call prtxyz (its) close (unit=its) c c the maximum is located, get ready for minimization c sg = 0.0d0 do i = 1, nvar s0(i) = tan(i) sg = sg + s0(i)*dgdt(i) end do do i = 1, nvar h0(i) = dgdt(i) / sg end do c c set the initial conjugate direction for minimization c ninner = 0 g2 = 0.0d0 hg = 0.0d0 f_move = 1000000.0d0 do i = 1, nvar g2 = g2 + g(i)**2 hg = hg + h0(i)*g(i) end do do i = 1, nvar s(i) = -g(i) + hg*s0(i) end do g_rms = sqrt(g2/dble(n)) write (iout,170) 170 format (/,' Search for a Minimum in Conjugate Directions :', & /,' CG Iter F Value RMS G F Move', & ' X Move Angle FG Call Comment',/) write (iout,180) ninner,f,g_rms,ncalls 180 format (i6,f13.4,f11.4,30x,i7) c c check the termination criterion c if (g_rms .lt. grdmin) then terminate = .true. write (iout,190) 190 format (/,' SADDLE -- Normal Termination at', & ' Transition State') end if c c line search to find minimum in conjugate direction c do while (.not. terminate) ninner = ninner + 1 f_old = f g2_old = g2 do i = 1, nvar x_old(i) = xx(i) g_old(i) = g(i) end do status = ' ' angmax = 90.0d0 call search (nvar,f,g,xx,s,f_move,angle, & ncalls,saddle1,status) c c if search direction points uphill, use its negative c if (status .eq. 'WideAngle') then do i = 1, nvar s(i) = -s(i) end do call search (nvar,f,g,xx,s,f_move,angle, & ncalls,saddle1,status) end if c c compute movement and gradient following line search c f_move = f_old - f x_move = 0.0d0 g2 = 0.0d0 do i = 1, nvar x_move = x_move + (xx(i)-x_old(i))**2 g2 = g2 + g(i)**2 end do x_move = sqrt(x_move/dble(n)) g_rms = sqrt(g2/dble(n)) write (iout,200) ninner,f,g_rms,f_move, & x_move,angle,ncalls,status 200 format (i6,f13.4,f11.4,f11.4,f10.4,f9.2,i7,3x,a9) c c check the termination criteria c if (g_rms .lt. grdmin) then terminate = .true. write (iout,210) 210 format (/,' SADDLE -- Normal Termination at', & ' Transition State') else if (nouter .ge. maxouter) then terminate = .true. write (iout,220) 220 format (/,' SADDLE -- Termination due to Maximum', & ' Iteration Limit') end if c c check to see if another maximization is needed c if (.not. terminate) then sg0 = 0.0d0 do i = 1, nvar sg0 = sg0 + s0(i)*g(i) end do newcycle = .false. if (ninner .ge. maxinner) newcycle = .true. if (sg0*sg0/g2 .gt. diverge) newcycle = .true. if (status .ne. ' Success ') newcycle = .true. c c unfortunately, a new maximization is needed; first save c the current minimum as the transition state estimate c if (newcycle) then do i = 1, n x(i) = xx(3*i-2) y(i) = xx(3*i-1) z(i) = xx(3*i) end do its = freeunit () tsfile = 'tstate.xyz' call version (tsfile,'old') open (unit=its,file=tsfile,status='old') rewind (unit=its) call prtxyz (its) close (unit=its) c c move the path endpoints toward current transition state; c then jump to the start of the next maximization cycle c if (reduce .ne. 0.0d0) then call pathval (nvar,xx) tpath = reduce * ppath call pathpnt (nvar,tpath,x_old,xmin1,xmin2) do i = 1, nvar xmin1(i) = x_old(i) end do ncalls = ncalls + 1 energy1 = saddle1 (xmin1,g) tpath = 1.0d0 - reduce*(1.0d0-ppath) call pathpnt (nvar,tpath,x_old,xmin1,xmin2) do i = 1, nvar xmin2(i) = x_old(i) end do ncalls = ncalls + 1 energy2 = saddle1 (xmin2,g) end if goto 100 end if c c find the next conjugate search direction to search; c choice of "beta" is Fletcher-Reeves or Polak-Ribiere c hg = 0.0d0 do i = 1, nvar hg = hg + h0(i)*g(i) end do beta = 0.0d0 do i = 1, nvar c beta = beta + g(i) * g(i) beta = beta + g(i) * (g(i)-g_old(i)) end do beta = beta / g2_old do i = 1, nvar s(i) = -g(i) + hg*s0(i) + beta*s(i) end do end if end do c c write out the final transition state structure c do i = 1, n x(i) = xx(3*i-2) y(i) = xx(3*i-1) z(i) = xx(3*i) end do its = freeunit () tsfile = 'tstate.xyz' call version (tsfile,'old') open (unit=its,file=tsfile,status='old') rewind (unit=its) call prtxyz (its) close (unit=its) c c perform deallocation of some local arrays c deallocate (xx) deallocate (g) deallocate (x_old) deallocate (g_old) deallocate (tan) deallocate (dgdt) deallocate (s0) deallocate (s) deallocate (h0) c c perform any final tasks before program exit c call final end c c c ############################################################### c ## ## c ## subroutine pathval -- synchronous transit path values ## c ## ## c ############################################################### c c c "pathval" computes the synchronous transit path value for c the specified structure c c subroutine pathval (nvar,xx) use atoms use syntrn implicit none integer i,nvar real*8 dr,dp,rmsvalue real*8 xx(*) real*8, allocatable :: x1(:) real*8, allocatable :: y1(:) real*8, allocatable :: z1(:) real*8, allocatable :: x2(:) real*8, allocatable :: y2(:) real*8, allocatable :: z2(:) c c c perform dynamic allocation of some local arrays c allocate (x1(n)) allocate (y1(n)) allocate (z1(n)) allocate (x2(n)) allocate (y2(n)) allocate (z2(n)) c c find the value of the transit path coordinate "ppath"; c it is the ratio of the rms fits to the two endpoints c do i = 1, n x1(i) = xmin1(3*i-2) y1(i) = xmin1(3*i-1) z1(i) = xmin1(3*i) x2(i) = xx(3*i-2) y2(i) = xx(3*i-1) z2(i) = xx(3*i) end do call impose (n,x1,y1,z1,n,x2,y2,z2,dr) do i = 1, n x1(i) = xmin2(3*i-2) y1(i) = xmin2(3*i-1) z1(i) = xmin2(3*i) x2(i) = xx(3*i-2) y2(i) = xx(3*i-1) z2(i) = xx(3*i) end do call impose (n,x1,y1,z1,n,x2,y2,z2,dp) ppath = dr / (dr+dp) c c superimpose on linear transit structure of same path value c do i = 1, n x1(i) = (1.0d0-ppath)*xmin1(3*i-2) + ppath*xmin2(3*i-2) y1(i) = (1.0d0-ppath)*xmin1(3*i-1) + ppath*xmin2(3*i-1) z1(i) = (1.0d0-ppath)*xmin1(3*i) + ppath*xmin2(3*i) x2(i) = xx(3*i-2) y2(i) = xx(3*i-1) z2(i) = xx(3*i) end do call impose (n,x1,y1,z1,n,x2,y2,z2,rmsvalue) do i = 1, n xx(3*i-2) = x2(i) xx(3*i-1) = y2(i) xx(3*i) = z2(i) end do do i = 1, nvar xm(i) = xx(i) end do c c perform deallocation of some local arrays c deallocate (x1) deallocate (y1) deallocate (z1) deallocate (x2) deallocate (y2) deallocate (z2) return end c c c ############################################################### c ## ## c ## subroutine pathscan -- scan along the transit pathway ## c ## ## c ############################################################### c c c "pathscan" makes a scan of a synchronous transit pathway by c computing structures and energies for specific path values c c subroutine pathscan (nvar,x0,x1,ncalls) use iounit use syntrn implicit none integer i,nvar,ncalls real*8 energy,gamma real*8 g_rms,g_tan real*8 saddle1 real*8 x0(*) real*8 x1(*) real*8, allocatable :: xx(:) real*8, allocatable :: g(:) real*8, allocatable :: tan(:) real*8, allocatable :: dgdt(:) c c c perform dynamic allocation of some local arrays c allocate (xx(nvar)) allocate (g(nvar)) allocate (tan(nvar)) allocate (dgdt(nvar)) c c make a scan along the synchronous transit pathway c write (iout,10) 10 format (/,' Scan of the Synchronous Transit Pathway :', & /,' N Scan F Value Path RMS G', & ' G Tan Gamma FG Call',/) do i = 0, 10 tpath = 0.1d0 * dble(i) call pathpnt (nvar,tpath,xx,x0,x1) ncalls = ncalls + 3 energy = saddle1 (xx,g) call tangent (nvar,xx,g,g_rms,tan,g_tan,gamma,dgdt) write (iout,20) i,energy,tpath,g_rms,g_tan,gamma,ncalls 20 format (i6,f13.4,f11.4,f11.4,f11.4,f11.5,i8) end do c c perform deallocation of some local arrays c deallocate (xx) deallocate (g) deallocate (tan) deallocate (dgdt) return end c c c ############################################################# c ## ## c ## subroutine pathpnt -- get coordinates of path point ## c ## ## c ############################################################# c c c "pathpnt" finds a structure on the synchronous transit path c with the specified path value "tpath" c c subroutine pathpnt (nvar,tpath,xx,x0,x1) use inform use minima implicit none integer i,nvar real*8 tpath real*8 value real*8 grdmin real*8 transit real*8 xx(*) real*8 x0(*) real*8 x1(*) external transit external optsave c c c initialize some parameters for the upcoming optimization c if (debug) then iprint = 1 else iprint = 0 end if iwrite = 0 maxiter = 1000 grdmin = 0.00001d0 c c interpolate coordinates to give initial estimate c do i = 1, nvar xx(i) = (1.0d0-tpath)*x0(i) + tpath*x1(i) end do c c optimize the synchronous transit function c c call lbfgs (nvar,xx,value,grdmin,transit,optsave) call ocvm (nvar,xx,value,grdmin,transit,optsave) return end c c c ########################################################### c ## ## c ## subroutine tangent -- synchronous transit tangent ## c ## ## c ########################################################### c c c "tangent" finds the projected gradient on the synchronous c transit path for a point along the transit pathway c c subroutine tangent (nvar,xx,g,g_rms,tan,g_tan,gamma,dgdt) use atoms use syntrn implicit none integer i,nvar real*8 g_rms,g_tan real*8 gamma,delta real*8 t0,g2,tan_norm real*8 energy,saddle1 real*8 xx(*) real*8 g(*) real*8 tan(*) real*8 dgdt(*) real*8, allocatable :: xf(:) real*8, allocatable :: xb(:) real*8, allocatable :: gf(:) real*8, allocatable :: gb(:) c c c set the finite difference path increment c delta = 0.01d0 c c store the initial pathpnt and compute gradient norm c t0 = tpath g2 = 0.0d0 do i = 1, nvar g2 = g2 + g(i)**2 end do g_rms = sqrt(g2/dble(n)) c c perform dynamic allocation of some local arrays c allocate (xf(nvar)) allocate (xb(nvar)) allocate (gf(nvar)) allocate (gb(nvar)) c c compute the forward difference c do i = 1, nvar xf(i) = xx(i) end do tpath = t0 + delta call pathpnt (nvar,tpath,xf,xf,xf) energy = saddle1 (xf,gf) c c compute the backward difference c do i = 1, nvar xb(i) = xx(i) end do tpath = t0 - delta call pathpnt (nvar,tpath,xb,xb,xb) energy = saddle1 (xb,gb) tpath = t0 c c compute tangent to the path, and projected gradient c tan_norm = 0.0d0 do i = 1, nvar tan(i) = xf(i) - xb(i) tan_norm = tan_norm + tan(i)**2 dgdt(i) = gf(i) - gb(i) end do tan_norm = sqrt(tan_norm) g_tan = 0.0d0 do i = 1, nvar tan(i) = tan(i) / tan_norm g_tan = g_tan + g(i)*tan(i) end do g_tan = g_tan / sqrt(dble(n)) gamma = (g_tan/g_rms)**2 c c perform deallocation of some local arrays c deallocate (xf) deallocate (xb) deallocate (gf) deallocate (gb) return end c c c ############################################################ c ## ## c ## function transit -- synchronous transit evaluation ## c ## ## c ############################################################ c c c "transit" evaluates the synchronous transit function and c gradient; linear and quadratic transit paths are available c c function transit (xx,g) use atoms use syntrn implicit none integer i,j,nvar integer ix,iy,iz integer jx,jy,jz real*8 transit,value real*8 xci,yci,zci real*8 xcd,ycd,zcd real*8 x1i,y1i,z1i real*8 x1d,y1d,z1d real*8 x2i,y2i,z2i real*8 x2d,y2d,z2d real*8 xmi,ymi,zmi real*8 xmd,ymd,zmd real*8 gamma,term real*8 termx,termy,termz real*8 cutoff,cutoff2 real*8 r1,r2,rc,rm real*8 ri,ri4,rd real*8 wi,wc,wd real*8 tq,pq real*8 xx(*) real*8 g(*) character*9 mode c c c zero out the synchronous transit function and gradient c value = 0.0d0 nvar = 3 * n do i = 1, nvar g(i) = 0.0d0 end do tq = 1.0d0 - tpath c c set the cutoff distance for interatomic distances c cutoff = 1000.0d0 cutoff2 = cutoff**2 c c set the type of synchronous transit path to be used c if (ppath .eq. 0.0d0) then mode = 'LINEAR' else mode = 'QUADRATIC' pq = 1.0d0 - ppath end if c c portion based on interpolated interatomic distances c do i = 1, n-1 iz = 3 * i iy = iz - 1 ix = iz - 2 xci = xx(ix) yci = xx(iy) zci = xx(iz) x1i = xmin1(ix) y1i = xmin1(iy) z1i = xmin1(iz) x2i = xmin2(ix) y2i = xmin2(iy) z2i = xmin2(iz) if (mode .eq. 'QUADRATIC') then xmi = xm(ix) ymi = xm(iy) zmi = xm(iz) end if do j = i+1, n jz = 3 * j jy = jz - 1 jx = jz - 2 xcd = xci - xx(jx) ycd = yci - xx(jy) zcd = zci - xx(jz) x1d = x1i - xmin1(jx) y1d = y1i - xmin1(jy) z1d = z1i - xmin1(jz) x2d = x2i - xmin2(jx) y2d = y2i - xmin2(jy) z2d = z2i - xmin2(jz) rc = xcd**2 + ycd**2 + zcd**2 r1 = x1d**2 + y1d**2 + z1d**2 r2 = x2d**2 + y2d**2 + z2d**2 if (min(rc,r1,r2) .lt. cutoff2) then rc = sqrt(rc) r1 = sqrt(r1) r2 = sqrt(r2) ri = tq*r1 + tpath*r2 if (mode .eq. 'QUADRATIC') then xmd = xmi - xm(jx) ymd = ymi - xm(jy) zmd = zmi - xm(jz) rm = sqrt(xmd**2+ymd**2+zmd**2) gamma = (rm-pq*r1-ppath*r2) / (ppath*pq) ri = ri + gamma*tpath*tq end if ri4 = ri**4 rd = rc - ri value = value + rd**2/ri4 term = 2.0d0 * rd/(ri4*rc) termx = term * xcd termy = term * ycd termz = term * zcd g(ix) = g(ix) + termx g(iy) = g(iy) + termy g(iz) = g(iz) + termz g(jx) = g(jx) - termx g(jy) = g(jy) - termy g(jz) = g(jz) - termz end if end do end do c c portion used to supress rigid rotations and translations c do i = 1, nvar wc = xx(i) wi = tq*xmin1(i) + tpath*xmin2(i) wd = wc - wi value = value + 0.000001d0*wd**2 g(i) = g(i) + 0.000002d0*wd end do transit = value return end c c c ############################################################ c ## ## c ## function saddle1 -- energy and gradient for saddle ## c ## ## c ############################################################ c c c "saddle1" is a service routine that computes the energy and c gradient for transition state optimization c c function saddle1 (xx,g) use atoms implicit none integer i real*8 e,saddle1 real*8 xx(*) real*8 g(*) c c c copy optimization values to coordinates and find gradient c do i = 1, n x(i) = xx(3*i-2) y(i) = xx(3*i-1) z(i) = xx(3*i) end do call gradient (e,g) saddle1 = e return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module scales -- optimization parameter scale factors ## c ## ## c ############################################################### c c c scale multiplicative factor for each optimization parameter c set_scale logical flag to show if scale factors have been set c c module scales implicit none real*8, allocatable :: scale(:) logical set_scale save end c c c ############################################################## c ## COPYRIGHT (C) 1998 by Rohit Pappu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ################################################################# c ## ## c ## program scan -- maps minima on potential energy surface ## c ## ## c ################################################################# c c c "scan" attempts to find all the local minima on a potential c energy surface via an iterative series of local searches along c normal mode directions c c literature reference: c c I. Kolossvary and W. C. Guida, "Low-Mode Conformational Search c Elucidated: Application to C39H80 and Flexible Docking of c 9-Deazaguanine Inhibitors into PNP, Journal of Computational c Chemistry, 20, 1671-1684 (1999) c c program scan use files use inform use iounit use omega use output implicit none integer maxmap parameter (maxmap=100000) integer i,ixyz integer lext,freeunit integer nmap,niter integer nvec,neigen real*8 minimum,grdmin,range real*8 emap(maxmap) logical exist character*7 ext character*240 xyzfile character*240 string c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c initialize the number of minima and coordinate type c nmap = 0 coordtype = 'CARTESIAN' c c get the rotatable bonds for torsional local search c call makeint (0) call initrot call active c c get the number of eigenvectors to use for the local search c neigen = -1 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) neigen 10 continue nvec = min(nomega,5) if (neigen .le. 0) then write (iout,20) nvec 20 format(/,' Enter the Number of Eigenvectors for Local', & ' Search [',i1,'] : ',$) read (input,30) neigen 30 format (i10) if (neigen .le. 0) neigen = nvec end if neigen = min(neigen,nvec) c c get the energy threshold criterion for map membership c range = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=40,end=40) range 40 continue if (range .le. 0.0d0) then write (iout,50) 50 format (/,' Enter the Energy Threshold for Local Minima', & ' [100.0] : ',$) read (input,60) range 60 format (f20.0) end if if (range .le. 0.0d0) range = 100.0d0 c c get the termination criterion as RMS gradient per atom c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=70,end=70) grdmin 70 continue if (grdmin .le. 0.0d0) then write (iout,80) 80 format (/,' Enter RMS Gradient per Atom Criterion', & ' [0.0001] : ',$) read (input,90) grdmin 90 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.0001d0 c c set the energy output precision via convergence criterion c if (grdmin .le. 0.000001d0) digits = 6 if (grdmin .le. 0.00000001d0) digits = 8 c c create and open an output file if using archive mode c if (archive) then ixyz = freeunit () xyzfile = filename(1:leng) call suffix (xyzfile,'arc','new') open (unit=ixyz,file=xyzfile,status='new') close (unit=ixyz) end if c c find the first map point from the input structure c write (iout,100) 100 format (/,' Generating Seed Point for Potential Energy', & ' Surface Scan',/) call localmin (minimum,grdmin) call mapcheck (nmap,emap,range,minimum,grdmin) c c use normal mode local search to explore adjacent minima c niter = 0 do while (niter .lt. nmap) niter = niter + 1 write (iout,110) niter 110 format (/,' Normal Mode Local Search',7x,'Minimum',i7,/) ixyz = freeunit () if (archive) then xyzfile = filename(1:leng) call suffix (xyzfile,'arc','old') open (unit=ixyz,file=xyzfile,status='old') do i = 1, niter-1 call readxyz (ixyz) end do else lext = 3 call numeral (niter,ext,lext) xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'old') open (unit=ixyz,file=xyzfile,status='old') end if call readxyz (ixyz) close (unit=ixyz) call modesrch (nmap,emap,range,neigen,grdmin) end do c c perform any final tasks before program exit c call final end c c c ############################################################### c ## ## c ## subroutine mapcheck -- addition to local minimum list ## c ## ## c ############################################################### c c c "mapcheck" checks the current minimum energy structure c for possible addition to the master list of local minima c c subroutine mapcheck (nmap,emap,range,minimum,grdmin) use files use inform use iounit use output implicit none integer i,ixyz,lext integer nmap,freeunit real*8 minimum,grdmin real*8 delta,eps,range real*8 emap(*) logical unique,exist character*7 ext character*240 xyzfile c c c check to see if the current minimum was previously found c eps = grdmin unique = .true. do i = 1, nmap delta = minimum - emap(i) if (abs(delta) .lt. eps) unique = .false. if (delta .gt. range) unique = .false. end do c c add minimum to master list if it was not previously known c if (unique) then nmap = nmap + 1 emap(nmap) = minimum if (digits .ge. 8) then write (iout,10) nmap,minimum 10 format (/,4x,'Potential Surface Map',7x,'Minimum', & i7,6x,f20.8,/) else if (digits .ge. 6) then write (iout,20) nmap,minimum 20 format (/,4x,'Potential Surface Map',7x,'Minimum', & i7,6x,f18.6,/) else write (iout,30) nmap,minimum 30 format (/,4x,'Potential Surface Map',7x,'Minimum', & i7,6x,f16.4,/) end if c c write the coordinates of the new minimum to a file c ixyz = freeunit () if (archive) then xyzfile = filename(1:leng) call suffix (xyzfile,'arc','old') inquire (file=xyzfile,exist=exist) if (exist) then call openend (ixyz,xyzfile) else open (unit=ixyz,file=xyzfile,status='new') end if else lext = 3 call numeral (nmap,ext,lext) xyzfile = filename(1:leng)//'.'//ext(1:lext) call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') end if call prtxyz (ixyz) close (unit=ixyz) end if return end c c c ############################################################### c ## ## c ## function scan1 -- energy and gradient values for scan ## c ## ## c ############################################################### c c c "scan1" is a service routine that computes the energy and c gradient during exploration of a potential energy surface c via iterative local search c c function scan1 (xx,g) use atoms implicit none integer i,nvar real*8 scan1,e real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) c c c convert optimization parameters to atomic coordinates 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 c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute and store the energy and gradient c call gradient (e,derivs) scan1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, n nvar = nvar + 1 g(nvar) = derivs(1,i) nvar = nvar + 1 g(nvar) = derivs(2,i) nvar = nvar + 1 g(nvar) = derivs(3,i) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ############################################################ c ## ## c ## subroutine scan2 -- Hessian matrix values for scan ## c ## ## c ############################################################ c c c "scan2" is a service routine that computes the sparse matrix c Hessian elements during exploration of a potential energy c surface via iterative local search c c subroutine scan2 (mode,xx,h,hinit,hstop,hindex,hdiag) use atoms implicit none integer i,nvar integer hinit(*) integer hstop(*) integer hindex(*) real*8 xx(*) real*8 hdiag(*) real*8 h(*) character*4 mode c c c translate optimization parameters to atomic coordinates c if (mode .eq. 'NONE') return 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 c c compute and store the Hessian elements c call hessian (h,hinit,hstop,hindex,hdiag) return end c c c ######################################################### c ## ## c ## subroutine modesrch -- normal mode local search ## c ## ## c ######################################################### c c subroutine modesrch (nmap,emap,range,neigen,grdmin) use iounit use omega implicit none integer i,k,nsearch integer nmap,neigen real*8 minimum,grdmin,range real*8 emap(*) real*8, allocatable :: step(:) real*8, allocatable :: eigen(:) real*8, allocatable :: vects(:,:) c c c store the current coordinates as the reference set c call makeref (1) c c perform dynamic allocation of some local arrays c allocate (step(nomega)) allocate (eigen(nomega)) allocate (vects(nomega,nomega)) c c convert to internal coordinates and find torsional modes c call makeint (0) call eigenrot (eigen,vects) c c search both directions along each torsional eigenvector c nsearch = 0 do i = 1, neigen do k = 1, nomega step(k) = vects(k,nomega-i+1) end do nsearch = nsearch + 1 call climber (nsearch,minimum,step,grdmin) call mapcheck (nmap,emap,range,minimum,grdmin) do k = 1, nomega step(k) = -vects(k,nomega-i+1) end do nsearch = nsearch + 1 call climber (nsearch,minimum,step,grdmin) call mapcheck (nmap,emap,range,minimum,grdmin) end do c c perform deallocation of some local arrays c deallocate (step) deallocate (eigen) deallocate (vects) return end c c c ############################################################### c ## ## c ## subroutine eigenrot -- torsional Hessian eigenvectors ## c ## ## c ############################################################### c c subroutine eigenrot (eigen,vects) use atoms use omega implicit none integer i,j,ihess real*8 vnorm real*8 eigen(*) real*8, allocatable :: matrix(:) real*8 vects(nomega,*) real*8, allocatable :: hrot(:,:) c c c perform dynamic allocation of some local arrays c allocate (matrix(nomega*(nomega+1)/2)) allocate (hrot(nomega,nomega)) c c compute the Hessian in torsional space c call hessrot ('FULL',hrot) c c place Hessian elements into triangular form c ihess = 0 do i = 1, nomega do j = i, nomega ihess = ihess + 1 matrix(ihess) = hrot(i,j) end do end do c c diagonalize the Hessian to obtain eigenvalues c call diagq (nomega,nomega,matrix,eigen,vects) c c perform deallocation of some local arrays c deallocate (matrix) deallocate (hrot) c c normalize the torsional Hessian eigenvectors c do i = 1, nomega vnorm = 0.0d0 do j = 1, nomega vnorm = vnorm + vects(j,i)**2 end do vnorm = sqrt(vnorm) do j = 1, nomega vects(j,i) = vects(j,i) / vnorm end do end do return end c c c ############################################################### c ## ## c ## subroutine climber -- explore single search direction ## c ## ## c ############################################################### c c subroutine climber (nsearch,minimum,step,grdmin) use inform use iounit use math use omega use potent use zcoord implicit none integer maxstep parameter (maxstep=500) integer i,kstep integer nstep,nsearch real*8 minimum,grdmin real*8 big,energy,size real*8 estep(0:maxstep) real*8 step(*) logical done logical oldpolar c c c convert current reference coordinates to a Z-matrix c call getref (1) call makeint (0) c c set the maximum number of steps and the step size c done = .false. big = 100000.0d0 minimum = big kstep = 0 nstep = 65 size = 0.1d0 * radian do i = 1, nomega step(i) = size * step(i) end do c c scan the search direction for a minimization candidate c do while (.not. done) if (kstep .ne. 0) then do i = 1, nomega ztors(zline(i)) = ztors(zline(i)) + step(i) end do end if call makexyz oldpolar = use_polar use_polar = .false. estep(kstep) = energy () use_polar = oldpolar if (kstep .ge. 2) then if (estep(kstep) .lt. estep(kstep-2) .and. & estep(kstep-1) .lt. estep(kstep-2)) then done = .true. do i = 1, nomega ztors(zline(i)) = ztors(zline(i)) - step(i) end do call makexyz call localmin (minimum,grdmin) if (minimum .le. -big) then minimum = big write (iout,10) nsearch 10 format (4x,'Search Direction',i4,38x,'<<<<<<') else if (minimum .ge. big) then minimum = big write (iout,20) nsearch 20 format (4x,'Search Direction',i4,38x,'>>>>>>') else if (digits .ge. 8) then write (iout,30) nsearch,kstep-1,minimum 30 format (4x,'Search Direction',i4,11x,'Step', & i7,6x,f20.8) else if (digits .ge. 6) then write (iout,40) nsearch,kstep-1,minimum 40 format (4x,'Search Direction',i4,11x,'Step', & i7,6x,f18.6) else write (iout,50) nsearch,kstep-1,minimum 50 format (4x,'Search Direction',i4,11x,'Step', & i7,6x,f16.4) end if end if end if end if if (kstep.ge.nstep .and. .not.done) then done = .true. write (iout,60) nsearch 60 format (4x,'Search Direction',i4,38x,'------') end if kstep = kstep + 1 end do return end c c c ################################################################ c ## ## c ## subroutine localmin -- optimize local search candidate ## c ## ## c ################################################################ c c c "localmin" is used during normal mode local search to c perform a Cartesian coordinate energy minimization c c subroutine localmin (minimum,grdmin) use atoms use inform use minima use output use potent use scales implicit none integer i,j,nvar real*8 minimum,scan1 real*8 grdmin,oldgrd real*8 gnorm,grms,big real*8, allocatable :: xx(:) real*8, allocatable :: derivs(:,:) logical oldverb,oldpolar character*6 mode,method external scan1,scan2 external optsave c c c initialize optimization output and maximum energy c iwrite = 0 iprint = 0 big = 100000.0d0 c c perform dynamic allocation of some local arrays c allocate (xx(3*n)) c c convert atomic coordinates to optimization parameters c nvar = 0 do i = 1, n nvar = nvar + 1 xx(nvar) = x(i) nvar = nvar + 1 xx(nvar) = y(i) nvar = nvar + 1 xx(nvar) = z(i) end do c c perform dynamic allocation of some global arrays c if (.not. set_scale) then if (.not. allocated(scale)) allocate (scale(nvar)) c c set scaling parameters to unity due to mixed optimization c set_scale = .true. do i = 1, nvar scale(i) = 1.0d0 end do end if c c adjust polarization and set initial optimization values c oldverb = verbose oldpolar = use_polar oldgrd = grdmin verbose = .false. use_polar = .false. grdmin = 3.0 c c initial optimizaton to get close to approximate minimum c call lbfgs (nvar,xx,minimum,grdmin,scan1,optsave) c c secondary optimization to reach the exact local minimum c use_polar = oldpolar grdmin = oldgrd mode = 'AUTO' method = 'AUTO' call tncg (mode,method,nvar,xx,minimum, & grdmin,scan1,scan2,optsave) verbose = oldverb c c convert optimization parameters to atomic coordinates 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 c c perform deallocation of some local arrays c deallocate (xx) c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c independently check the gradient convergence criterion c call gradient (minimum,derivs) gnorm = 0.0d0 do i = 1, n do j = 1, 3 gnorm = gnorm + derivs(j,i)**2 end do end do gnorm = sqrt(gnorm) grms = gnorm / sqrt(dble(n)) if (grms .gt. grdmin) minimum = big c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ############################################################## c ## COPYRIGHT (C) 1998 by Rohit Pappu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ############################################################## c ## ## c ## subroutine sdstep -- Verlet stochastic dynamics step ## c ## ## c ############################################################## c c c "sdstep" performs a single stochastic dynamics time step c via the velocity Verlet integration algorithm c c literature references: c c M. P. Allen, "Brownian Dynamics Simulation of a Chemical c Reaction in Solution", Molecular Physics, 40, 1073-1087 (1980) c c F. Guarnieri and W. C. Still, "A Rapidly Convergent Simulation c Method: Mixed Monte Carlo/Stochastic Dynamics", Journal of c Computational Chemistry, 15, 1302-1310 (1994) c c subroutine sdstep (istep,dt) use atoms use atomid use freeze use moldyn use units use usage use virial implicit none integer i,j,k integer istep real*8 dt,term real*8 epot,etot real*8 eksum real*8 temp,pres real*8 vxx,vyy,vzz real*8 vyx,vzx,vzy 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 :: pfric(:) real*8, allocatable :: vfric(:) real*8, allocatable :: afric(:) real*8, allocatable :: prand(:,:) real*8, allocatable :: vrand(:,:) real*8, allocatable :: derivs(:,:) c c c perform dynamic allocation of some local arrays c allocate (xold(n)) allocate (yold(n)) allocate (zold(n)) allocate (pfric(n)) allocate (vfric(n)) allocate (afric(n)) allocate (prand(3,n)) allocate (vrand(3,n)) allocate (derivs(3,n)) c c get frictional and random terms for position and velocity c call sdterm (istep,dt,pfric,vfric,afric,prand,vrand) c c store the current atom positions, then find full-step c positions and half-step velocities via modified Verlet c 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)*vfric(k) + a(1,k)*afric(k) + prand(1,k) y(k) = y(k) + v(2,k)*vfric(k) + a(2,k)*afric(k) + prand(2,k) z(k) = z(k) + v(3,k)*vfric(k) + a(3,k)*afric(k) + prand(3,k) do j = 1, 3 v(j,k) = v(j,k)*pfric(k) + 0.5d0*a(j,k)*vfric(k) end do end do 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 find the full-step velocities using modified Verlet 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) + 0.5d0*a(j,k)*vfric(k) + vrand(j,k) end do end do c c correct internal virial to account for frictional forces c do i = 1, nuse k = iuse(i) term = vfric(k)/dt - 1.0d0 vxx = term * x(k) * derivs(1,k) vyx = 0.5d0 * term * (y(k)*derivs(1,k)+x(k)*derivs(2,k)) vzx = 0.5d0 * term * (z(k)*derivs(1,k)+x(k)*derivs(3,k)) vyy = term * y(k) * derivs(2,k) vzy = 0.5d0 * term * (z(k)*derivs(2,k)+y(k)*derivs(3,k)) vzz = term * z(k) * derivs(3,k) 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 perform deallocation of some local arrays c deallocate (xold) deallocate (yold) deallocate (zold) deallocate (pfric) deallocate (vfric) deallocate (afric) deallocate (prand) deallocate (vrand) deallocate (derivs) 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) 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) return end c c c ############################################################# c ## ## c ## subroutine sdterm -- frictional and random SD terms ## c ## ## c ############################################################# c c c "sdterm" finds the frictional and random terms needed to c update positions and velocities during stochastic dynamics c c subroutine sdterm (istep,dt,pfric,vfric,afric,prand,vrand) use atoms use atomid use bath use stodyn use units use usage implicit none integer i,j,k integer istep real*8 dt,ktm real*8 gdt,egdt real*8 gdt2,gdt3 real*8 gdt4,gdt5 real*8 gdt6,gdt7 real*8 gdt8,gdt9 real*8 pterm,vterm real*8 pnorm,vnorm real*8 normal real*8 psig,vsig real*8 rho,rhoc real*8 pfric(*) real*8 vfric(*) real*8 afric(*) real*8 prand(3,*) real*8 vrand(3,*) logical first external normal save first data first / .true. / c c c perform dynamic allocation of some global arrays c if (first) then first = .false. if (.not. allocated(fgamma)) allocate (fgamma(n)) c c set the atomic friction coefficients to the global value c do i = 1, n fgamma(i) = friction end do end if c c set the value of the friction coefficient for each atom c if (use_sdarea) call sdarea (istep) c c get the frictional and random terms for stochastic dynamics c do i = 1, nuse k = iuse(i) gdt = fgamma(k) * dt c c stochastic dynamics reduces to simple MD for zero friction c if (gdt .le. 0.0d0) then pfric(k) = 1.0d0 vfric(k) = dt afric(k) = 0.5d0 * dt * dt do j = 1, 3 prand(j,k) = 0.0d0 vrand(j,k) = 0.0d0 end do c c analytical expressions when friction coefficient is large c else if (gdt .ge. 0.05d0) then egdt = exp(-gdt) pfric(k) = egdt vfric(k) = (1.0d0-egdt) / fgamma(k) afric(k) = (dt-vfric(k)) / fgamma(k) pterm = 2.0d0*gdt - 3.0d0 + (4.0d0-egdt)*egdt vterm = 1.0d0 - egdt**2 rho = (1.0d0-egdt)**2 / sqrt(pterm*vterm) c c use series expansions when friction coefficient is small c else gdt2 = gdt * gdt gdt3 = gdt * gdt2 gdt4 = gdt2 * gdt2 gdt5 = gdt2 * gdt3 gdt6 = gdt3 * gdt3 gdt7 = gdt3 * gdt4 gdt8 = gdt4 * gdt4 gdt9 = gdt4 * gdt5 afric(k) = (gdt2/2.0d0 - gdt3/6.0d0 + gdt4/24.0d0 & - gdt5/120.0d0 + gdt6/720.0d0 & - gdt7/5040.0d0 + gdt8/40320.0d0 & - gdt9/362880.0d0) / fgamma(k)**2 vfric(k) = dt - fgamma(k)*afric(k) pfric(k) = 1.0d0 - fgamma(k)*vfric(k) pterm = 2.0d0*gdt3/3.0d0 - gdt4/2.0d0 & + 7.0d0*gdt5/30.0d0 - gdt6/12.0d0 & + 31.0d0*gdt7/1260.0d0 - gdt8/160.0d0 & + 127.0d0*gdt9/90720.0d0 vterm = 2.0d0*gdt - 2.0d0*gdt2 + 4.0d0*gdt3/3.0d0 & - 2.0d0*gdt4/3.0d0 + 4.0d0*gdt5/15.0d0 & - 4.0d0*gdt6/45.0d0 + 8.0d0*gdt7/315.0d0 & - 2.0d0*gdt8/315.0d0 + 4.0d0*gdt9/2835.0d0 rho = sqrt(3.0d0) * (0.5d0 - gdt/16.0d0 & - 17.0d0*gdt2/1280.0d0 & + 17.0d0*gdt3/6144.0d0 & + 40967.0d0*gdt4/34406400.0d0 & - 57203.0d0*gdt5/275251200.0d0 & - 1429487.0d0*gdt6/13212057600.0d0 & + 1877509.0d0*gdt7/105696460800.0d0) end if c c compute random terms to thermostat the nonzero friction case c ktm = boltzmann * kelvin / mass(k) psig = sqrt(ktm*pterm) / fgamma(k) vsig = sqrt(ktm*vterm) rhoc = sqrt(1.0d0 - rho*rho) do j = 1, 3 pnorm = normal () vnorm = normal () prand(j,k) = psig * pnorm vrand(j,k) = vsig * (rho*pnorm+rhoc*vnorm) end do end if end do return end c c c ############################################################# c ## ## c ## subroutine sdarea -- scale SD friction coefficients ## c ## ## c ############################################################# c c c "sdarea" optionally scales the atomic friction coefficient c of each atom based on its accessible surface area c c literature reference: c c S. Yun-Yi, W. Lu and W. F. van Gunsteren, "On the Approximation c of Solvent Effects on the Conformation and Dynamics of c Cyclosporin A by Stochastic Dynamics Simulation Techniques", c Molecular Simulation, 1, 369-383 (1988) c c subroutine sdarea (istep) use atoms use atomid use couple use kvdws use math use stodyn use usage implicit none integer i,k integer istep integer resurf integer modstep real*8 probe,ratio,area real*8, allocatable :: radius(:) c c c determine new friction coefficients every few SD steps c resurf = 100 modstep = mod(istep,resurf) if (modstep .ne. 1) return c c perform dynamic allocation of some local arrays c allocate (radius(n)) c c set the atomic radii to estimates of sigma values c probe = 0.0d0 do i = 1, n radius(i) = rad(class(i)) / twosix if (radius(i) .ne. 0.0d0) radius(i) = radius(i) + probe end do c c scale atomic friction coefficients by accessible area c do i = 1, nuse k = iuse(i) if (radius(k) .ne. 0.0d0) then call surfatom (k,area,radius) ratio = area / (4.0d0*pi*radius(k)**2) fgamma(k) = ratio * friction end if end do c c monovalent atoms with zero radius get attached atom value c do i = 1, nuse k = iuse(i) if (radius(k).eq.0.0d0 .and. n12(k).eq.1) then fgamma(k) = fgamma(i12(1,k)) end if end do c c perform deallocation of some local arrays c deallocate (radius) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine search -- perform unidirectional line search ## c ## ## c ################################################################# c c c "search" is a unidirectional line search based upon parabolic c extrapolation and cubic interpolation using both function and c gradient values c c variables used by the routine : c c f function value at the best line search point c x current values of variables during line search c g gradient at the current point during line search c p initial search vector, unchanged by this routine c s scaled search vector at current line search point c angle angle between search and negative gradient vector c c parameters used by the routine : c c stpmin minimum step length in current line search direction c stpmax maximum step length in current line search direction c cappa stringency of line search (0=tight < cappa < 1=loose) c slpmax projected gradient above which stepsize is reduced c angmax maximum angle between search direction and -gradient c intmax maximum number of interpolations during line search c c status codes upon return : c c Success normal termination after satisfying "cappa" test c ScaleStep normal termination after a step size rescaling c ReSearch normal termination after a reinterpolation c WideAngle large angle between search direction and -gradient c BadIntpln unsatisfied "cappa" test after two searches c IntplnErr function value increase or serious gradient error c c subroutine search (nvar,f,g,x,p,f_move,angle,ncalls, & fgvalue,status) use linmin use math implicit none integer i,nvar integer ncalls integer intpln real*8 fgvalue real*8 f,f_move real*8 s_norm,g_norm real*8 cosang,angle real*8 step,parab real*8 cube,cubstp real*8 sss,ttt real*8 f_0,f_1 real*8 f_a,f_b,f_c real*8 sg_0,sg_1 real*8 sg_a,sg_b,sg_c real*8 x(*) real*8 g(*) real*8 p(*) real*8, allocatable :: x_0(:) real*8, allocatable :: s(:) logical restart character*9 status character*9 blank external fgvalue c c c use default parameters for the line search if needed c blank = ' ' if (stpmin .eq. 0.0d0) stpmin = 1.0d-16 if (stpmax .eq. 0.0d0) stpmax = 2.0d0 if (cappa .eq. 0.0d0) cappa = 0.1d0 if (slpmax .eq. 0.0d0) slpmax = 10000.0d0 if (angmax .eq. 0.0d0) angmax = 180.0d0 if (intmax .eq. 0) intmax = 5 c c perform dynamic allocation of some local arrays c allocate (x_0(nvar)) allocate (s(nvar)) c c copy the search direction into a new vector c do i = 1, nvar s(i) = p(i) end do c c compute the length of gradient and search direction c g_norm = 0.0d0 s_norm = 0.0d0 do i = 1, nvar g_norm = g_norm + g(i)*g(i) s_norm = s_norm + s(i)*s(i) end do g_norm = sqrt(g_norm) s_norm = sqrt(s_norm) c c store initial function, then normalize the c search vector and find projected gradient c f_0 = f sg_0 = 0.0d0 do i = 1, nvar x_0(i) = x(i) s(i) = s(i) / s_norm sg_0 = sg_0 + s(i)*g(i) end do c c check the angle between the search direction c and the negative gradient vector c cosang = -sg_0 / g_norm cosang = min(1.0d0,max(-1.0d0,cosang)) angle = radian * acos(cosang) if (angle .gt. angmax) then status = 'WideAngle' deallocate (x_0) deallocate (s) return end if c c set the initial stepsize to the length of the passed c search vector, or based on previous function decrease c step = 2.0d0 * abs(f_move/sg_0) step = min(step,s_norm) if (step .gt. stpmax) step = stpmax if (step .lt. stpmin) step = stpmin c c beginning of the parabolic extrapolation procedure c 10 continue restart = .true. intpln = 0 f_b = f_0 sg_b = sg_0 c c replace last point by latest and take another step c 20 continue f_a = f_b sg_a = sg_b do i = 1, nvar x(i) = x(i) + step*s(i) end do c c get new function and projected gradient following a step c ncalls = ncalls + 1 f_b = fgvalue (x,g) sg_b = 0.0d0 do i = 1, nvar sg_b = sg_b + s(i)*g(i) end do c c scale stepsize if initial gradient change is too large c if (abs(sg_b/sg_a).ge.slpmax .and. restart) then do i = 1, nvar x(i) = x_0(i) end do step = step / 10.0d0 status = 'ScaleStep' goto 10 end if restart = .false. c c return if the gradient is small and function decreases c if (abs(sg_b/sg_0).le.cappa .and. f_b.lt.f_a) then f = f_b if (status .eq. blank) status = ' Success ' deallocate (x_0) deallocate (s) return end if c c interpolate if gradient changes sign or function increases c if (sg_b*sg_a.lt.0.0d0 .or. f_b.gt.f_a) goto 30 c c if the finite difference curvature is negative double the step; c or if (step < parabolic estimate < 4*step) use this estimate, c otherwise truncate to step or 4*step, respectively c step = 2.0d0 * step if (sg_b .gt. sg_a) then parab = (f_a-f_b) / (sg_b-sg_a) if (parab .gt. 2.0d0*step) parab = 2.0d0 * step if (parab .lt. 0.5d0*step) parab = 0.5d0 * step step = parab end if if (step .gt. stpmax) step = stpmax goto 20 c c beginning of the cubic interpolation procedure c 30 continue intpln = intpln + 1 sss = 3.0d0*(f_b-f_a)/step - sg_a - sg_b ttt = sss*sss - sg_a*sg_b if (ttt .lt. 0.0d0) then f = f_b status = 'IntplnErr' deallocate (x_0) deallocate (s) return end if ttt = sqrt(ttt) cube = step * (sg_b+ttt+sss)/(sg_b-sg_a+2.0d0*ttt) if (cube.lt.0.0d0 .or. cube.gt.step) then f = f_b status = 'IntplnErr' deallocate (x_0) deallocate (s) return end if do i = 1, nvar x(i) = x(i) - cube*s(i) end do c c get new function and gradient, then test for termination c ncalls = ncalls + 1 f_c = fgvalue (x,g) sg_c = 0.0d0 do i = 1, nvar sg_c = sg_c + s(i)*g(i) end do if (abs(sg_c/sg_0) .le. cappa) then f = f_c if (status .eq. blank) status = ' Success ' deallocate (x_0) deallocate (s) return end if c c get the next pair of bracketing points by replacing one c of the current brackets with the interpolated point c if (f_c.le.f_a .or. f_c.le.f_b) then cubstp = min(abs(cube),abs(step-cube)) if (cubstp.ge.stpmin .and. intpln.lt.intmax) then c c if the current brackets have slopes of opposite sign, c then substitute the interpolated point for the bracket c point with slope of same sign as the interpolated point c if (sg_a*sg_b .lt. 0.0d0) then if (sg_a*sg_c .lt. 0.0d0) then f_b = f_c sg_b = sg_c step = step - cube else f_a = f_c sg_a = sg_c step = cube do i = 1, nvar x(i) = x(i) + cube*s(i) end do end if c c if current brackets have slope of same sign, then replace c the far bracket if the interpolated point has a slope of c the opposite sign or a lower function value than the near c bracket, otherwise replace the near bracket point c else if (sg_a*sg_c.lt.0.0d0 .or. f_a.le.f_c) then f_b = f_c sg_b = sg_c step = step - cube else f_a = f_c sg_a = sg_c step = cube do i = 1, nvar x(i) = x(i) + cube*s(i) end do end if end if goto 30 end if end if c c interpolation has failed, reset to best current point c f_1 = min(f_a,f_b,f_c) if (f_1 .eq. f_a) then sg_1 = sg_a do i = 1, nvar x(i) = x(i) + (cube-step)*s(i) end do else if (f_1 .eq. f_b) then sg_1 = sg_b do i = 1, nvar x(i) = x(i) + cube*s(i) end do else if (f_1 .eq. f_c) then sg_1 = sg_c end if c c try to restart from best point with smaller stepsize c if (f_1 .gt. f_0) then ncalls = ncalls + 1 f = fgvalue (x,g) status = 'IntplnErr' deallocate (x_0) deallocate (s) return end if f_0 = f_1 sg_0 = sg_1 if (sg_1 .gt. 0.0d0) then do i = 1, nvar s(i) = -s(i) end do sg_0 = -sg_1 end if step = max(cube,step-cube) / 10.0d0 if (step .lt. stpmin) step = stpmin c c if already restarted once, then return with best point c if (status .eq. ' ReSearch') then ncalls = ncalls + 1 f = fgvalue (x,g) status = 'BadIntpln' deallocate (x_0) deallocate (s) return else status = ' ReSearch' goto 10 end if end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module sequen -- sequence information for biopolymer ## c ## ## c ############################################################## c c c nseq total number of residues in biopolymer sequences c nchain number of separate biopolymer sequence chains c ichain first and last residue in each biopolymer chain c seqtyp residue type for each residue in the sequence c seq three-letter code for each residue in the sequence c chnnam one-letter identifier for each sequence chain c chntyp contents of each chain (GENERIC, PEPTIDE or NUCLEIC) c c module sequen use sizes implicit none integer nseq integer nchain integer ichain(2,maxres) integer seqtyp(maxres) character*1 chnnam(maxres) character*3 seq(maxres) character*7 chntyp(maxres) save end c c c ################################################################ c ## COPYRIGHT (C) 2003 by Michael Schnieders & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ############################################################# c ## ## c ## routines below implement dummy versions of the socket ## c ## communication calls required for the transmission of ## c ## information between Tinker and Force Field Explorer; ## c ## functional C code is in "server.c", while the dummy ## c ## calls in this file are written in standard Fortran ## c ## ## c ############################################################# c c ############################ c ## ## c ## subroutine chksocket ## c ## ## c ############################ c c subroutine chksocket (flag) implicit none integer flag c c c set flag that will disable socket communications c flag = 0 return end c c c ############################ c ## ## c ## subroutine createjvm ## c ## ## c ############################ c c subroutine createjvm (flag) implicit none integer flag return end c c c ############################# c ## ## c ## subroutine destroyjvm ## c ## ## c ############################# c c subroutine destroyjvm () implicit none return end c c c ############################### c ## ## c ## subroutine createserver ## c ## ## c ############################### c c subroutine createserver (flag) implicit none integer flag return end c c c ################################ c ## ## c ## subroutine destroyserver ## c ## ## c ################################ c c subroutine destroyserver () implicit none return end c c c ############################### c ## ## c ## subroutine createsystem ## c ## ## c ############################### c c subroutine createsystem (n,nkey,flag) implicit none integer n integer nkey integer flag return end c c c ############################# c ## ## c ## subroutine getmonitor ## c ## ## c ############################# c c subroutine getmonitor () implicit none return end c c c ################################# c ## ## c ## subroutine releasemonitor ## c ## ## c ################################# c c subroutine releasemonitor () implicit none return end c c c ############################### c ## ## c ## subroutine createupdate ## c ## ## c ############################### c c subroutine createupdate (n,mode,amoeba,flag) implicit none integer n integer mode integer amoeba integer flag return end c c c ############################# c ## ## c ## subroutine needupdate ## c ## ## c ############################# c c subroutine needupdate (flag) implicit none integer flag return end c c c ############################# c ## ## c ## subroutine setupdated ## c ## ## c ############################# c c subroutine setupdated () implicit none return end c c c ########################## c ## ## c ## subroutine setfile ## c ## ## c ########################## c c subroutine setfile (filename) implicit none character*(*) filename return end c c c ################################ c ## ## c ## subroutine setforcefield ## c ## ## c ################################ c c subroutine setforcefield (forcefield) implicit none character*(*) forcefield return end c c c ############################# c ## ## c ## subroutine setkeyword ## c ## ## c ############################# c c subroutine setkeyword (i,keyline) implicit none integer i character*(*) keyline return end c c c ############################### c ## ## c ## subroutine setatomtypes ## c ## ## c ############################### c c subroutine setatomtypes (n,type) implicit none integer n integer type(*) return end c c c ############################ c ## ## c ## subroutine setatomic ## c ## ## c ############################ c c subroutine setatomic (n,atomic) implicit none integer n integer atomic(*) return end c c c ########################## c ## ## c ## subroutine setmass ## c ## ## c ########################## c c subroutine setmass (n,mass) implicit none integer n real*8 mass(*) return end c c c ############################ c ## ## c ## subroutine setcharge ## c ## ## c ############################ c c subroutine setcharge (n,charge) implicit none integer n real*8 charge(*) return end c c c ################################## c ## ## c ## subroutine setconnectivity ## c ## ## c ################################## c c subroutine setconnectivity (n,b1,b2,b3,b4) implicit none integer n integer b1(*) integer b2(*) integer b3(*) integer b4(*) return end c c c ########################## c ## ## c ## subroutine setname ## c ## ## c ########################## c c subroutine setname (i,name) implicit none integer i character*(*) name return end c c c ########################### c ## ## c ## subroutine setstory ## c ## ## c ########################### c c subroutine setstory (i,story) implicit none integer i character*(*) story return end c c c ################################# c ## ## c ## subroutine setcoordinates ## c ## ## c ################################# c c subroutine setcoordinates (n,x,y,z) implicit none integer n real*8 x(*) real*8 y(*) real*8 z(*) return end c c c ########################## c ## ## c ## subroutine setstep ## c ## ## c ########################## c c subroutine setstep (ncycle) implicit none integer ncycle return end c c c ############################ c ## ## c ## subroutine setmdtime ## c ## ## c ############################ c c subroutine setmdtime (time) implicit none real*8 time return end c c c ############################ c ## ## c ## subroutine setenergy ## c ## ## c ############################ c c subroutine setenergy (energy) implicit none real*8 energy return end c c c ############################### c ## ## c ## subroutine setgradients ## c ## ## c ############################### c c subroutine setgradients (n,dx,dy,dz) implicit none integer n real*8 dx(*) real*8 dy(*) real*8 dz(*) return end c c c ############################## c ## ## c ## subroutine setvelocity ## c ## ## c ############################## c c subroutine setvelocity (n,vx,vy,vz) implicit none integer n real*8 vx(*) real*8 vy(*) real*8 vz(*) return end c c c ################################## c ## ## c ## subroutine setacceleration ## c ## ## c ################################## c c subroutine setacceleration (n,ax,ay,az) implicit none integer n real*8 ax(*) real*8 ay(*) real*8 az(*) return end c c c ############################# c ## ## c ## subroutine setinduced ## c ## ## c ############################# c c subroutine setinduced (n,ux,uy,uz) implicit none integer n real*8 ux(*) real*8 uy(*) real*8 uz(*) return end c c c ################################################### c ## COPYRIGHT (C) 2022 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine setprm -- allocate force field parameters ## c ## ## c ############################################################## c c c "setprm" counts and allocates memory space for force field c parameter values involving multiple atom types or classes as c found in the parameter file and keyfile c c subroutine setprm use atoms use couple use kangs use kantor use kbonds use kcflux use kdipol use keys use khbond use kiprop use kitors use kmulti use kopbnd use kopdst use korbs use kpitor use kpolpr use kstbnd use ksttor use ktorsn use ktrtor use kurybr use kvdwpr use params use restrn implicit none integer i,k,ia,ib,next character*20 keyword character*240 record character*240 string c c c zero out the count of each force field parameter type c maxnb = 0 maxnb5 = 0 maxnb4 = 0 maxnb3 = 0 maxnel = 0 maxna = 0 maxna5 = 0 maxna4 = 0 maxna3 = 0 maxnap = 0 maxnaf = 0 maxnsb = 0 maxnu = 0 maxnopb = 0 maxnopd = 0 maxndi = 0 maxnti = 0 maxnt = 0 maxnt5 = 0 maxnt4 = 0 maxnpt = 0 maxnbt = 0 maxnat = 0 maxntt = 0 maxnvp = 0 maxnhb = 0 maxnd = 0 maxnd5 = 0 maxnd4 = 0 maxnd3 = 0 maxnmp = 0 maxnpp = 0 maxncfb = 0 maxncfa = 0 maxnpi = 0 maxnpi5 = 0 maxnpi4 = 0 maxfix = 0 c c find any parameter values found in the parameter file c do i = 1, nprm record = prmline(i) next = 1 call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:5) .eq. 'BOND ') maxnb = maxnb + 1 if (keyword(1:9) .eq. 'MMFFBOND ') maxnb = maxnb + 1 if (keyword(1:6) .eq. 'BOND5 ') maxnb5 = maxnb5 + 1 if (keyword(1:6) .eq. 'BOND4 ') maxnb4 = maxnb4 + 1 if (keyword(1:6) .eq. 'BOND3 ') maxnb3 = maxnb3 + 1 if (keyword(1:9) .eq. 'ELECTNEG ') maxnel = maxnel + 1 if (keyword(1:6) .eq. 'ANGLE ') maxna = maxna + 1 if (keyword(1:10) .eq. 'MMFFANGLE ') maxna = maxna + 1 if (keyword(1:7) .eq. 'ANGLE5 ') maxna5 = maxna5 + 1 if (keyword(1:7) .eq. 'ANGLE4 ') maxna4 = maxna4 + 1 if (keyword(1:7) .eq. 'ANGLE3 ') maxna3 = maxna3 + 1 if (keyword(1:7) .eq. 'ANGLEP ') maxnap = maxnap + 1 if (keyword(1:7) .eq. 'ANGLEF ') maxnaf = maxnaf + 1 if (keyword(1:7) .eq. 'STRBND ') maxnsb = maxnsb + 1 if (keyword(1:9) .eq. 'UREYBRAD ') maxnu = maxnu + 1 if (keyword(1:7) .eq. 'OPBEND ') maxnopb = maxnopb + 1 if (keyword(1:7) .eq. 'OPDIST ') maxnopd = maxnopd + 1 if (keyword(1:9) .eq. 'IMPROPER ') maxndi = maxndi + 1 if (keyword(1:8) .eq. 'IMPTORS ') maxnti = maxnti + 1 if (keyword(1:8) .eq. 'TORSION ') maxnt = maxnt + 1 if (keyword(1:12) .eq. 'MMFFTORSION ') maxnt = maxnt + 1 if (keyword(1:9) .eq. 'TORSION5 ') maxnt5 = maxnt5 + 1 if (keyword(1:9) .eq. 'TORSION4 ') maxnt4 = maxnt4 + 1 if (keyword(1:7) .eq. 'PITORS ') maxnpt = maxnpt + 1 if (keyword(1:8) .eq. 'STRTORS ') maxnbt = maxnbt + 1 if (keyword(1:8) .eq. 'ANGTORS ') maxnat = maxnat + 1 if (keyword(1:8) .eq. 'TORTORS ') maxntt = maxntt + 1 if (keyword(1:8) .eq. 'VDWPAIR ') maxnvp = maxnvp + 1 if (keyword(1:6) .eq. 'VDWPR ') maxnvp = maxnvp + 1 if (keyword(1:6) .eq. 'HBOND ') maxnhb = maxnhb + 1 if (keyword(1:7) .eq. 'DIPOLE ') maxnd = maxnd + 1 if (keyword(1:8) .eq. 'DIPOLE5 ') maxnd5 = maxnd5 + 1 if (keyword(1:8) .eq. 'DIPOLE4 ') maxnd4 = maxnd4 + 1 if (keyword(1:8) .eq. 'DIPOLE3 ') maxnd3 = maxnd3 + 1 if (keyword(1:10) .eq. 'MULTIPOLE ') maxnmp = maxnmp + 1 if (keyword(1:8) .eq. 'POLPAIR ') maxnpp = maxnpp + 1 if (keyword(1:9) .eq. 'BNDCFLUX ') maxncfb = maxncfb + 1 if (keyword(1:9) .eq. 'ANGCFLUX ') maxncfa = maxncfa + 1 if (keyword(1:7) .eq. 'PIBOND ') maxnpi = maxnpi + 1 if (keyword(1:8) .eq. 'PIBOND5 ') maxnpi5 = maxnpi5 + 1 if (keyword(1:8) .eq. 'PIBOND4 ') maxnpi4 = maxnpi4 + 1 if (keyword(1:9) .eq. 'RESTRAIN-') then maxfix = maxfix + 1 if (keyword(10:18) .eq. 'POSITION ') then string = record(19:240) next = 1 call getnumb (string,ia,next) if (ia.ge.-n .and. ia.le.-1) then ia = abs(ia) call getnumb (string,ib,next) ib = min(abs(ib),n) maxfix = maxfix + max(0,ib-ia) end if end if end if if (keyword(1:18) .eq. 'ENFORCE-CHIRALITY ') then do k = 1, n if (n12(k) .eq.4) maxfix = maxfix + 1 end do end if end do c c find additional parameter values found in the keyfile c do i = 1, nkey record = keyline(i) next = 1 call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:5) .eq. 'BOND ') maxnb = maxnb + 1 if (keyword(1:9) .eq. 'MMFFBOND ') maxnb = maxnb + 1 if (keyword(1:6) .eq. 'BOND5 ') maxnb5 = maxnb5 + 1 if (keyword(1:6) .eq. 'BOND4 ') maxnb4 = maxnb4 + 1 if (keyword(1:6) .eq. 'BOND3 ') maxnb3 = maxnb3 + 1 if (keyword(1:9) .eq. 'ELECTNEG ') maxnel = maxnel + 1 if (keyword(1:6) .eq. 'ANGLE ') maxna = maxna + 1 if (keyword(1:10) .eq. 'MMFFANGLE ') maxna = maxna + 1 if (keyword(1:7) .eq. 'ANGLE5 ') maxna5 = maxna5 + 1 if (keyword(1:7) .eq. 'ANGLE4 ') maxna4 = maxna4 + 1 if (keyword(1:7) .eq. 'ANGLE3 ') maxna3 = maxna3 + 1 if (keyword(1:7) .eq. 'ANGLEP ') maxnap = maxnap + 1 if (keyword(1:7) .eq. 'ANGLEF ') maxnaf = maxnaf + 1 if (keyword(1:7) .eq. 'STRBND ') maxnsb = maxnsb + 1 if (keyword(1:9) .eq. 'UREYBRAD ') maxnu = maxnu + 1 if (keyword(1:7) .eq. 'OPBEND ') maxnopb = maxnopb + 1 if (keyword(1:7) .eq. 'OPDIST ') maxnopd = maxnopd + 1 if (keyword(1:9) .eq. 'IMPROPER ') maxndi = maxndi + 1 if (keyword(1:8) .eq. 'IMPTORS ') maxnti = maxnti + 1 if (keyword(1:8) .eq. 'TORSION ') maxnt = maxnt + 1 if (keyword(1:12) .eq. 'MMFFTORSION ') maxnt = maxnt + 1 if (keyword(1:9) .eq. 'TORSION5 ') maxnt5 = maxnt5 + 1 if (keyword(1:9) .eq. 'TORSION4 ') maxnt4 = maxnt4 + 1 if (keyword(1:7) .eq. 'PITORS ') maxnpt = maxnpt + 1 if (keyword(1:8) .eq. 'STRTORS ') maxnbt = maxnbt + 1 if (keyword(1:8) .eq. 'ANGTORS ') maxnat = maxnat + 1 if (keyword(1:8) .eq. 'TORTORS ') maxntt = maxntt + 1 if (keyword(1:8) .eq. 'VDWPAIR ') maxnvp = maxnvp + 1 if (keyword(1:6) .eq. 'VDWPR ') maxnvp = maxnvp + 1 if (keyword(1:6) .eq. 'HBOND ') maxnhb = maxnhb + 1 if (keyword(1:7) .eq. 'DIPOLE ') maxnd = maxnd + 1 if (keyword(1:8) .eq. 'DIPOLE5 ') maxnd5 = maxnd5 + 1 if (keyword(1:8) .eq. 'DIPOLE4 ') maxnd4 = maxnd4 + 1 if (keyword(1:8) .eq. 'DIPOLE3 ') maxnd3 = maxnd3 + 1 if (keyword(1:10) .eq. 'MULTIPOLE ') maxnmp = maxnmp + 1 if (keyword(1:8) .eq. 'POLPAIR ') maxnpp = maxnpp + 1 if (keyword(1:9) .eq. 'BNDCFLUX ') maxncfb = maxncfb + 1 if (keyword(1:9) .eq. 'ANGCFLUX ') maxncfa = maxncfa + 1 if (keyword(1:7) .eq. 'PIBOND ') maxnpi = maxnpi + 1 if (keyword(1:8) .eq. 'PIBOND5 ') maxnpi5 = maxnpi5 + 1 if (keyword(1:8) .eq. 'PIBOND4 ') maxnpi4 = maxnpi4 + 1 if (keyword(1:9) .eq. 'RESTRAIN-') then maxfix = maxfix + 1 if (keyword(10:18) .eq. 'POSITION ') then string = record(19:240) next = 1 call getnumb (string,ia,next) if (ia.ge.-n .and. ia.le.-1) then ia = abs(ia) call getnumb (string,ib,next) ib = min(abs(ib),n) maxfix = maxfix + max(0,ib-ia) end if end if end if if (keyword(1:18) .eq. 'ENFORCE-CHIRALITY ') then do k = 1, n if (n12(k) .eq.4) maxfix = maxfix + 1 end do end if end do c c set the allocated memory for each parameter type c maxnb = max(500,maxnb+100) maxnb5 = max(500,maxnb5+100) maxnb4 = max(500,maxnb4+100) maxnb3 = max(500,maxnb3+100) maxnel = max(500,maxnel+100) maxna = max(500,maxna+100) maxna5 = max(500,maxna5+100) maxna4 = max(500,maxna4+100) maxna3 = max(500,maxna3+100) maxnap = max(500,maxnap+100) maxnaf = max(500,maxnaf+100) maxnsb = max(500,maxnsb+100) maxnu = max(500,maxnu+100) maxnopb = max(500,maxnopb+100) maxnopd = max(500,maxnopd+100) maxndi = max(500,maxndi+100) maxnti = max(500,maxnti+100) maxnt = max(500,maxnt+100) maxnt5 = max(500,maxnt5+100) maxnt4 = max(500,maxnt4+100) maxnpt = max(500,maxnpt+100) maxnbt = max(500,maxnbt+100) maxnat = max(500,maxnat+100) maxntt = max(50,maxntt+10) maxnvp = max(500,maxnvp+100) maxnhb = max(500,maxnhb+100) maxnd = max(500,maxnd+100) maxnd5 = max(500,maxnd5+100) maxnd4 = max(500,maxnd4+100) maxnd3 = max(500,maxnd3+100) maxnmp = max(500,maxnmp+100) maxnpp = max(500,maxnpp+100) maxncfb = max(500,maxncfb+100) maxncfa = max(500,maxncfa+100) maxnpi = max(500,maxnpi+100) maxnpi5 = max(500,maxnpi5+100) maxnpi4 = max(500,maxnpi4+100) maxfix = max(500,maxfix+100) c c allocate bond stretching forcefield parameters c if (allocated(bcon)) deallocate (bcon) allocate (bcon(maxnb)) if (allocated(bcon5)) deallocate (bcon5) allocate (bcon5(maxnb5)) if (allocated(bcon4)) deallocate (bcon4) allocate (bcon4(maxnb4)) if (allocated(bcon3)) deallocate (bcon3) allocate (bcon3(maxnb3)) if (allocated(blen)) deallocate (blen) allocate (blen(maxnb)) if (allocated(blen5)) deallocate (blen5) allocate (blen5(maxnb5)) if (allocated(blen4)) deallocate (blen4) allocate (blen4(maxnb4)) if (allocated(blen3)) deallocate (blen3) allocate (blen3(maxnb3)) if (allocated(dlen)) deallocate (dlen) allocate (dlen(maxnel)) if (allocated(kb)) deallocate (kb) allocate (kb(maxnb)) if (allocated(kb5)) deallocate (kb5) allocate (kb5(maxnb5)) if (allocated(kb4)) deallocate (kb4) allocate (kb4(maxnb4)) if (allocated(kb3)) deallocate (kb3) allocate (kb3(maxnb3)) if (allocated(kel)) deallocate (kel) allocate (kel(maxnel)) c c allocate bond angle bend forcefield parameters c if (allocated(acon)) deallocate (acon) allocate (acon(maxna)) if (allocated(acon5)) deallocate (acon5) allocate (acon5(maxna5)) if (allocated(acon4)) deallocate (acon4) allocate (acon4(maxna4)) if (allocated(acon3)) deallocate (acon3) allocate (acon3(maxna3)) if (allocated(aconp)) deallocate (aconp) allocate (aconp(maxnap)) if (allocated(aconf)) deallocate (aconf) allocate (aconf(maxnaf)) if (allocated(ang)) deallocate (ang) allocate (ang(3,maxna)) if (allocated(ang5)) deallocate (ang5) allocate (ang5(3,maxna5)) if (allocated(ang4)) deallocate (ang4) allocate (ang4(3,maxna4)) if (allocated(ang3)) deallocate (ang3) allocate (ang3(3,maxna3)) if (allocated(angp)) deallocate (angp) allocate (angp(2,maxnap)) if (allocated(angf)) deallocate (angf) allocate (angf(2,maxnaf)) if (allocated(ka)) deallocate (ka) allocate (ka(maxna)) if (allocated(ka5)) deallocate (ka5) allocate (ka5(maxna5)) if (allocated(ka4)) deallocate (ka4) allocate (ka4(maxna4)) if (allocated(ka3)) deallocate (ka3) allocate (ka3(maxna3)) if (allocated(kap)) deallocate (kap) allocate (kap(maxnap)) if (allocated(kaf)) deallocate (kaf) allocate (kaf(maxnaf)) c c allocate stretch-bend forcefield parameters c if (allocated(stbn)) deallocate (stbn) allocate (stbn(2,maxnsb)) if (allocated(ksb)) deallocate (ksb) allocate (ksb(maxnsb)) c c allocate Urey-Bradley term forcefield parameters c if (allocated(ucon)) deallocate (ucon) allocate (ucon(maxnu)) if (allocated(dst13)) deallocate (dst13) allocate (dst13(maxnu)) if (allocated(ku)) deallocate (ku) allocate (ku(maxnu)) c c allocate out-of-plane bend forcefield parameters c if (allocated(opbn)) deallocate (opbn) allocate (opbn(maxnopb)) if (allocated(kopb)) deallocate (kopb) allocate (kopb(maxnopb)) c c allocate out-of-plane distance forcefield parameters c if (allocated(opds)) deallocate (opds) allocate (opds(maxnopd)) if (allocated(kopd)) deallocate (kopd) allocate (kopd(maxnopd)) c c allocate improper dihedral forcefield parameters c if (allocated(dcon)) deallocate (dcon) allocate (dcon(maxndi)) if (allocated(tdi)) deallocate (tdi) allocate (tdi(maxndi)) if (allocated(kdi)) deallocate (kdi) allocate (kdi(maxndi)) c c allocate improper torsion forcefield parameters c if (allocated(ti1)) deallocate (ti1) allocate (ti1(2,maxnti)) if (allocated(ti2)) deallocate (ti2) allocate (ti2(2,maxnti)) if (allocated(ti3)) deallocate (ti3) allocate (ti3(2,maxnti)) if (allocated(kti)) deallocate (kti) allocate (kti(maxnti)) c c allocate torsion angle forcefield parameters c if (allocated(t1)) deallocate (t1) allocate (t1(2,maxnt)) if (allocated(t2)) deallocate (t2) allocate (t2(2,maxnt)) if (allocated(t3)) deallocate (t3) allocate (t3(2,maxnt)) if (allocated(t4)) deallocate (t4) allocate (t4(2,maxnt)) if (allocated(t5)) deallocate (t5) allocate (t5(2,maxnt)) if (allocated(t6)) deallocate (t6) allocate (t6(2,maxnt)) if (allocated(t15)) deallocate (t15) allocate (t15(2,maxnt5)) if (allocated(t25)) deallocate (t25) allocate (t25(2,maxnt5)) if (allocated(t35)) deallocate (t35) allocate (t35(2,maxnt5)) if (allocated(t45)) deallocate (t45) allocate (t45(2,maxnt5)) if (allocated(t55)) deallocate (t55) allocate (t55(2,maxnt5)) if (allocated(t65)) deallocate (t65) allocate (t65(2,maxnt5)) if (allocated(t14)) deallocate (t14) allocate (t14(2,maxnt4)) if (allocated(t24)) deallocate (t24) allocate (t24(2,maxnt4)) if (allocated(t34)) deallocate (t34) allocate (t34(2,maxnt4)) if (allocated(t44)) deallocate (t44) allocate (t44(2,maxnt4)) if (allocated(t54)) deallocate (t54) allocate (t54(2,maxnt4)) if (allocated(t64)) deallocate (t64) allocate (t64(2,maxnt4)) if (allocated(kt)) deallocate (kt) allocate (kt(maxnt)) if (allocated(kt5)) deallocate (kt5) allocate (kt5(maxnt5)) if (allocated(kt4)) deallocate (kt4) allocate (kt4(maxnt4)) c c allocate pi-system torsion forcefield parameters c if (allocated(ptcon)) deallocate (ptcon) allocate (ptcon(maxnpt)) if (allocated(kpt)) deallocate (kpt) allocate (kpt(maxnpt)) c c allocate stretch-torsion forcefield parameters c if (allocated(btcon)) deallocate (btcon) allocate (btcon(9,maxnbt)) if (allocated(kbt)) deallocate (kbt) allocate (kbt(maxnbt)) c c allocate angle-torsion forcefield parameters c if (allocated(atcon)) deallocate (atcon) allocate (atcon(6,maxnat)) if (allocated(kat)) deallocate (kat) allocate (kat(maxnat)) c c allocate torsion-torsion forcefield parameters c if (allocated(tnx)) deallocate (tnx) allocate (tnx(maxntt)) if (allocated(tny)) deallocate (tny) allocate (tny(maxntt)) if (allocated(ttx)) deallocate (ttx) allocate (ttx(maxtgrd,maxntt)) if (allocated(tty)) deallocate (tty) allocate (tty(maxtgrd,maxntt)) if (allocated(tbf)) deallocate (tbf) allocate (tbf(maxtgrd2,maxntt)) if (allocated(tbx)) deallocate (tbx) allocate (tbx(maxtgrd2,maxntt)) if (allocated(tby)) deallocate (tby) allocate (tby(maxtgrd2,maxntt)) if (allocated(tbxy)) deallocate (tbxy) allocate (tbxy(maxtgrd2,maxntt)) if (allocated(ktt)) deallocate (ktt) allocate (ktt(maxntt)) c c allocate special vdw term forcefield parameters c if (allocated(radpr)) deallocate (radpr) allocate (radpr(maxnvp)) if (allocated(epspr)) deallocate (epspr) allocate (epspr(maxnvp)) if (allocated(kvpr)) deallocate (kvpr) allocate (kvpr(maxnvp)) c c allocate H-bonding term forcefield parameters c if (allocated(radhb)) deallocate (radhb) allocate (radhb(maxnhb)) if (allocated(epshb)) deallocate (epshb) allocate (epshb(maxnhb)) if (allocated(khb)) deallocate (khb) allocate (khb(maxnhb)) c c allocate bond dipole forcefield parameters c if (allocated(dpl)) deallocate (dpl) allocate (dpl(maxnd)) if (allocated(dpl5)) deallocate (dpl5) allocate (dpl5(maxnd5)) if (allocated(dpl4)) deallocate (dpl4) allocate (dpl4(maxnd4)) if (allocated(dpl3)) deallocate (dpl3) allocate (dpl3(maxnd3)) if (allocated(pos)) deallocate (pos) allocate (pos(maxnd)) if (allocated(pos5)) deallocate (pos5) allocate (pos5(maxnd5)) if (allocated(pos4)) deallocate (pos4) allocate (pos4(maxnd4)) if (allocated(pos3)) deallocate (pos3) allocate (pos3(maxnd3)) if (allocated(kd)) deallocate (kd) allocate (kd(maxnd)) if (allocated(kd5)) deallocate (kd5) allocate (kd5(maxnd5)) if (allocated(kd4)) deallocate (kd4) allocate (kd4(maxnd4)) if (allocated(kd3)) deallocate (kd3) allocate (kd3(maxnd3)) c c allocate atomic multipole forcefield parameters c if (allocated(multip)) deallocate (multip) allocate (multip(13,maxnmp)) if (allocated(mpaxis)) deallocate (mpaxis) allocate (mpaxis(maxnmp)) if (allocated(kmp)) deallocate (kmp) allocate (kmp(maxnmp)) c c allocate special Thole forcefield parameters c if (allocated(thlpr)) deallocate (thlpr) allocate (thlpr(maxnpp)) if (allocated(thdpr)) deallocate (thdpr) allocate (thdpr(maxnpp)) if (allocated(kppr)) deallocate (kppr) allocate (kppr(maxnpp)) c c allocate charge flux term forcefield parameters c if (allocated(cflb)) deallocate (cflb) allocate (cflb(maxncfb)) if (allocated(cfla)) deallocate (cfla) allocate (cfla(2,maxncfa)) if (allocated(cflab)) deallocate (cflab) allocate (cflab(2,maxncfa)) if (allocated(kcfb)) deallocate (kcfb) allocate (kcfb(maxncfb)) if (allocated(kcfa)) deallocate (kcfa) allocate (kcfa(maxncfa)) c c allocate pisystem orbital forcefield parameters c if (allocated(sslope)) deallocate (sslope) allocate (sslope(maxnpi)) if (allocated(sslope5)) deallocate (sslope5) allocate (sslope5(maxnpi5)) if (allocated(sslope4)) deallocate (sslope4) allocate (sslope4(maxnpi4)) if (allocated(tslope)) deallocate (tslope) allocate (tslope(maxnpi)) if (allocated(tslope5)) deallocate (tslope5) allocate (tslope5(maxnpi5)) if (allocated(tslope4)) deallocate (tslope4) allocate (tslope4(maxnpi4)) if (allocated(kpi)) deallocate (kpi) allocate (kpi(maxnpi)) if (allocated(kpi5)) deallocate (kpi5) allocate (kpi5(maxnpi5)) if (allocated(kpi4)) deallocate (kpi4) allocate (kpi4(maxnpi4)) return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine shakeup -- setup of holonomic constraints ## c ## ## c ############################################################## c c c "shakeup" initializes any holonomic constraints for use with c the SHAKE and RATTLE algorithms c c subroutine shakeup use angbnd use atmlst use atomid use atoms use bndstr use bound use couple use freeze use keys use math use molcul use usage implicit none integer i,j,k,m,nh integer ia,ib,ic integer ja,jb,jc integer ilist,next real*8 rab,rbc,rac real*8 cosine logical done character*9 rattyp character*20 keyword character*240 record character*240 string c c c set defaults for constraints and convergence tolerance c nrat = 0 nratx = 0 rateps = 0.000001d0 use_rattle = .true. c c perform dynamic allocation of some global arrays c if (.not. allocated(iratx)) then allocate (iratx(maxatm)) allocate (kratx(maxatm)) allocate (irat(2,maxatm)) allocate (krat(maxatm)) allocate (ratimage(maxatm)) end if c c process keywords containing holonomic constraint options c do k = 1, nkey next = 1 record = keyline(k) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:11) .eq. 'RATTLE-EPS ') then read (string,*,err=10,end=10) rateps end if 10 continue end do c c process keywords containing various constraint types c do k = 1, nkey next = 1 record = keyline(k) call upcase (record) call gettext (record,keyword,next) if (keyword(1:7) .eq. 'RATTLE ') then call getword (record,rattyp,next) c c constrain all bond lengths at their ideal values c if (rattyp(1:5) .eq. 'BONDS') then do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (use(ia) .or. use(ib)) then nrat = nrat + 1 irat(1,nrat) = ia irat(2,nrat) = ib krat(nrat) = bl(i) end if end do c c constrain bonds and independent angles at ideal values c else if (rattyp(1:6) .eq. 'ANGLES') then do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (use(ia) .or. use(ib)) then nrat = nrat + 1 irat(1,nrat) = ia irat(2,nrat) = ib krat(nrat) = bl(i) end if end do do i = 1, n if (n12(i) .gt. 1) then do j = 1, 2*n12(i)-3 ilist = anglist(j,i) ia = iang(1,ilist) ib = iang(2,ilist) ic = iang(3,ilist) if (use(ia) .or. use(ib) .or. use(ic)) then do m = 1, n12(ib) if (i12(m,ib) .eq. ia) then rab = bl(bndlist(m,ib)) else if (i12(m,ib) .eq. ic) then rbc = bl(bndlist(m,ib)) end if end do cosine = cos(anat(ilist)/radian) rac = sqrt(rab*rab+rbc*rbc & -2.0d0*rab*rbc*cosine) nrat = nrat + 1 irat(1,nrat) = ia irat(2,nrat) = ic krat(nrat) = rac call chkangle (ia,ib,ic) end if end do end if end do c c fix bond length in diatomics to give a rigid molecule c else if (rattyp(1:8) .eq. 'DIATOMIC') then do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (n12(ia).eq.1 .and. n12(ib).eq.1) then if (use(ia) .or. use(ib)) then nrat = nrat + 1 irat(1,nrat) = ia irat(2,nrat) = ib krat(nrat) = bl(i) end if end if end do c c fix bonds and angle in triatomics to give a rigid molecule c else if (rattyp(1:9) .eq. 'TRIATOMIC') then do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) if (n12(ia)+n12(ib)+n12(ic) .eq. 4) then rab = bl(bndlist(1,ia)) rbc = bl(bndlist(1,ic)) cosine = cos(anat(i)/radian) rac = sqrt(rab**2+rbc**2-2.0d0*rab*rbc*cosine) if (use(ia) .or. use(ib)) then nrat = nrat + 1 irat(1,nrat) = ia irat(2,nrat) = ib krat(nrat) = rab end if if (use(ib) .or. use(ic)) then nrat = nrat + 1 irat(1,nrat) = ib irat(2,nrat) = ic krat(nrat) = rbc end if if (use(ia) .or. use(ib) .or. use(ic)) then nrat = nrat + 1 irat(1,nrat) = ia irat(2,nrat) = ic krat(nrat) = rac end if end if end do c c fix bonds and angles of each water to give a rigid molecule c else if (rattyp(1:5) .eq. 'WATER') then do i = 1, n nh = 0 if (atomic(i) .eq. 8) then do j = 1, n12(i) if (atomic(i12(j,i)) .eq. 1) nh = nh + 1 end do end if if (nh .ge. 2) then do j = 1, n12(i) ilist = bndlist(j,i) ia = ibnd(1,ilist) ib = ibnd(2,ilist) ja = atomic(ia) jb = atomic(ib) if (use(ia) .or. use(ib)) then if (ja.eq.1 .or. jb.eq.1) then nrat = nrat + 1 irat(1,nrat) = ia irat(2,nrat) = ib krat(nrat) = bl(ilist) end if end if end do do j = 1, 2*n12(i)-3 ilist = anglist(j,i) ia = iang(1,ilist) ib = iang(2,ilist) ic = iang(3,ilist) ja = atomic(ia) jc = atomic(ic) if (use(ia) .or. use(ib) .or. use(ic)) then if (ja.eq.1 .and. jc.eq.1) then do m = 1, n12(ib) if (i12(m,ib) .eq. ia) then rab = bl(bndlist(m,ib)) else if (i12(m,ib) .eq. ic) then rbc = bl(bndlist(m,ib)) end if end do cosine = cos(anat(ilist)/radian) rac = sqrt(rab*rab+rbc*rbc & -2.0d0*rab*rbc*cosine) nrat = nrat + 1 irat(1,nrat) = ia irat(2,nrat) = ic krat(nrat) = rac call chkangle (ia,ib,ic) end if end if end do end if end do c c fix all bonds to hydrogen atoms at their ideal length c else do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) if (atomic(ia).eq.1 .or. atomic(ib).eq.1) then if (use(ia) .or. use(ib)) then nrat = nrat + 1 irat(1,nrat) = ia irat(2,nrat) = ib krat(nrat) = bl(i) end if end if end do end if end if end do c c process keywords containing specific distance constraints c do k = 1, nkey next = 1 record = keyline(k) call gettext (record,keyword,next) call upcase (keyword) if (keyword(1:16) .eq. 'RATTLE-DISTANCE ') then call getnumb (record,ia,next) call getnumb (record,ib,next) rab = 0.0d0 string = record(next:240) read (string,*,err=20,end=20) rab 20 continue if (rab .eq. 0.0d0) then do i = 1, n12(ia) if (i12(i,ia) .eq. ib) then rab = bl(bndlist(i,ia)) end if end do end if if (rab .eq. 0.0d0) then rab = sqrt((x(ia)-x(ib))**2 + (y(ia)-y(ib))**2 & + (z(ia)-z(ib))**2) end if done = .false. do j = 1, nrat ja = irat(1,j) jb = irat(2,j) if ((ia.eq.ja .and. ib.eq.jb) .or. & (ia.eq.jb .and. ib.eq.ja)) then done = .true. krat(j) = rab end if end do if (.not. done) then nrat = nrat + 1 irat(1,nrat) = ia irat(2,nrat) = ib krat(nrat) = rab end if c c process keywords containing atom group spatial constraints c else if (keyword(1:13) .eq. 'RATTLE-PLANE ') then call getnumb (record,ia,next) nratx = nratx + 1 iratx(nratx) = ia kratx(nratx) = 1 else if (keyword(1:12) .eq. 'RATTLE-LINE ') then call getnumb (record,ia,next) nratx = nratx + 1 iratx(nratx) = ia kratx(nratx) = 2 else if (keyword(1:14) .eq. 'RATTLE-ORIGIN ') then call getnumb (record,ia,next) nratx = nratx + 1 iratx(nratx) = ia kratx(nratx) = 3 end if end do c c find and remove any duplicate distance constraints c do i = 1, nrat-1 ia = irat(1,i) ib = irat(2,i) do j = i+1, nrat ja = irat(1,j) jb = irat(2,j) if ((ia.eq.ja .and. ib.eq.jb) .or. & (ia.eq.jb .and. ib.eq.ja)) krat(j) = -1.0d0 end do end do k = nrat do i = k, 1, -1 if (krat(i) .lt. 0.0d0) then do j = i, k-1 irat(1,j) = irat(1,j+1) irat(2,j) = irat(2,j+1) krat(j) = krat(j+1) end do nrat = nrat - 1 end if end do c c set flag to apply minimum image to intermolecular constraints c do i = 1, nrat ia = irat(1,i) ib = irat(2,i) if (use_bounds .and. (molcule(ia).ne.molcule(ib))) then ratimage(i) = .true. else if (use_polymer) then ratimage(i) = .true. else ratimage(i) = .false. end if end do c c if no holonomic constraints are present, turn off their use c if (nrat.eq.0 .and. nratx.eq.0) use_rattle = .false. return end c c c ################################################################ c ## ## c ## subroutine chkangle -- eliminate redundant constraints ## c ## ## c ################################################################ c c c "chkangle" tests angles to be constrained for their presence c in small rings and removes constraints that are redundant c c note this version correctly handles isolated small rings, c but should remove one additional redundant constraint for c each ring fusion c c subroutine chkangle (ia,ib,ic) use couple use freeze use ring implicit none integer i,j,k integer ia,ib,ic integer id,ie,imin logical remove c c c all internal angles of 3-membered rings are redundant c remove = .false. if (nring3 .ne. 0) then do i = 1, n12(ia) j = i12(i,ia) if (j .eq. ic) remove = .true. end do end if c c for 4-membered rings, two internal angles are redundant c if (nring4 .ne. 0) then do i = 1, n12(ia) id = i12(i,ia) if (id .ne. ib) then do j = 1, n12(id) k = i12(j,id) if (k .eq. ic) then imin = min(ia,ib,ic,id) if (ib .eq. imin) remove = .true. if (id .eq. imin) remove = .true. end if end do end if end do end if c c for 5-membered rings, one internal angle is redundant c if (nring5 .ne. 0) then do i = 1, n12(ia) id = i12(i,ia) if (id.ne.ib .and. id.ne.ic) then do j = 1, n12(ic) ie = i12(j,ic) if (ie.ne.ib .and. ie.ne.ia) then do k = 1, n12(id) if (i12(k,id) .eq. ie) then imin = min(ia,ib,ic,id,ie) if (ib .eq. imin) remove = .true. end if end do end if end do end if end do end if c c remove the constraint from the list if it is redundant c if (remove) nrat = nrat - 1 return end c c c ################################################### c ## COPYRIGHT (C) 2023 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module shapes -- UnionBall area and volume variables ## c ## ## c ############################################################## c c c maxedge maximum number of edges between ball centers c maxtetra maximum number of tetrahedra in the system c npoint total number of balls (points) in the system c nvertex total number of vertices in the system c ntetra total number of tetrahedra in the system c nnew total number of entries on new tetrahedra list c nfree total number of spaces on free tetrahedra list c nkill total number of tetrahedra on list to kill c nlinkfacet total number of triangle facets in the system c newlist list with index numbers of the new tetrahedra c freespace list of the tetrahedra currently in free space c killspace list of the existing tetrahedra to be killed c vinfo information value for each of the vertices c tedge number of an edge found in each tetrahedron c tinfo orientation information for each tetrahedron c tnindex index related to tetrahedron orientation c tetra numbers of the four balls in each tetrahedron c tneighbor store the four neighbors of each tetrahedron c linkfacet numbers of two tetrahedra defining each facet c linkindex vertex numbers opposite each facet triangle c epsln2 minimal value of determinant over two balls c epsln3 minimal value of determinant over three balls c epsln4 minimal value of determinant over four balls c epsln5 minimal value of determinant over five balls c crdball coordinates in Angstroms of balls as 1-D array c radball radius value for each ball in Angstroms c wghtball weight value assigned for each ball c c module shapes integer maxedge integer maxtetra integer npoint,nvertex integer ntetra,nnew integer nfree,nkill integer nlinkfacet integer, allocatable :: newlist(:) integer, allocatable :: freespace(:) integer, allocatable :: killspace(:) integer, allocatable :: vinfo(:) integer, allocatable :: tedge(:) integer, allocatable :: tinfo(:) integer, allocatable :: tnindex(:) integer, allocatable :: tetra(:,:) integer, allocatable :: tneighbor(:,:) integer, allocatable :: linkfacet(:,:) integer, allocatable :: linkindex(:,:) real*8 epsln2,epsln3 real*8 epsln4,epsln5 real*8, allocatable :: crdball(:) real*8, allocatable :: radball(:) real*8, allocatable :: wghtball(:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module shunt -- polynomial switching function values ## c ## ## c ############################################################## c c c off distance at which the potential energy goes to zero c off2 square of distance at which the potential goes to zero c cut distance at which switching of the potential begins c cut2 square of distance at which the switching begins c c0 zeroth order coefficient of multiplicative switch c c1 first order coefficient of multiplicative switch c c2 second order coefficient of multiplicative switch c c3 third order coefficient of multiplicative switch c c4 fourth order coefficient of multiplicative switch c c5 fifth order coefficient of multiplicative switch c f0 zeroth order coefficient of additive switch function c f1 first order coefficient of additive switch function c f2 second order coefficient of additive switch function c f3 third order coefficient of additive switch function c f4 fourth order coefficient of additive switch function c f5 fifth order coefficient of additive switch function c f6 sixth order coefficient of additive switch function c f7 seventh order coefficient of additive switch function c c module shunt implicit none real*8 off,off2 real*8 cut,cut2 real*8 c0,c1,c2 real*8 c3,c4,c5 real*8 f0,f1,f2,f3 real*8 f4,f5,f6,f7 save end c c c ################################################### c ## COPYRIGHT (C) 1997 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## function sigmoid -- general sigmoidal functional form ## c ## ## c ############################################################### c c c "sigmoid" implements a normalized sigmoidal function on the c interval [0,1]; the curves connect (0,0) to (1,1) and have c a cooperativity controlled by beta, they approach a straight c line as beta -> 0 and get more nonlinear as beta increases c c function sigmoid (beta,x) implicit none real*8 beta,x real*8 sigmoid real*8 expmax real*8 expmin real*8 expterm c c c compute the value of the normalized sigmoidal function c if (beta .eq. 0.0d0) then sigmoid = x else expmax = 1.0d0 / (exp(-beta) + 1.0d0) expmin = 1.0d0 / (exp(beta) + 1.0d0) expterm = 1.0d0 / (exp(beta*(2.0d0*x-1.0d0)) + 1.0d0) sigmoid = (expmax - expterm) / (expmax - expmin) end if return end c c c ################################################### c ## COPYRIGHT (C) 2020 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine simplex -- Nelder-Mead simplex optimization ## c ## ## c ################################################################ c c c "simplex" is a general multidimensional Nelder-Mead simplex c optimization routine requiring only repeated evaluations of c the objective function c c literature reference: c c R. O'Neill, "Algorithm AS 47: Function Minimization Using a c Simplex Procedure", Applied Statistics, 20, 338-345 (1971) c c subroutine simplex (nvar,iter,ntest,x0,y0,step,toler,fvalue) use inform use iounit use keys use minima implicit none real*8 ccoeff,ecoeff real*8 rcoeff,eps parameter (ccoeff=0.5d0) parameter (ecoeff=2.0d0) parameter (rcoeff=1.0d0) parameter (eps=0.001d0) integer i,j,k,nvar integer iter,next integer ihi,ilo integer ntest,jtest real*8 toler,tol real*8 fvalue,step real*8 x,z,del real*8 y0,ylo real*8 ystar,y2star real*8 x0(*) real*8, allocatable :: xmin(:) real*8, allocatable :: pbar(:) real*8, allocatable :: pstar(:) real*8, allocatable :: p2star(:) real*8, allocatable :: y(:) real*8, allocatable :: p(:,:) logical done character*20 keyword character*240 record character*240 string external fvalue c c c set default parameters for the optimization c if (maxiter .eq. 0) maxiter = 1000000 if (iprint .lt. 0) iprint = 1000 if (iwrite .lt. 0) iwrite = 1000 c c search the keywords for optimization parameters c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:8) .eq. 'MAXITER ') then read (string,*,err=10,end=10) maxiter end if 10 continue end do c c initialization of various counters and variables c done = .false. iter = 0 jtest = ntest del = 1.0d0 tol = toler * dble(nvar) c c print header information about the optimization method c if (iprint .gt. 0) then write (iout,20) 20 format (/,' Nelder-Mead Simplex Optimization :') write (iout,30) 30 format (/,' NM Iter F Value G RMS F Move', & ' X Move Comment') flush (iout) end if c c perform dynamic allocation of some local arrays c allocate (xmin(nvar)) allocate (pbar(nvar)) allocate (pstar(nvar)) allocate (p2star(nvar)) allocate (y(nvar+1)) allocate (p(nvar,nvar+1)) c c initialize or restart with the base function value c do while (.not. done) do i = 1, nvar p(i,nvar+1) = x0(i) end do y(nvar+1) = fvalue (x0) iter = iter + 1 c c define the initial simplex as an "nvar+1" polytope c do j = 1, nvar x = x0(j) x0(j) = x0(j) + step*del do i = 1, nvar p(i,j) = x0(i) end do y(j) = fvalue (x0) iter = iter + 1 x0(j) = x end do c c find highest and lowest values; highest will be replaced c ilo = nvar + 1 ylo = y(ilo) do i = 1, nvar if (y(i) .le. ylo) then ilo = i ylo = y(ilo) end if end do c c set "y0" to be the current highest function value c do while (iter .lt. maxiter) ihi = nvar + 1 y0 = y(ihi) do i = 1, nvar if (y(i) .ge. y0) then ihi = i y0 = y(ihi) end if end do c c calculate "pbar", the centroid of the simplex vertices c excepting the vertex with the highest function value c do i = 1, nvar pbar(i) = 0.0d0 do j = 1, nvar+1 pbar(i) = pbar(i) + p(i,j) end do pbar(i) = (pbar(i)-p(i,ihi)) / dble(nvar) end do c c reflection through the centroid of the vertices c do i = 1, nvar pstar(i) = pbar(i) + rcoeff*(pbar(i)-p(i,ihi)) end do ystar = fvalue (pstar) iter = iter + 1 c c successful reflection, so try simplex extension c if (ystar .lt. ylo) then do i = 1, nvar p2star(i) = pbar(i) + ecoeff*(pstar(i)-pbar(i)) end do y2star = fvalue (p2star) iter = iter + 1 c c retain extension or contraction of the simplex c if (ystar .lt. y2star) then do i = 1, nvar p(i,ihi) = pstar(i) end do y(ihi) = ystar else do i = 1, nvar p(i,ihi) = p2star(i) end do y(ihi) = y2star end if c c no extension of the simplex will be used c else k = 0 do i = 1, nvar+1 if (ystar .lt. y(i)) then k = k + 1 end if end do if (1 .lt. k) then do i = 1, nvar p(i,ihi) = pstar(i) end do y(ihi) = ystar c c contraction on the "ihi" side of the centroid c else if (k .eq. 0) then do i = 1, nvar p2star(i) = pbar(i) + ccoeff*(p(i,ihi)-pbar(i)) end do y2star = fvalue (p2star) iter = iter + 1 c c perform contraction of the whole simplex c if (y(ihi) .lt. y2star) then do j = 1, nvar+1 do i = 1, nvar p(i,j) = 0.5d0 * (p(i,j)+p(i,ilo)) end do do i = 1, nvar xmin(i) = p(i,j) end do y(j) = fvalue (xmin) iter = iter + 1 end do ilo = nvar + 1 ylo = y(ilo) do i = 1, nvar if (y(i) .le. ylo) then ilo = i ylo = y(ilo) end if end do goto 40 c c retain the contraction of the simplex c else do i = 1, nvar p(i,ihi) = p2star(i) end do y(ihi) = y2star end if c c contraction on the reflection side of the centroid c else if (k .eq. 1) then do i = 1, nvar p2star(i) = pbar(i) + ccoeff*(pstar(i)-pbar(i)) end do y2star = fvalue (p2star) iter = iter + 1 c c check whether to retain reflection of the simplex c if (y2star .le. ystar) then do i = 1, nvar p(i,ihi) = p2star(i) end do y(ihi) = y2star else do i = 1, nvar p(i,ihi) = pstar(i) end do y(ihi) = ystar end if end if end if c c check to see if the "ylo" value has improved c if (y(ihi) .lt. ylo) then ylo = y(ihi) ilo = ihi end if c c check to see if the desired minimum has been reached c jtest = jtest -1 if (jtest .eq. 0) then if (iter .le. maxiter) then jtest = ntest x = 0.0d0 do i = 1, nvar+1 x = x + y(i) end do x = x / dble(nvar+1) z = 0.0d0 do i = 1, nvar+1 z = z + (y(i)-x)**2 end do if (z .le. tol) then goto 50 end if end if end if 40 continue end do 50 continue c c factorial tests to check if "y0" is a local minimum c do i = 1, nvar xmin(i) = p(i,ilo) end do y0 = y(ilo) done = .true. if (iter .ge. maxiter) then write (iout,60) 60 format (/,' SIMPLEX -- Maximum Number of Iterations', & ' Exceeded') else do i = 1, nvar del = step * eps xmin(i) = xmin(i) + del z = fvalue (xmin) iter = iter + 1 if (z .lt. y0) then done = .false. goto 70 end if xmin(i) = xmin(i) - del - del z = fvalue (xmin) iter = iter + 1 if (z .lt. y0) then done = .false. goto 70 end if xmin(i) = xmin(i) + del end do end if 70 continue c c set return to current minimum, restart if warranted c do i = 1, nvar x0(i) = xmin(i) end do del = eps end do c c perform deallocation of some local arrays c deallocate (xmin) deallocate (pbar) deallocate (pstar) deallocate (p2star) deallocate (y) deallocate (p) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## module sizes -- parameters to set array dimensions ## c ## ## c ############################################################ c c c "sizes" sets values for array dimensions used throughout c the software; these parameters fix the size of the largest c systems that can be handled c c parameter: maximum allowed number of: c c maxatm atoms in the molecular system c maxtyp force field atom type definitions c maxclass force field atom class definitions c maxval atoms directly bonded to an atom c maxref stored reference molecular systems c maxgrp user-defined groups of atoms c maxres residues in all macromolecules c maxbio biopolymer atom type definitions c c module sizes implicit none integer maxatm,maxtyp integer maxclass,maxval integer maxref,maxgrp integer maxres,maxbio parameter (maxatm=1000000) parameter (maxtyp=5000) parameter (maxclass=1000) parameter (maxval=8) parameter (maxref=30) parameter (maxgrp=1000) parameter (maxres=10000) parameter (maxbio=10000) save end c c c ################################################################ c ## COPYRIGHT (C) 2002 by Michael Schnieders & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ############################################################## c ## ## c ## subroutine sktdyn -- send the current dynamics info ## c ## ## c ############################################################## c c c "sktdyn" sends the current dynamics info via a socket c c subroutine sktdyn (istep,dt,epot) use atoms use moldyn use mpole use polar use potent use socket implicit none integer i,k,istep integer flag real*8 dt,time,epot real*8, allocatable :: vx(:) real*8, allocatable :: vy(:) real*8, allocatable :: vz(:) real*8, allocatable :: ax(:) real*8, allocatable :: ay(:) real*8, allocatable :: az(:) real*8, allocatable :: px(:) real*8, allocatable :: py(:) real*8, allocatable :: pz(:) c c c check to see if the server has been created c skttyp = 1 if (.not. sktstart) call sktinit () if (.not. use_socket) return c c save the current step number, time and energy c cstep = istep cdt = dt cenergy = epot c c check to see if we need to update the system info c flag = 1 if (.not. sktstop) call needupdate (flag) if (flag .eq. 0) return c c get the monitor for the update structure c call getmonitor () c c load the coordinates, time and energy information c call setcoordinates (n,x,y,z) time = dble(istep) * dt call setmdtime (time) call setenergy (epot) c c perform dynamic allocation of some local arrays c allocate (vx(n)) allocate (vy(n)) allocate (vz(n)) allocate (ax(n)) allocate (ay(n)) allocate (az(n)) allocate (px(n)) allocate (py(n)) allocate (pz(n)) c c load the velocity and acceleration information c do i = 1, n vx(i) = v(1,i) vy(i) = v(2,i) vz(i) = v(3,i) ax(i) = a(1,i) ay(i) = a(2,i) az(i) = a(3,i) px(i) = 0.0d0 py(i) = 0.0d0 pz(i) = 0.0d0 end do call setvelocity (n,vx,vy,vz) call setacceleration (n,ax,ay,az) if (use_polar) then do i = 1, npole k = ipole(i) px(k) = uind(1,k) py(k) = uind(2,k) pz(k) = uind(3,k) end do call setinduced (n,px,py,pz) end if c c perform deallocation of some local arrays c deallocate (vx) deallocate (vy) deallocate (vz) deallocate (ax) deallocate (ay) deallocate (az) deallocate (px) deallocate (py) deallocate (pz) c c release the monitor for the update stucture c call setupdated () call releasemonitor () return end c c c ############################################################# c ## ## c ## subroutine sktopt -- send current optimization info ## c ## ## c ############################################################# c c c "sktopt" sends the current optimization info via a socket c c subroutine sktopt (ncycle,eopt) use atoms use deriv use mpole use polar use potent use socket implicit none integer i,k,ncycle integer flag real*8 eopt real*8, allocatable :: gx(:) real*8, allocatable :: gy(:) real*8, allocatable :: gz(:) real*8, allocatable :: px(:) real*8, allocatable :: py(:) real*8, allocatable :: pz(:) c c c check to see if the server has been created c skttyp = 2 if (.not. sktstart) call sktinit () if (.not. use_socket) return c c save the current step number and energy c cstep = ncycle cenergy = eopt c c check to see if an update is needed c flag = 1 if (.not. sktstop) call needupdate (flag) if (flag .eq. 0) return c c get the monitor for the update structure c call getmonitor () c c load the coordinates and energy information c call setcoordinates (n,x,y,z) call setstep (ncycle) call setenergy (eopt) c c perform dynamic allocation of some local arrays c allocate (gx(n)) allocate (gy(n)) allocate (gz(n)) allocate (px(n)) allocate (py(n)) allocate (pz(n)) c c load the gradient and induced dipole information c do i = 1, n gx(i) = desum(1,i) gy(i) = desum(2,i) gz(i) = desum(3,i) px(i) = 0.0d0 py(i) = 0.0d0 pz(i) = 0.0d0 end do call setgradients (n,gx,gy,gz) if (use_polar) then do i = 1, npole k = ipole(i) px(k) = uind(1,k) py(k) = uind(2,k) pz(k) = uind(3,k) end do call setinduced (n,px,py,pz) end if c c perform deallocation of some local arrays c deallocate (gx) deallocate (gy) deallocate (gz) deallocate (px) deallocate (py) deallocate (pz) c c release the monitor for the system stucture c call setupdated () call releasemonitor () return end c c c ############################################################### c ## ## c ## subroutine sktinit -- initialize socket communication ## c ## ## c ############################################################### c c c "sktinit" sets up socket communication with the graphical c user interface by starting a Java virtual machine, initiating c a server, and loading an object with system information c c subroutine sktinit use atomid use atoms use charge use couple use files use fields use iounit use inform use keys use polar use socket implicit none integer i integer flag integer, allocatable :: b1(:) integer, allocatable :: b2(:) integer, allocatable :: b3(:) integer, allocatable :: b4(:) c c c set initialization flag and test for socket usage c sktstart = .true. use_socket = .true. call chksocket (flag) if (flag .eq. 0) then use_socket = .false. return end if c c create the Java Virtual Machine c call createjvm (flag) if (flag .eq. 0) then use_socket = .false. write (iout,10) 10 format (/,' SKTINIT -- Unable to Create the JVM Server', & /,' Check LD_LIBRARY_PATH and CLASSPATH Variables',/) return end if c c create the Tinker system object c call createsystem (n,nkey,flag) if (flag .eq. 0) then use_socket = .false. write (iout,20) 20 format (/,' SKTINIT -- Unable to Create Tinker System',/) return end if c c load the keyfile and coordinates information c call setfile (filename) call setforcefield (forcefield) do i = 1, nkey call setkeyword (i,keyline(i)) end do call setcoordinates (n,x,y,z) c c perform dynamic allocation of some local arrays c allocate (b1(n)) allocate (b2(n)) allocate (b3(n)) allocate (b4(n)) c c load the atom connectivity information c do i = 1, n b1(i) = i12(1,i) b2(i) = i12(2,i) b3(i) = i12(3,i) b4(i) = i12(4,i) end do call setconnectivity (n,b1,b2,b3,b4) c c perform deallocation of some local arrays c deallocate (b1) deallocate (b2) deallocate (b3) deallocate (b4) c c load atom type information for the parameter set c call setatomtypes (n,type) do i = 1, n call setname (i,name(i)) call setstory (i,story(i)) end do call setatomic (n,atomic) call setmass (n,mass) call setcharge (n,pchg) c c create the Tinker server c call createserver (flag) if (flag .eq. 0) then use_socket = .false. write (iout,30) 30 format (/,' SKTINIT -- Unable to Create Tinker Server',/) return end if c c create the update object c call createupdate (n,skttyp,npolar,flag) if (flag .eq. 0) then use_socket = .false. write (iout,40) 40 format (/,' SKTINIT -- Unable to Create Update Object',/) return end if return end c c c ########################################################### c ## ## c ## subroutine sktkill -- shutdown the server and JVM ## c ## ## c ########################################################### c c c "sktkill" closes the server and Java virtual machine c c subroutine sktkill use socket implicit none c c c check to see if there is anything to close c if (.not. use_socket) return sktstop = .true. c c load the final simulation results c if (skttyp .eq. 1) call sktdyn (cstep,cdt,cenergy) if (skttyp .eq. 2) call sktopt (cstep,cenergy) c c shutdown the Tinker server c call destroyserver () c c shutdown the Java virtual machine c c call destroyjvm () return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## program sniffer -- discrete generalized descent search ## c ## ## c ################################################################ c c c "sniffer" performs a global energy minimization using a c discrete version of Griewank's global search trajectory c c literature references: c c A. O. Griewank, "Generalized Descent for Global Optimization", c Journal of Optimization Theory and Applications, 34, 11-39 (1981) c c R. A. R. Butler and E. E. Slaminka, "An Evaluation of the Sniffer c Global Optimization Algorithm Using Standard Test Functions", c Journal of Computational Physics, 99, 28-32 (1992) c c J. W. Rogers, Jr. and R. A. Donnelly, "Potential Transformation c Methods for Large-Scale Global Optimization", SIAM Journal of c Optimization, 5, 871-891 (1995) c c program sniffer use atoms use files use inform use iounit use linmin use math use minima use output use scales use usage implicit none integer i,j,k,imin integer nvar,niter integer start,stop integer freeunit integer istep,maxstep real*8 sniffer1,gnorm real*8 grms,grdmin real*8 f,eps,mu real*8 scaler,angle real*8 rms,size real*8 fmin,gmin real*8 dnorm,dot real*8 alpha,cosine real*8 epsfac,mufac real*8 stepfac real*8 minimum real*8, allocatable :: xx(:) real*8, allocatable :: g(:) real*8, allocatable :: d(:) real*8, allocatable :: derivs(:,:) logical exist,done character*9 status character*240 minfile character*240 string c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic call makeref (1) c c get the number of steps in the initial block c maxstep = -1 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) maxstep 10 continue if (maxstep .le. 0) then write (iout,20) 20 format (/,' Enter Number of Steps in the Initial Set', & ' [100] : ',$) read (input,30) maxstep 30 format (i10) end if if (maxstep .le. 0) maxstep = 100 c c get the target value for the global energy minimum c fctmin = 1000000.0d0 call nextarg (string,exist) if (exist) read (string,*,err=40,end=40) fctmin 40 continue if (fctmin .ge. 1000000.0d0) then write (iout,50) 50 format (/,' Enter Target Energy for the Global Minimum', & ' [0.0] : ',$) read (input,60) fctmin 60 format (f20.0) end if if (fctmin .ge. 1000000.0d0) fctmin = 0.0d0 c c get termination criterion as RMS gradient per atom c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=70,end=70) grdmin 70 continue if (grdmin .le. 0.0d0) then write (iout,80) 80 format (/,' Enter RMS Gradient per Atom Criterion [1.0] : ',$) read (input,90) grdmin 90 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 coordtype = 'CARTESIAN' c c perform dynamic allocation of some global arrays c if (.not. allocated(scale)) allocate (scale(3*n)) c c set scaling parameter for function and derivative values; c use square root of median eigenvalue of a typical Hessian c set_scale = .true. scaler = 1.0d0 nvar = 0 do i = 1, nuse do j = 1, 3 nvar = nvar + 1 scale(nvar) = scaler end do end do c c perform dynamic allocation of some local arrays c allocate (xx(nvar)) allocate (g(nvar)) allocate (d(nvar)) allocate (derivs(3,n)) c c scale the coordinates of each active atom c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 xx(nvar) = x(k) * scale(nvar) nvar = nvar + 1 xx(nvar) = y(k) * scale(nvar) nvar = nvar + 1 xx(nvar) = z(k) * scale(nvar) end do c c set initial values for the control parameters c epsfac = 1.1d0 mufac = 1.7d0 stepfac = 1.1d0 c c set initial values for optimization parameters c iprint = 1 iwrite = 100 rms = sqrt(dble(n)) start = 0 stop = start + maxstep eps = 1.0d0 mu = 1.0d0 stpmax = 0.1d0 * rms stpmin = 0.001d0 c c initialize unit direction vector along negative gradient c f = sniffer1 (xx,g) gnorm = 0.0d0 do i = 1, nvar gnorm = gnorm + g(i)**2 end do gnorm = sqrt(gnorm) grms = gnorm / rms do i = 1, nvar d(i) = -g(i) / gnorm end do fmin = f gmin = grms c c tests of the successful termination criteria c if (fmin .le. fctmin) then status = 'TargetVal' done = .true. else if (gmin .le. grdmin) then status = 'SmallGrad' done = .true. else done = .false. end if c c print header information prior to iterations c if (iprint .gt. 0) then write (iout,100) 100 format (/,' Discrete Generalized Descent Global', & ' Optimization :') end if c c perform a set of basic sniffer search steps c niter = 0 do while (.not. done) write (iout,110) 110 format (/,4x,'Iter',11x,'F Value',13x,'G RMS', & 8x,'X Move',9x,'Angle',/) do istep = start, stop c c get the current energy and gradient values c f = sniffer1 (xx,g) c c if current energy is lowest yet, save the coordinates c if (f .lt. fmin) then nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 x(k) = xx(nvar) / scale(nvar) nvar = nvar + 1 y(k) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(k) = xx(nvar) / scale(nvar) end do call makeref (1) imin = freeunit () open (unit=imin,file=minfile,status='old') rewind (unit=imin) call prtxyz (imin) close (unit=imin) end if c c get rms gradient and dot product with search direction c gnorm = 0.0d0 dot = 0.0d0 do i = 1, nvar gnorm = gnorm + g(i)*g(i) dot = dot + d(i)*g(i) end do gnorm = sqrt(gnorm) grms = gnorm / (scaler*rms) c c compute the next direction vector and its length c alpha = max(0.0d0,1.0d0+(1.0d0+eps)*dot) dnorm = 0.0d0 do i = 1, nvar d(i) = -eps*g(i) + alpha*d(i) dnorm = dnorm + d(i)*d(i) end do dnorm = sqrt(dnorm) c c normalize direction and get angle with negative gradient c dot = 0.0d0 do i = 1, nvar d(i) = d(i) / dnorm dot = dot + d(i)*g(i) end do cosine = -dot / gnorm cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) c c move atomic positions along the direction vector c size = min(stpmax,mu*(f-fctmin)) do i = 1, nvar xx(i) = xx(i) + size*d(i) end do c c compute the size of the step taken c size = min(stpmax,mu*(f-fctmin)) size = size / rms c c update the best value and gradient found so far c fmin = min(fmin,f) gmin = min(gmin,grms) c c print intermediate results every few iterations c if (iprint .gt. 0) then if (done .or. mod(niter,iprint).eq.0) then if (f.lt.1.0d12 .and. f.gt.-1.0d11 & .and. grms.lt.1.0d12) then write (iout,120) istep,f,grms,size,angle 120 format (i8,2f18.4,2f14.4) else write (iout,130) istep,f,grms,size,angle 130 format (i8,2d18.4,2f14.4) end if end if end if end do c c tests of the various termination and error criteria c if (fmin .le. fctmin) then status = 'TargetVal' done = .true. else if (gmin .le. grdmin) then status = 'SmallGrad' done = .true. else if (size .le. stpmin) then status = 'SmallMove' done = .true. end if c c write the final coordinates for this set of steps c niter = niter + 1 if (cyclesave) call optsave (niter,fmin,xx) c c update the optimization parameters for the next set c eps = eps * epsfac mu = mu / mufac maxstep = nint(dble(maxstep)*stepfac) start = stop + 1 stop = start + maxstep end do c c write message about satisfaction of termination criteria c if (status .eq. 'SmallMove') then write (iout,140) status 140 format (/,' SNIFFER -- Incomplete Convergence due to ',a9) else write (iout,150) status 150 format (/,' SNIFFER -- Normal Termination due to ',a9) end if c c use lowest energy structure as global minimum estimate c call getref (1) c c compute the final function and RMS gradient values c call gradient (minimum,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 / rms c c perform deallocation of some local arrays c deallocate (xx) deallocate (g) deallocate (d) deallocate (derivs) c c write out the final function and gradient values c if (grms .gt. 0.0001d0) then write (iout,160) minimum,grms,gnorm 160 format (/,' Final Function Value :',f15.4, & /,' Final RMS Gradient : ',f15.4, & /,' Final Gradient Norm : ',f15.4) else write (iout,170) minimum,grms,gnorm 170 format (/,' Final Function Value :',f15.4, & /,' Final RMS Gradient : ',d15.4, & /,' Final Gradient Norm : ',d15.4) 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 ## function sniffer1 -- energy and gradient for sniffer ## c ## ## c ############################################################## c c c "sniffer1" is a service routine that computes the energy c and gradient for the Sniffer global optimization method c c function sniffer1 (xx,g) use atoms use scales use usage implicit none integer i,k,nvar real*8 sniffer1,e real*8 xx(*) real*8 g(*) 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) / scale(nvar) nvar = nvar + 1 y(k) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(k) = xx(nvar) / scale(nvar) end do c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute and store the energy and gradient c call gradient (e,derivs) sniffer1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, nuse k = iuse(i) nvar = nvar + 1 g(nvar) = derivs(1,k) / scale(nvar) nvar = nvar + 1 g(nvar) = derivs(2,k) / scale(nvar) nvar = nvar + 1 g(nvar) = derivs(3,k) / scale(nvar) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ################################################### c ## COPYRIGHT (C) 2002 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module socket -- socket communication control parameters ## c ## ## c ################################################################## c c c skttyp socket information type (1=DYN, 2=OPT) c cstep current dynamics or optimization step number c cdt current dynamics cumulative simulation time c cenergy current potential energy from simulation c sktstart logical flag to indicate socket initialization c sktstop logical flag to indicate socket shutdown c use_socket logical flag governing use of external sockets c c module socket implicit none integer skttyp integer cstep real*8 cdt real*8 cenergy logical sktstart logical sktstop logical use_socket save end c c c ################################################### c ## COPYRIGHT (C) 2020 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## module solpot -- solvation term functional form details ## c ## ## c ################################################################# c c c solvtyp type of continuum solvation energy model in use c borntyp method to be used for the Born radius computation c c module solpot implicit none character*8 solvtyp character*8 borntyp save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module solute -- continuum solvation model parameters ## c ## ## c ############################################################### c c c maxneck maximum number of neck correction atom radius bins c c doffset dielectric offset to continuum solvation atomic radii c onipr probe radius to use with onion Born radius method c p1 single-atom scale factor for analytical Still radii c p2 1-2 interaction scale factor for analytical Still radii c p3 1-3 interaction scale factor for analytical Still radii c p4 nonbonded scale factor for analytical Still radii c p5 soft cutoff parameter for analytical Still radii c descoff offset for pairwise descreening at small separation c rneck atom radius bins used to store Aij/Bij neck constants c aneck constants to use in calculating neck values c bneck constants to use in calculating neck values c rsolv atomic radius of each atom for continuum solvation c rdescr atomic radius of each atom for descreening c asolv atomic surface area solvation weight parameters c rborn Born radius of each atom for GB/SA solvation c drb solvation derivatives with respect to Born radii c drbp GK polarization derivatives with respect to Born radii c drobc chain rule term for Onufriev-Bashford-Case radii c gpol polarization self-energy values for each atom c shct Hawkins-Cramer-Truhlar radius overlap scale factors c aobc alpha values for Onufriev-Bashford-Case radii c bobc beta values for Onufriev-Bashford-Case radii c gobc gamma values for Onufriev-Bashford-Case radii c vsolv atomic volume of each atom for use with ACE c wace "omega" values for atom class pairs for use with ACE c s2ace "sigma^2" values for atom class pairs for use with ACE c uace "mu" values for atom class pairs for use with ACE c sneck pairwise neck correction scale factor for each atom c bornint unscaled 1/r^6 corrections for tanh chain rule term c useneck logical flag to use neck interstitial space correction c usetanh logical flag to use tanh interstitial space correction c c c module solute implicit none integer maxneck parameter (maxneck=45) real*8 doffset,onipr real*8 p1,p2,p3,p4,p5 real*8 descoff real*8 rneck(maxneck) real*8 aneck(maxneck,maxneck) real*8 bneck(maxneck,maxneck) real*8, allocatable :: rsolv(:) real*8, allocatable :: rdescr(:) real*8, allocatable :: asolv(:) real*8, allocatable :: rborn(:) real*8, allocatable :: drb(:) real*8, allocatable :: drbp(:) real*8, allocatable :: drobc(:) real*8, allocatable :: gpol(:) real*8, allocatable :: shct(:) real*8, allocatable :: aobc(:) real*8, allocatable :: bobc(:) real*8, allocatable :: gobc(:) real*8, allocatable :: vsolv(:) real*8, allocatable :: wace(:,:) real*8, allocatable :: s2ace(:,:) real*8, allocatable :: uace(:,:) real*8, allocatable :: sneck(:) real*8, allocatable :: bornint(:) logical useneck logical usetanh save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ######################################################### c ## ## c ## subroutine sort -- heapsort of an integer array ## c ## ## c ######################################################### c c c "sort" takes an input list of integers and sorts it c into ascending order using the Heapsort algorithm c c subroutine sort (n,list) implicit none integer i,j,k,n integer index,lists integer list(*) c c c perform the heapsort of the input list c k = n/2 + 1 index = n do while (n .gt. 1) if (k .gt. 1) then k = k - 1 lists = list(k) else lists = list(index) list(index) = list(1) index = index - 1 if (index .le. 1) then list(1) = lists return end if end if i = k j = k + k do while (j .le. index) if (j .lt. index) then if (list(j) .lt. list(j+1)) j = j + 1 end if if (lists .lt. list(j)) then list(i) = list(j) i = j j = j + j else j = index + 1 end if end do list(i) = lists end do return end c c c ############################################################## c ## ## c ## subroutine sort2 -- heapsort of real array with keys ## c ## ## c ############################################################## c c c "sort2" takes an input list of reals and sorts it c into ascending order using the Heapsort algorithm; c it also returns a key into the original ordering c c subroutine sort2 (n,list,key) implicit none integer i,j,k,n integer index,keys integer key(*) real*8 lists real*8 list(*) c c c initialize index into the original ordering c do i = 1, n key(i) = i end do c c perform the heapsort of the input list c k = n/2 + 1 index = n do while (n .gt. 1) if (k .gt. 1) then k = k - 1 lists = list(k) keys = key(k) else lists = list(index) keys = key(index) list(index) = list(1) key(index) = key(1) index = index - 1 if (index .le. 1) then list(1) = lists key(1) = keys return end if end if i = k j = k + k do while (j .le. index) if (j .lt. index) then if (list(j) .lt. list(j+1)) j = j + 1 end if if (lists .lt. list(j)) then list(i) = list(j) key(i) = key(j) i = j j = j + j else j = index + 1 end if end do list(i) = lists key(i) = keys end do return end c c c ################################################################# c ## ## c ## subroutine sort3 -- heapsort of integer array with keys ## c ## ## c ################################################################# c c c "sort3" takes an input list of integers and sorts it c into ascending order using the Heapsort algorithm; c it also returns a key into the original ordering c c subroutine sort3 (n,list,key) implicit none integer i,j,k,n integer index integer lists integer keys integer list(*) integer key(*) c c c initialize index into the original ordering c do i = 1, n key(i) = i end do c c perform the heapsort of the input list c k = n/2 + 1 index = n do while (n .gt. 1) if (k .gt. 1) then k = k - 1 lists = list(k) keys = key(k) else lists = list(index) keys = key(index) list(index) = list(1) key(index) = key(1) index = index - 1 if (index .le. 1) then list(1) = lists key(1) = keys return end if end if i = k j = k + k do while (j .le. index) if (j .lt. index) then if (list(j) .lt. list(j+1)) j = j + 1 end if if (lists .lt. list(j)) then list(i) = list(j) key(i) = key(j) i = j j = j + j else j = index + 1 end if end do list(i) = lists key(i) = keys end do return end c c c ################################################################# c ## ## c ## subroutine sort4 -- heapsort of integer absolute values ## c ## ## c ################################################################# c c c "sort4" takes an input list of integers and sorts it into c ascending absolute value using the Heapsort algorithm c c subroutine sort4 (n,list) implicit none integer i,j,k,n integer index integer lists integer list(*) c c c perform the heapsort of the input list c k = n/2 + 1 index = n do while (n .gt. 1) if (k .gt. 1) then k = k - 1 lists = list(k) else lists = list(index) list(index) = list(1) index = index - 1 if (index .le. 1) then list(1) = lists return end if end if i = k j = k + k do while (j .le. index) if (j .lt. index) then if (abs(list(j)) .lt. abs(list(j+1))) j = j + 1 end if if (abs(lists) .lt. abs(list(j))) then list(i) = list(j) i = j j = j + j else j = index + 1 end if end do list(i) = lists end do return end c c c ################################################################ c ## ## c ## subroutine sort5 -- heapsort of integer array modulo m ## c ## ## c ################################################################ c c c "sort5" takes an input list of integers and sorts it c into ascending order based on each value modulo "m" c c subroutine sort5 (n,list,m) implicit none integer i,j,k,m,n integer index,smod integer jmod,j1mod integer lists integer list(*) c c c perform the heapsort of the input list c k = n/2 + 1 index = n do while (n .gt. 1) if (k .gt. 1) then k = k - 1 lists = list(k) else lists = list(index) list(index) = list(1) index = index - 1 if (index .le. 1) then list(1) = lists return end if end if i = k j = k + k do while (j .le. index) if (j .lt. index) then jmod = mod(list(j),m) j1mod = mod(list(j+1),m) if (jmod .lt. j1mod) then j = j + 1 else if (jmod.eq.j1mod .and. list(j).lt.list(j+1)) then j = j + 1 end if end if smod = mod(lists,m) jmod = mod(list(j),m) if (smod .lt. jmod) then list(i) = list(j) i = j j = j + j else if (smod.eq.jmod .and. lists.lt.list(j)) then list(i) = list(j) i = j j = j + j else j = index + 1 end if end do list(i) = lists end do return end c c c ############################################################# c ## ## c ## subroutine sort6 -- heapsort of a text string array ## c ## ## c ############################################################# c c c "sort6" takes an input list of character strings and sorts c it into alphabetical order using the Heapsort algorithm c c subroutine sort6 (n,list) implicit none integer i,j,k,n integer index character*256 lists character*(*) list(*) c c c perform the heapsort of the input list c k = n/2 + 1 index = n do while (n .gt. 1) if (k .gt. 1) then k = k - 1 lists = list(k) else lists = list(index) list(index) = list(1) index = index - 1 if (index .le. 1) then list(1) = lists return end if end if i = k j = k + k do while (j .le. index) if (j .lt. index) then if (list(j) .lt. list(j+1)) j = j + 1 end if if (lists .lt. list(j)) then list(i) = list(j) i = j j = j + j else j = index + 1 end if end do list(i) = lists end do return end c c c ################################################################ c ## ## c ## subroutine sort7 -- heapsort of text strings with keys ## c ## ## c ################################################################ c c c "sort7" takes an input list of character strings and sorts it c into alphabetical order using the Heapsort algorithm; it also c returns a key into the original ordering c c subroutine sort7 (n,list,key) implicit none integer i,j,k,n integer index integer keys integer key(*) character*256 lists character*(*) list(*) c c c initialize index into the original ordering c do i = 1, n key(i) = i end do c c perform the heapsort of the input list c k = n/2 + 1 index = n do while (n .gt. 1) if (k .gt. 1) then k = k - 1 lists = list(k) keys = key(k) else lists = list(index) keys = key(index) list(index) = list(1) key(index) = key(1) index = index - 1 if (index .le. 1) then list(1) = lists key(1) = keys return end if end if i = k j = k + k do while (j .le. index) if (j .lt. index) then if (list(j) .lt. list(j+1)) j = j + 1 end if if (lists .lt. list(j)) then list(i) = list(j) key(i) = key(j) i = j j = j + j else j = index + 1 end if end do list(i) = lists key(i) = keys end do return end c c c ######################################################### c ## ## c ## subroutine sort8 -- heapsort to unique integers ## c ## ## c ######################################################### c c c "sort8" takes an input list of integers and sorts it into c ascending order using the Heapsort algorithm, duplicate c values are removed from the final sorted list c c subroutine sort8 (n,list) implicit none integer i,j,k,n integer index integer lists integer list(*) c c c perform the heapsort of the input list c k = n/2 + 1 index = n do while (n .gt. 1) if (k .gt. 1) then k = k - 1 lists = list(k) else lists = list(index) list(index) = list(1) index = index - 1 if (index .le. 1) then list(1) = lists c c remove duplicate values from final list c j = 1 do i = 2, n if (list(i-1) .ne. list(i)) then j = j + 1 list(j) = list(i) end if end do if (j .lt. n) n = j return end if end if i = k j = k + k do while (j .le. index) if (j .lt. index) then if (list(j) .lt. list(j+1)) j = j + 1 end if if (lists .lt. list(j)) then list(i) = list(j) i = j j = j + j else j = index + 1 end if end do list(i) = lists end do return end c c c ############################################################ c ## ## c ## subroutine sort9 -- heapsort to unique real values ## c ## ## c ############################################################ c c c "sort9" takes an input list of reals and sorts it into c ascending order using the Heapsort algorithm, duplicate c values are removed from the final sorted list c c subroutine sort9 (n,list) implicit none integer i,j,k,n integer index real*8 lists real*8 list(*) c c c perform the heapsort of the input list c k = n/2 + 1 index = n do while (n .gt. 1) if (k .gt. 1) then k = k - 1 lists = list(k) else lists = list(index) list(index) = list(1) index = index - 1 if (index .le. 1) then list(1) = lists c c remove duplicate values from final list c j = 1 do i = 2, n if (list(i-1) .ne. list(i)) then j = j + 1 list(j) = list(i) end if end do if (j .lt. n) n = j return end if end if i = k j = k + k do while (j .le. index) if (j .lt. index) then if (list(j) .lt. list(j+1)) j = j + 1 end if if (lists .lt. list(j)) then list(i) = list(j) i = j j = j + j else j = index + 1 end if end do list(i) = lists end do return end c c c ############################################################## c ## ## c ## subroutine sort10 -- heapsort to unique text strings ## c ## ## c ############################################################## c c c "sort10" takes an input list of character strings and sorts c it into alphabetical order using the Heapsort algorithm, c duplicate values are removed from the final sorted list c c subroutine sort10 (n,list) implicit none integer i,j,k,n integer index character*256 lists character*(*) list(*) c c c perform the heapsort of the input list c k = n/2 + 1 index = n do while (n .gt. 1) if (k .gt. 1) then k = k - 1 lists = list(k) else lists = list(index) list(index) = list(1) index = index - 1 if (index .le. 1) then list(1) = lists c c remove duplicate values from final list c j = 1 do i = 2, n if (list(i-1) .ne. list(i)) then j = j + 1 list(j) = list(i) end if end do if (j .lt. n) n = j return end if end if i = k j = k + k do while (j .le. index) if (j .lt. index) then if (list(j) .lt. list(j+1)) j = j + 1 end if if (lists .lt. list(j)) then list(i) = list(j) i = j j = j + j else j = index + 1 end if end do list(i) = lists end do return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## program spacefill -- surface area and volume of model ## c ## ## c ############################################################### c c c "spacefill" computes the surface area and volume of c a structure; the van der Waals, accessible-excluded, c and contact-reentrant definitions are available c c program spacefill use atomid use atoms use files use inform use iounit use kvdws use math use ptable use usage implicit none integer i,ixyz,next integer mode,frame integer freeunit real*8 area,volume real*8 exclude,reentrant real*8 random,value real*8, allocatable :: radius(:) logical exist,query character*1 answer character*240 xyzfile character*240 record character*240 string external random c c c set up the structure and values for the computation; c atomic radii can be changed via the keyword mechanism c call initial call getxyz call field call active call katom call kvdw c c initialize random numbers and turn on extra printing c verbose = .false. value = random () debug = .true. c c select either vdw, excluded or molecular volume and area c 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 (/,' Three Types of Area and Volume can be Computed :', & //,4x,'(1) Van der Waals Area and Volume', & /,4x,'(2) Accessible Area and Excluded Volume', & /,4x,'(3) Contact-Reentrant Area and Volume') write (iout,30) 30 format (/,' Enter the Number of your Choice [1] : ',$) read (input,40) mode 40 format (i10) end if if (mode.ne.2 .and. mode.ne.3) mode = 1 c c set the excluded/accessible and contact/reentrant probes c value = 0.0d0 exclude = 0.0d0 reentrant = 0.0d0 if (mode.eq.2 .or. mode.eq.3) then query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=50,end=50) value query = .false. end if 50 continue if (query) then write (iout,60) 60 format (/,' Enter a Value for the Probe Radius', & ' [1.4 Ang] : ',$) read (input,70) value 70 format (f20.0) end if if (value .eq. 0.0d0) value = 1.4d0 if (mode .eq. 2) exclude = value if (mode .eq. 3) reentrant = value end if c c decide whether to include hydrogens in the calculation c call nextarg (answer,exist) if (.not. exist) then write (iout,80) 80 format (/,' Include the Hydrogen Atoms in Computation', & ' [N] : ',$) read (input,90) record 90 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .ne. 'Y') then do i = 1, n if (atomic(i) .eq. 1) use(i) = .false. end do end if c c decide whether to provide full output for large systems c if (n .gt. 100) then debug = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,100) 100 format (/,' Output the Surface Area of Individual Atoms', & ' [N] : ',$) read (input,110) record 110 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') debug = .true. end if c c perform dynamic allocation of some local arrays c allocate (radius(n)) c c set atomic radii based on force field or Bondi values c do i = 1, n if (use(i)) then radius(i) = rad(class(i)) c radius(i) = rad(class(i)) / twosix c radius(i) = vdwrad(atomic(i)) else radius(i) = 0.0d0 end if end do c c reopen the coordinates file and read the first structure c frame = 0 ixyz = freeunit () xyzfile = filename call suffix (xyzfile,'xyz','old') open (unit=ixyz,file=xyzfile,status ='old') rewind (unit=ixyz) call readxyz (ixyz) c c get area and volume for successive coordinate structures c do while (.not. abort) frame = frame + 1 if (frame .gt. 1) then write (iout,120) frame 120 format (/,' Area and Volume for Archive Structure :',5x,i8) end if c c use the Connolly routines to find the area and volume c call connolly (n,x,y,z,radius,exclude,reentrant,area,volume) c c print out the values of the total surface area and volume c if (mode .eq. 1) then write (iout,130) 130 format (/,' Van der Waals Surface Area and Volume :') else if (mode .eq. 2) then write (iout,140) 140 format (/,' Accessible Surface Area and Excluded Volume :') else if (mode .eq. 3) then write (iout,150) 150 format (/,' Contact-Reentrant Surface Area and Volume :') end if write (iout,160) area 160 format (/,' Total Area :',f20.3,' Square Angstroms') write (iout,170) volume 170 format (' Total Volume :',f18.3,' Cubic Angstroms') c c attempt to read next structure from the coordinate file c call readxyz (ixyz) end do c c perform deallocation of some local arrays c deallocate (radius) c c perform any final tasks before program exit c close (unit=ixyz) call final end c c c ################################################### c ## COPYRIGHT (C) 2000 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## program spectrum -- power spectrum from autocorrelation ## c ## ## c ################################################################# c c c "spectrum" computes a power spectrum over a wavelength range c from the velocity autocorrelation as a function of time c c program spectrum use files use iounit use math use units implicit none integer i,k integer next,nsamp integer ivel,nvel integer maxvel integer maxfreq integer freeunit real*8 factor,aver real*8 norm,step real*8 freq,time real*8, allocatable :: vel(:) real*8, allocatable :: intense(:) logical exist,done character*240 velfile character*240 record character*240 string c c c perform the standard initialization functions c call initial c c try to get a filename from the command line arguments c call nextarg (velfile,exist) if (exist) then call basefile (velfile) call suffix (velfile,'vel','old') inquire (file=velfile,exist=exist) end if c c ask for the velocity autocorrelation data filename c do while (.not. exist) write (iout,10) 10 format (/,' Enter Name of Velocity Autocorrelation', & ' File : ',$) read (input,20) velfile 20 format (a240) call basefile (velfile) call suffix (velfile,'vel','old') inquire (file=velfile,exist=exist) end do c c get the time step between autocorrelation data points c step = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=30,end=30) step 30 continue if (step .le. 0.0d0) then write (iout,40) 40 format (/,' Enter Time Step for Autocorrelation Data', & ' [1.0 fs] : ',$) read (input,50) step 50 format (f20.0) end if if (step .le. 0.0d0) step = 1.0d0 step = 0.001d0 * step c c open the velocity autocorrelation data file c ivel = freeunit () open (unit=ivel,file=velfile,status='old') rewind (unit=ivel) c c read through file headers to the start of the data c done = .false. do while (.not. done) read (ivel,60) record 60 format (a240) next = 1 call getword (record,string,next) if (string(1:10) .eq. 'Separation') then done = .true. read (ivel,70) 70 format () end if end do c c perform dynamic allocation of some local arrays c maxvel = 100000 maxfreq = 5000 allocate (vel(0:maxvel)) allocate (intense(maxfreq)) c c read the velocity autocorrelation as a function of time c do i = 1, maxvel read (ivel,80,err=90,end=90) record 80 format (a240) read (record,*) k,nsamp,aver,norm nvel = k vel(k) = norm end do 90 continue c c compute the power spectrum via discrete Fourier transform c factor = 2.0d0 * pi * lightspd do i = 1, maxfreq freq = factor * dble(i) intense(i) = 0.0d0 do k = 0, nvel time = step * dble(k) intense(i) = intense(i) + vel(k)*cos(freq*time) end do intense(i) = 1000.0d0 * step * intense(i) end do c c print the power spectrum intensity at each wavelength c write (iout,100) 100 format (/,' Power Spectrum from Velocity Autocorrelation :', & //,4x,'Frequency (cm-1)',10x,'Intensity',/) do i = 1, maxfreq write (iout,110) dble(i),intense(i) 110 format (3x,f12.2,8x,f16.6) end do c c perform deallocation of some local arrays c deallocate (vel) deallocate (intense) 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 ## subroutine square -- nonlinear least squares with bounds ## c ## ## c ################################################################## c c c "square" is a nonlinear least squares routine derived from the c IMSL BCLSF and MINPACK LMDER routines; the Jacobian is estimated c by finite differences and bounds are specified for the variables c to be refined c c literature references: c c "BCLSF: Solve Nonlinear Least Squares Problems Subject to Bounds c on the Variables Using a Modified Levenberg-Marquardt Algorithm c and a Finite-Difference Jacobian", IMSL Fortran Math Library, c Version 2020.0, Rogue Wave Software, 2019 c c B. S. Garbow, K. E. Hillstrom and J. J. More, "MINPACK Subroutine c LMDER", Argonne National Laboratory, March 1980 c c arguments and variables: c c n number of least squares variables c m number of residual functions c xlo vector with the lower bounds for the variables c xhi vector with the upper bounds for the variables c xscale vector with the diagonal scaling matrix for variables c xc vector with variable values at the approximate solution c fc vector with the residuals at the approximate solution c fp vector containing the updated residuals c xp vector containing the updated point c sc vector containing the last step taken c gc vector with gradient estimate at approximate solution c fjac matrix with estimate of Jacobian at approximate solution c iactive vector showing if variable is at upper or lower bound c ipvt vector with permutation matrix used in QR factorization c of the Jacobian at the approximate solution c stpmax scalar containing maximum allowed step size c delta scalar containing the trust region radius c c required external routines: c c rsdvalue subroutine to evaluate residual function values c lsqwrite subroutine to write out info about current status c c subroutine square (n,m,xlo,xhi,xc,fc,gc,fjac,grdmin, & rsdvalue,lsqwrite) use inform use iounit use keys use minima implicit none integer i,j,k,m,n integer icode,next integer niter,ncalls integer nactive,nbigstp integer, allocatable :: iactive(:) integer, allocatable :: ipvt(:) real*8 eps,epsq,delta real*8 fcnorm,fpnorm real*8 gcnorm,ganorm real*8 grdmin,stpnorm real*8 stpmax,stpmin real*8 rftol,faketol real*8 xtemp,stepsz real*8 amu,sum,temp real*8 xlo(*) real*8 xhi(*) real*8 xc(*) real*8 fc(*) real*8 gc(*) real*8, allocatable :: xp(:) real*8, allocatable :: xpprev(:) real*8, allocatable :: ga(:) real*8, allocatable :: gs(:) real*8, allocatable :: sc(:) real*8, allocatable :: sa(:) real*8, allocatable :: xsa(:) real*8, allocatable :: xscale(:) real*8, allocatable :: rdiag(:) real*8, allocatable :: fp(:) real*8, allocatable :: fpprev(:) real*8, allocatable :: ftemp(:) real*8, allocatable :: qtf(:) real*8 fjac(m,*) logical done,first logical gauss,bigstp logical pivot character*20 keyword character*240 record character*240 string external rsdvalue external lsqwrite c c c initialize various counters for calls and iterations c niter = 0 ncalls = 0 nbigstp = 0 c c setup the default tolerances and parameter values c eps = 0.00000001d0 if (maxiter .eq. 0) maxiter = 100 if (iprint .lt. 0) iprint = 1 if (iwrite .lt. 0) iwrite = 1 if (fctmin .eq. 0.0d0) fctmin = eps if (grdmin .eq. 0.0d0) grdmin = eps**(1.0d0/3.0d0) epsq = sqrt(eps) delta = 0.0d0 stpmax = 10000.0d0 * sqrt(dble(n)) stpmin = eps**(2.0d0/3.0d0) rftol = eps**(2.0d0/3.0d0) faketol = 100.0d0 * eps 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) string = record(next:240) if (keyword(1:7) .eq. 'FCTMIN ') then read (string,*,err=10,end=10) fctmin else if (keyword(1:8) .eq. 'MAXITER ') then read (string,*,err=10,end=10) maxiter else if (keyword(1:8) .eq. 'STEPMAX ') then read (string,*,err=10,end=10) stpmax else if (keyword(1:8) .eq. 'STEPMIN ') then read (string,*,err=10,end=10) stpmin else 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 perform dynamic allocation of some local arrays c allocate (iactive(n)) allocate (ipvt(n)) allocate (xp(n)) allocate (xpprev(m)) allocate (ga(n)) allocate (gs(n)) allocate (sc(n)) allocate (sa(n)) allocate (xsa(n)) allocate (xscale(n)) allocate (rdiag(n)) allocate (fp(m)) allocate (fpprev(m)) allocate (ftemp(m)) allocate (qtf(m)) c c check feasibility of variables and use bounds if needed c nactive = 0 do j = 1, n if (xc(j) .lt. xlo(j)) then xc(j) = xlo(j) iactive(j) = -1 else if (xc(j) .gt. xhi(j)) then xc(j) = xhi(j) iactive(j) = 1 else nactive = nactive + 1 iactive(j) = 0 end if end do c c evaluate the function at the initial point c ncalls = ncalls + 1 call rsdvalue (n,m,xc,fc) fcnorm = 0.0d0 do i = 1, m fcnorm = fcnorm + fc(i)**2 end do fcnorm = 0.5d0 * fcnorm c c evaluate the Jacobian at the initial point by finite c differences; replace loop with user routine if desired c do j = 1, n stepsz = epsq * abs(xc(j)) if (stepsz .lt. epsq) stepsz = epsq if (xc(j) .lt. 0.0d0) stepsz = -stepsz xtemp = xc(j) xc(j) = xtemp + stepsz ncalls = ncalls + 1 call rsdvalue (n,m,xc,ftemp) xc(j) = xtemp do i = 1, m fjac(i,j) = (ftemp(i)-fc(i)) / stepsz end do end do c c compute More's adaptive variable scale factors c do j = 1, n temp = 0.0d0 do i = 1, m temp = temp + fjac(i,j)**2 end do xscale(j) = sqrt(temp) if (xscale(j) .eq. 0.0d0) xscale(j) = 1.0d0 end do c c compute the total gradient vector for all variables c do j = 1, n gc(j) = 0.0d0 do i = 1, m gc(j) = gc(j) + fjac(i,j)*fc(i) end do end do c c compute the norm of the scaled total gradient c and the scaled gradient for active variables c gcnorm = 0.0d0 ganorm = 0.0d0 do j = 1, n gs(j) = gc(j) * max(abs(xc(j)),1.0d0/xscale(j)) gcnorm = gcnorm + gs(j)**2 if (iactive(j) .eq. 0) then ganorm = ganorm + gs(j)**2 end if end do gcnorm = sqrt(gcnorm/dble(n)) if (nactive .ne. 0) ganorm = sqrt(ganorm/dble(nactive)) c c print out information about initial conditions c if (iprint .gt. 0) then write (iout,20) 20 format (/,' Levenberg-Marquardt Nonlinear Least Squares :') write (iout,30) 30 format (/,' LS Iter F Value Total G Active G', & ' N Active F Calls',/) if (max(fcnorm,gcnorm) .lt. 10000000.0d0) then write (iout,40) niter,fcnorm,gcnorm,ganorm,nactive,ncalls 40 format (i6,f14.4,2f13.4,2i10) else write (iout,50) niter,fcnorm,gcnorm,ganorm,nactive,ncalls 50 format (i6,d14.4,2d13.4,2i10) end if end if c c write out the parameters, derivatives and residuals c if (iwrite .ne. 0) call lsqwrite (niter,m,xc,gs,fc) c c check stopping criteria at the initial point; test the c absolute function value and gradient norm for termination c if (fcnorm .le. fctmin) return if (ganorm .le. grdmin) return c c beginning of the main least squares iteration loop c done = .false. do while (.not. done) niter = niter + 1 c c repack the Jacobian to include only active variables c if (nactive .ne. n) then k = 0 do j = 1, n if (iactive(j) .ne. 0) then if (k .eq. 0) k = j else if (k .ne. 0) then do i = 1, m fjac(i,k) = fjac(i,j) end do k = k + 1 end if end if end do end if c c repack scale factors and gradient for active variables c k = 0 do j = 1, n if (iactive(j) .eq. 0) then k = k + 1 xsa(k) = xscale(j) ga(k) = gc(j) end if end do c c compute the QR factorization of the Jacobian c pivot = .true. call qrfact (nactive,m,fjac,pivot,ipvt,rdiag) c c compute the vector Q(transpose) * residuals c do i = 1, m qtf(i) = fc(i) end do do j = 1, nactive if (fjac(j,j) .ne. 0.0d0) then sum = 0.0d0 do i = j, m sum = sum + fjac(i,j)*qtf(i) end do temp = -sum / fjac(j,j) do i = j, m qtf(i) = qtf(i) + fjac(i,j)*temp end do end if fjac(j,j) = rdiag(j) end do c c compute the Levenberg-Marquardt step c icode = 6 first = .true. do while (icode .ge. 4) call lmstep (nactive,m,ga,fjac,ipvt,xsa,qtf,stpmax, & delta,amu,first,sa,gauss) c c unpack the step vector to include all variables c k = 0 do i = 1, n if (iactive(i) .ne. 0) then sc(i) = 0.0d0 else k = k + 1 sc(i) = sa(k) end if end do c c check new point and update the trust region c call trust (n,m,xc,fcnorm,gc,fjac,ipvt,sc,sa,xscale,gauss, & stpmax,delta,icode,xp,xpprev,fc,fp,fpnorm, & fpprev,bigstp,ncalls,xlo,xhi,nactive,stpmin, & rftol,faketol,rsdvalue) end do if (icode .eq. 1) done = .true. c c update to the new variables and residuals c do j = 1, n xc(j) = xp(j) end do do i = 1, m fc(i) = fp(i) end do fcnorm = fpnorm c c check for active variables to be made inactive; in a true c active set strategy, variables are removed one at a time c from the current active set (via goto statements below) c do j = 1, n if (iactive(j) .eq. 0) then if (abs(xc(j)-xlo(j)) .le. eps) then nactive = nactive - 1 iactive(j) = -1 goto 60 else if (abs(xc(j)-xhi(j)) .le. eps) then nactive = nactive - 1 iactive(j) = 1 goto 60 end if end if end do 60 continue c c evaluate the Jacobian at the new point using finite c differences; replace loop with user routine if desired c do j = 1, n stepsz = epsq * max(abs(xc(j)),1.0d0/xscale(j)) if (xc(j) .lt. 0.0d0) stepsz = -stepsz xtemp = xc(j) xc(j) = xtemp + stepsz ncalls = ncalls + 1 call rsdvalue (n,m,xc,ftemp) xc(j) = xtemp do i = 1, m fjac(i,j) = (ftemp(i)-fc(i)) / stepsz end do end do c c compute the LMDER adaptive variable scale factors c do j = 1, n temp = 0.0d0 do i = 1, m temp = temp + fjac(i,j)**2 end do xscale(j) = max(xscale(j),sqrt(temp)) end do c c compute the total gradient vector for all variables c do j = 1, n gc(j) = 0.0d0 do i = 1, m gc(j) = gc(j) + fjac(i,j)*fc(i) end do end do c c compute the norm of the scaled total gradient c and the scaled gradient for active variables c gcnorm = 0.0d0 ganorm = 0.0d0 do j = 1, n gs(j) = gc(j) * max(abs(xc(j)),1.0d0/xscale(j)) gcnorm = gcnorm + gs(j)**2 if (iactive(j) .eq. 0) then ganorm = ganorm + gs(j)**2 end if end do gcnorm = sqrt(gcnorm/dble(n)) if (nactive .ne. 0) ganorm = sqrt(ganorm/dble(nactive)) c c print out information about current iteration c if (iprint.ne.0 .and. mod(niter,iprint).eq.0) then if (max(fcnorm,gcnorm) .lt. 10000000.0d0) then write (iout,70) niter,fcnorm,gcnorm,ganorm, & nactive,ncalls 70 format (i6,f14.4,2f13.4,2i10) else write (iout,80) niter,fcnorm,gcnorm,ganorm, & nactive,ncalls 80 format (i6,d14.4,2d13.4,2i10) end if end if c c check stopping criteria at the new point; test the absolute c function value, gradient norm and step norm for termination c if (fcnorm .le. fctmin) done = .true. if (ganorm .le. grdmin) done = .true. stpnorm = 0.0d0 do j = 1, n temp = max(abs(xc(j)),1.0d0/xscale(j)) stpnorm = stpnorm + (sc(j)/temp)**2 end do stpnorm = sqrt(stpnorm/dble(n)) if (stpnorm.gt.eps .and. stpnorm.le.stpmin) done = .true. c c check for inactive variables to be made active; in a true c active set strategy, variables are added one at a time to c the current active set (via goto statements below) c if (done) then if (nactive .ne. n) then do j = 1, n if (iactive(j).eq.-1 .and. gc(j).lt.0.0d0) then nactive = nactive + 1 iactive(j) = 0 done = .false. goto 90 else if (iactive(j).eq.1 .and. gc(j).gt.0.0d0) then nactive = nactive + 1 iactive(j) = 0 done = .false. goto 90 end if end do 90 continue end if end if c c if still done, then normal termination has been achieved c if (done) then write (iout,100) 100 format (/,' SQUARE -- Normal Termination of', & ' Least Squares') c c check for termination due to relative function convergence c else if (icode .eq. 2) then done = .true. write (iout,110) 110 format (/,' SQUARE -- Successful Relative Function', & ' Convergence') if (verbose) then write (iout,120) 120 format (/,' Both the scaled actual and predicted', & ' reductions in the function', & /,' are less than or equal to the relative', & ' convergence tolerance') end if c c check for termination due to false convergence c else if (icode .eq. 3) then done = .true. write (iout,130) 130 format (/,' SQUARE -- Possible False Convergence') if (verbose) then write (iout,140) 140 format (/,' The iterates appear to be converging to', & ' a noncritical point due', & /,' to bad gradient information, discontinuous', & ' function, or stopping', & /,' tolerances being too tight') end if c c check for several consecutive maximum steps taken c else if (bigstp) then nbigstp = nbigstp + 1 if (nbigstp .eq. 5) then done = .true. write (iout,150) 150 format (/,' SQUARE -- Five Consecutive Maximum', & ' Length Steps') if (verbose) then write (iout,160) 160 format (/,' Either the function is unbounded below,', & ' or has a finite', & /,' asymptote in some direction, or STEPMAX', & ' is too small') end if end if c c check the limit on the number of iterations c else if (niter .ge. maxiter) then done = .true. write (iout,170) 170 format (/,' SQUARE -- Incomplete Convergence due', & ' to IterLimit') c c no reason to quit, so prepare to take another step c else nbigstp = 0 end if c c write out the parameters, derivatives and residuals c if (iwrite.ne.0 .and. mod(niter,iwrite).eq.0) then if (.not. done) call lsqwrite (niter,m,xc,gs,fc) end if end do c c perform deallocation of some local arrays c deallocate (iactive) deallocate (ipvt) deallocate (xp) deallocate (ga) deallocate (gs) deallocate (sc) deallocate (sa) deallocate (xsa) deallocate (xscale) deallocate (rdiag) deallocate (fp) deallocate (ftemp) deallocate (qtf) return end c c c ################################################################ c ## ## c ## subroutine lmstep -- computes Levenberg-Marquardt step ## c ## ## c ################################################################ c c c "lmstep" computes a Levenberg-Marquardt step during a nonlinear c least squares based on the IMSL U7LSF and MINPACK LMPAR routines c and the internal doubling strategy of Dennis and Schnabel c c literature reference: c c J. E. Dennis, Jr. and R. B. Schnabel, "Numerical Methods for c Unconstrained Optimization and Nonlinear Equations", SIAM, 1987 c c arguments and variables: c c n number of least squares variables c m number of residual functions c ga vector with the gradient of the residual vector c a array of size n by n which on input contains in the full c upper triangle of the matrix r resulting from the QR c factorization of the Jacobian; on output the full upper c triangle is unaltered, and the strict lower triangle c contains the strict lower triangle of the matrix l c which is the Cholesky factor of (j**t)*j + amu*xscale c ipvt vector with pivoting information from QR factorization c xscale vector with the diagonal scaling matrix for variables c qtf vector with first n elements of Q(transpose) c * (scaled residual) c amu scalar with initial estimate of the Levenberg-Marquardt c parameter on input, and the final estimate of the c parameter on output c first logical flag set true only if this is the first c call to this routine in this iteration c sa vector with the Levenberg-Marquardt step c gnstep vector with the Gauss-Newton step c gauss logical flag set true if the Gauss-Newton step c is acceptable, and false otherwise c diag vector with the diagonal elements of the Cholesky c factor of (j**t)*j + amu*xscale c c subroutine lmstep (n,m,ga,a,ipvt,xscale,qtf,stpmax, & delta,amu,first,sa,gauss) implicit none integer i,j,k integer m,n,nsing integer maxtry,ntry integer ipvt(*) real*8 stpmax,delta real*8 amu,alow,alpha real*8 amulow,amuhi real*8 beta,high,sum real*8 deltap,gnleng real*8 phi,phip,phipi real*8 stplen,sgnorm real*8 gamma,eps,temp real*8 ga(*) real*8 xscale(*) real*8 qtf(*) real*8 sa(*) real*8, allocatable :: gnstep(:) real*8, allocatable :: diag(:) real*8, allocatable :: work1(:) real*8, allocatable :: work2(:) real*8 a(m,*) logical first,gauss logical done save deltap,nsing save gnleng,sgnorm save phi,phip,phipi c c c initialize the Levenberg-Marquardt step length c do i = 1, n sa(i) = 0.0d0 end do c c set values for floating point magnitude and spacing c gamma = 0.00000001d0 eps = 0.00000001d0 c c perform dynamic allocation of some local arrays c allocate (gnstep(n)) allocate (diag(n)) allocate (work1(n)) allocate (work2(n)) c c if initial trust region is not provided, compute the Cauchy c step length given by beta = norm2(r*trans(p)*d**(-2)*g)**2 c if (delta .eq. 0.0d0) then amu = 0.0d0 do i = 1, n work1(i) = ga(i) / xscale(i) end do alpha = 0.0d0 do i = 1, n alpha = alpha + work1(i)**2 end do beta = 0.0d0 do i = 1, n temp = 0.0d0 do j = i, n k = ipvt(j) temp = temp + a(i,j)*ga(k)/xscale(k)**2 end do beta = beta + temp**2 end do if (beta .le. gamma) then delta = alpha * sqrt(alpha) else delta = alpha * sqrt(alpha)/beta end if delta = min(delta,stpmax) end if c c the below is only done the first time through this iteration: c (1) compute a Gauss-Newton step; if Jacobian is rank-deficient, c obtain a least squares solution, (2) compute the length of the c scaled Gauss-Newton step, (3) compute the norm of the scaled c gradient used in computing an upper bound for "amu" c if (first) then nsing = n do j = 1, n if (a(j,j).eq.0.0d0 .and. nsing.eq.n) nsing = j - 1 if (nsing .lt. n) work1(j) = 0.0d0 end do work1(nsing) = qtf(nsing) / a(nsing,nsing) do j = nsing-1, 1, -1 sum = 0.0d0 do i = j+1, nsing sum = sum + a(j,i)*work1(i) end do work1(j) = (qtf(j)-sum) / a(j,j) end do do j = 1, n gnstep(ipvt(j)) = -work1(j) end do c c find the length of scaled Gauss-Newton step c do j = 1, n work1(j) = xscale(j) * gnstep(j) end do gnleng = 0.0d0 do j = 1, n gnleng = gnleng + work1(j)**2 end do gnleng = sqrt(gnleng) c c find the length of the scaled gradient c do j = 1, n work1(j) = ga(j) / xscale(j) end do sgnorm = 0.0d0 do j = 1, n sgnorm = sgnorm + work1(j)**2 end do sgnorm = sqrt(sgnorm) end if c c set bounds on number of iterations and computed step c maxtry = 100 high = 1.5d0 alow = 0.75d0 c c check to see if the Gauss-Newton step is acceptable c if (gnleng .le. high*delta) then gauss = .true. do j = 1, n sa(j) = gnstep(j) end do amu = 0.0d0 delta = min(delta,gnleng) c c the Gauss-Newton step is rejected, find a nontrivial step; c first compute a starting value of "amu" if previous step c was not a Gauss-Newton step c else gauss = .false. if (amu .gt. 0.0d0) & amu = amu - ((phi+deltap)/delta)*(((deltap-delta)+phi)/phip) phi = gnleng - delta c c if the Jacobian is not rank deficient, the Newton step c provides a lower bound for "amu"; else set bound to zero c if (nsing .eq. n) then if (first) then first = .false. do j = 1, n k = ipvt(j) work1(j) = gnstep(k) * xscale(k)**2 end do c c obtain trans(r**-1)*(trans(p)*s) by solving the system of c equations trans(r)*work1 = work1 c work1(n) = work1(n) / a(n,n) do j = n-1, 1, -1 sum = 0.0d0 do i = j+1, n sum = sum + a(j,i)*work1(i) end do work1(j) = (work1(j)-sum) / a(j,j) end do phipi = 0.0d0 do j = 1, n phipi = phipi - work1(j)**2 end do phipi = phipi / gnleng end if amulow = -phi / phipi else first = .false. amulow = 0.0d0 end if amuhi = sgnorm / delta c c iterate until a satisfactory "amu" is generated c ntry = 0 done = .false. do while (.not. done) if (amu.lt.amulow .or. amu.gt.amuhi) then amu = max(sqrt(amulow*amuhi),0.001d0*amuhi) end if temp = sqrt(amu) do j = 1, n work1(j) = temp * xscale(j) end do c c solve the damped least squares system using the Levenberg- c Marquardt step from the MINPACK LMPAR method c call qrsolve (n,m,a,ipvt,work1,qtf,sa,diag,work2) do j = 1, n sa(j) = -sa(j) end do do j = 1, n work2(j) = xscale(j) * sa(j) end do stplen = 0.0d0 do j = 1, n stplen = stplen + work2(j)**2 end do stplen = sqrt(stplen) phi = stplen - delta do j = 1, n k = ipvt(j) work1(j) = xscale(k) * work2(k) end do do j = 1, n if (abs(diag(j)) .ge. gamma) then work1(j) = work1(j) / diag(j) end if if (j .lt. n) then do i = j+1, n work1(i) = work1(i) - work1(j)*a(i,j) end do end if end do phip = 0.0d0 do j = 1, n phip = phip - work1(j)**2 end do phip = phip / stplen c c check for an acceptable step or for too many iterations; c otherwise update amulow, amuhi and amu for next iteration c ntry = ntry + 1 if (stplen.ge.alow*delta .and. stplen.le.high*delta) then done = .true. else if (amuhi-amulow .le. eps) then done = .true. else if (ntry .ge. maxtry) then done = .true. else amulow = max(amulow,amu-(phi/phip)) if (phi .lt. 0.0d0) amuhi = amu amu = amu - (stplen/delta)*(phi/phip) end if end do end if deltap = delta c c perform deallocation of some local arrays c deallocate (gnstep) deallocate (diag) deallocate (work1) deallocate (work2) return end c c c ############################################################## c ## ## c ## subroutine trust -- update of the model trust region ## c ## ## c ############################################################## c c c "trust" updates the model trust region for a nonlinear least c squares calculation based on the IMSL B4LSF routine and the c NL2SOL method of Dennis and colleagues c c literature reference: c c J. E. Dennis, Jr. and R. B. Schnabel, "Numerical Methods for c Unconstrained Optimization and Nonlinear Equations", SIAM, 1987 c c arguments and variables: c c n number of least squares variables c m number of residual functions c xc vector with the current iterate c fcnorm scalar containing the norm of f(xc) c gc vector with the gradient at xc c a real m by n matrix containing the upper triangular c matrix r from the QR factorization of the current c Jacobian in the upper triangle c ipvt vector of length n containing the permutation matrix c from QR factorization of the Jacobian c sc vector containing the Newton step c sa vector containing current step c xscale vector containing the diagonal scaling matrix for x c gauss flag set to true when the Gauss-Newton step is taken c stpmax maximum allowable step size c delta trust region radius with value retained between calls c icode return code values, set upon exit: c 0 xp is accepted as the next iterate, and delta c is the trust region for next iteration c 1 the algorithm was unable to find a satisfactory c xp sufficiently distinct from xc c 2 both the scaled actual and predicted model c reductions are smaller than rftol c 3 false convergence is detected c 4 fpnorm is too large, so the current iteration c is continued with a new, reduced trust region c 5 fpnorm is sufficiently small, but the chance of c taking a longer successful step seems good, c so the current iteration is to be continued c with a new, doubled trust region c xp vector of length n containing the new iterate c xpprev vector with the value of xp at the previous call c within this iteration c fp vector of length m containing the functions at xp c fpnorm scalar containing the norm of f(xp) c fpprev vector of length m containing f(xpprev) c bigstp flag set to true if maximum step length was taken c ncalls number of function evaluations used c xlo vector of length n containing the lower bounds c xhi vector of length n containing the upper bounds c nactive number of columns in the active Jacobian c c required external routines: c c rsdvalue subroutine to evaluate residual function values c c subroutine trust (n,m,xc,fcnorm,gc,a,ipvt,sc,sa,xscale,gauss, & stpmax,delta,icode,xp,xpprev,fc,fp,fpnorm, & fpprev,bigstp,ncalls,xlo,xhi,nactive,stpmin, & rftol,faketol,rsdvalue) implicit none integer i,j,k integer m,n,icode integer ncalls,nactive integer ipvt(*) real*8 fcnorm,stpmax real*8 fpnorm,fpnrmp real*8 reduce,model real*8 rellen,slope,eps real*8 stplen,stpmin real*8 rftol,faketol real*8 alpha,delta,temp real*8 xc(*) real*8 gc(*) real*8 sc(*) real*8 sa(*) real*8 xp(*) real*8 xpprev(*) real*8 fc(*) real*8 fp(*) real*8 fpprev(*) real*8 xlo(*) real*8 xhi(*) real*8 xscale(*) real*8 a(m,*) logical gauss,bigstp logical feas,ltemp save fpnrmp external rsdvalue c c c set value of alpha, logical flags and step length c eps = 0.00000001d0 alpha = 0.0001d0 bigstp = .false. feas = .true. stplen = 0.0d0 do i = 1, n stplen = stplen + (xscale(i)*sc(i))**2 end do stplen = sqrt(stplen) c c compute new trial point and new function values c do i = 1, n xp(i) = xc(i) + sc(i) if (xp(i) .gt. xhi(i)) then sc(i) = xhi(i) - xc(i) xp(i) = xhi(i) feas = .false. else if (xp(i) .lt. xlo(i)) then sc(i) = xlo(i) - xc(i) xp(i) = xlo(i) feas = .false. end if end do ncalls = ncalls + 1 call rsdvalue (n,m,xp,fp) fpnorm = 0.0d0 do i = 1, m fpnorm = fpnorm + fp(i)**2 end do fpnorm = 0.5d0 * fpnorm reduce = fpnorm - fcnorm slope = 0.0d0 do i = 1, n slope = slope + gc(i)*sc(i) end do if (icode .ne. 5) fpnrmp = 0.0d0 c c internal doubling no good; reset to previous and quit c if (icode.eq.5 .and. & ((fpnorm.ge.fpnrmp).or.(reduce.gt.alpha*slope))) then icode = 0 do i = 1, n xp(i) = xpprev(i) end do do i = 1, m fp(i) = fpprev(i) end do fpnorm = fpnrmp delta = 0.5d0 * delta c c fpnorm is too large; the step is unacceptable c else if (reduce .ge. alpha*slope) then rellen = 0.0d0 do i = 1, n temp = abs(sc(i))/max(abs(xp(i)),1.0d0/xscale(i)) rellen = max(rellen,temp) end do c c magnitude of (xp-xc) is too small, end the global step c if (rellen .lt. stpmin) then icode = 1 do i = 1, n xp(i) = xc(i) end do do i = 1, m fp(i) = fc(i) end do c c quadratic interpolation step; reduce delta and continue c else icode = 4 if (abs(reduce-slope) .gt. eps) then temp = -0.5d0 * slope * stplen / (reduce-slope) else temp = -0.5d0 * slope * stplen end if if (temp .lt. 0.1d0*delta) then delta = 0.1d0 * delta else if (temp .gt. 0.5d0*delta) then delta = 0.5d0 * delta else delta = temp end if end if c c fpnorm is sufficiently small; step is acceptable, compute the c predicted model reduction as model = g(T)*s + (1/2)*s(T)*h*s c with h = p * r**t * r * p**t c else model = slope do i = 1, nactive k = ipvt(i) temp = 0.0d0 do j = i, nactive temp = temp + sa(k)*a(i,j) end do model = model + 0.5d0*temp*temp end do ltemp = (abs(model-reduce) .le. 0.1d0*abs(reduce)) c c if reduce and predicted model agree to within relative error c of 0.1 or if negative curvature is indicated, and a longer step c is possible and delta has not been decreased this iteration, c then double trust region and continue global step c if (icode.ne.4 .and. (ltemp.or.(reduce.le.slope)) .and. feas & .and. .not.gauss .and. (delta.le.0.99d0*stpmax)) then icode = 5 do i = 1, n xpprev(i) = xp(i) end do do i = 1, m fpprev(i) = fp(i) end do fpnrmp = fpnorm delta = min(2.0d0*delta,stpmax) c c accept the point; choose new trust region for next iteration c else icode = 0 if (stplen .gt. 0.99d0*stpmax) bigstp = .true. if (reduce .ge. 0.1d0*model) then delta = 0.5d0 * delta else if (reduce .le. 0.75d0*model) then delta = min(2.0d0*delta,stpmax) end if end if c c check relative function convergence and false convergence c if (reduce .le. 2.0d0*model) then if (abs(reduce).le.rftol*abs(fcnorm) .and. & abs(model).le.rftol*abs(fcnorm)) then icode = 2 end if else rellen = 0.0d0 do i = 1, n temp = abs(sc(i))/max(abs(xp(i)),1.0d0/xscale(i)) rellen = max(rellen,temp) end do if (rellen .lt. faketol) icode = 3 end if end if return end c c c ################################################### c ## COPYRIGHT (C) 1998 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module stodyn -- SD trajectory frictional coefficients ## c ## ## c ################################################################ c c c friction global frictional coefficient for exposed particle c fgamma atomic frictional coefficients for each atom c use_sdarea logical flag to use surface area friction scaling c c module stodyn implicit none real*8 friction real*8, allocatable :: fgamma(:) logical use_sdarea save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## module strbnd -- stretch-bends in current structure ## c ## ## c ############################################################# c c c nstrbnd total number of stretch-bend interactions c isb angle and bond numbers used in stretch-bend c sbk force constants for stretch-bend terms c c module strbnd implicit none integer nstrbnd integer, allocatable :: isb(:,:) real*8, allocatable :: sbk(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module strtor -- stretch-torsions in current structure ## c ## ## c ################################################################ c c c nstrtor total number of stretch-torsion interactions c ist torsion and bond numbers used in stretch-torsion c kst 1-, 2- and 3-fold stretch-torsion force constants c c module strtor implicit none integer nstrtor integer, allocatable :: ist(:,:) real*8, allocatable :: kst(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine suffix -- test for default file extension ## c ## ## c ############################################################## c c c "suffix" checks a filename for the presence of an extension, c and appends an extension and version if none is found c c subroutine suffix (string,extension,status) use ascii implicit none integer i,k integer leng,lext integer trimtext logical exist character*1 letter character*3 status character*(*) string character*(*) extension c c c get the full length of the current filename c leng = trimtext (string) lext = trimtext (extension) c c check for an extension on the current filename 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 append an extension or version as appropriate c if (k .eq. leng) then exist = .false. if (leng .ne. 0) then inquire (file=string(1:leng),exist=exist) end if if (.not. exist) then string = string(1:leng)//'.'//extension(1:lext) call version (string,status) end if else if (status .eq. 'new') then call version (string,status) 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 superpose -- optimal coordinate superposition ## c ## ## c ############################################################### c c c "superpose" takes pairs of structures and superimposes them c in the optimal least squares sense; it will attempt to match c all atom pairs or only those specified by the user c c program superpose use align use atomid use atoms use bound use files use inform use iounit use titles implicit none integer i,ixyz,next integer n1,i1,n2,i2 integer leng1,leng2 integer ifile1,ifile2 integer frame1,frame2 integer nmax,last1 integer start,stop integer option,delta integer trimtext,freeunit integer range(4) integer, allocatable :: atomic1(:) integer, allocatable :: atomic2(:) real*8 xr,yr,zr real*8 dist,cutoff real*8 rmsvalue real*8, allocatable :: mass1(:) real*8, allocatable :: mass2(:) 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 header,exist logical query,skip logical dopbc,dowrite logical self,same,twin character*1 answer character*3, allocatable :: name1(:) character*3, allocatable :: name2(:) character*240 file1,file2 character*240 xyzfile character*240 record character*240 string c c c get atom names and masses for the first structure c call initial call getxyz call unitcell call lattice call field call katom file1 = filename leng1 = trimtext (file1) c c perform dynamic allocation of some local arrays c allocate (atomic1(n)) allocate (mass1(n)) allocate (x1(n)) allocate (y1(n)) allocate (z1(n)) allocate (name1(n)) c c store atom names and masses for the first structure c n1 = n do i = 1, n1 name1(i) = name(i) atomic1(i) = atomic(i) mass1(i) = mass(i) end do c c get atom names and masses for the second structure c call getxyz call field call katom file2 = filename leng2 = trimtext (file2) c c perform dynamic allocation of some local arrays c allocate (atomic2(n)) allocate (mass2(n)) allocate (x2(n)) allocate (y2(n)) allocate (z2(n)) allocate (name2(n)) c c store atom names and masses for the second structure c n2 = n do i = 1, n2 name2(i) = name(i) atomic2(i) = atomic(i) mass2(i) = mass(i) end do c c get atom pairs to be superimposed from command line c option = 0 start = 0 stop = 0 answer = ' ' query = .true. call nextarg (string,exist) if (exist) then query = .false. read (string,*,err=10,end=10) option if (option .eq. 1) then call nextarg (string,exist) if (exist) then answer = string(1:1) read (string,*,err=10,end=10) start answer = ' ' call nextarg (string,exist) if (exist) then answer = string(1:1) read (string,*,err=10,end=10) stop answer = ' ' end if end if end if end if 10 continue c c ask the user which pairs of atoms are to be superimposed c if (query) then write (iout,20) 20 format (/,' Two Options are Available : (1) Fit atoms', & ' "M" through "N" from structure 1', & /,' to the corresponding atoms of structure 2.', & ' Enter "1,M,N" to use this option.', & /,' If "N" is omitted, the fit uses atoms 1', & ' through "M". If both "M" and "N" are', & /,' omitted, the fit uses all atoms; or (2)', & ' Individual entry of atom range pairs', & /,' to be used in the fitting procedure.') write (iout,30) 30 format (/,' Enter an Option (either 1,M,N or 2', & ' [=1,0,0]) : ',$) read (input,40) record 40 format (a240) read (record,*,err=50,end=50) option,start,stop 50 continue if (option.lt.1 .or. option.gt.2) then option = 1 start = 0 stop = 0 end if end if c c warning if structures have different numbers of atoms c if (option .eq. 1) then if (n1.ne.n2 .and. start.eq.0) then write (iout,60) 60 format (/,' SUPERPOSE -- The Molecules contain', & ' Different Numbers of Atoms') end if end if c c perform dynamic allocation of some global arrays c nmax = max(n1,n2) allocate (ifit(2,nmax)) allocate (wfit(nmax)) c c setup automatic superposition with option to omit hydrogens c if (option .eq. 1) then if (answer .eq. ' ') then call nextarg (answer,exist) else exist = .true. end if if (.not. exist) then write (iout,70) 70 format (/,' Include Hydrogen Atoms in the Fitting', & ' [Y] : ',$) read (input,80) record 80 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (start.eq.0 .and. stop.eq.0) then start = 1 stop = min(n1,n2) else if (start.ne.0 .and. stop.eq.0) then stop = min(n1,n2,start) start = 1 else if (start.ne.0 .and. stop.ne.0) then start = max(1,start) stop = min(n1,n2,stop) end if nfit = 0 do i = start, stop skip = .false. if (answer .eq. 'N') then if (atomic1(i).le.1 .or. atomic2(i).le.1) then skip = .true. end if end if if (.not. skip) then nfit = nfit + 1 ifit(1,nfit) = i ifit(2,nfit) = i end if end do end if c c manual input of the pairs of atom ranges to superimpose c if (option .eq. 2) then write (iout,90) 90 format (/,' On successive lines below, enter atom', & ' pairs or pairs of atom ranges to use', & /,' during fitting. Entering "4,7" will fit', & ' atom 4 of structure 1 to atom 7 of', & /,' structure 2, while the entry "4,7,9,12"', & ' will match atoms 4 through 7 from', & /,' structure 1 with atoms 9 through 12 of', & ' structure 2. Hit to end entry', & /,' of the list of pairs.') nfit = 0 do while (.true.) do i = 1, 4 range(i) = 0 end do write (iout,100) 100 format (/,' Enter a Pair of Atoms or Ranges : ',$) read (input,110) record 110 format (a240) read (record,*,err=120,end=120) (range(i),i=1,4) 120 continue if (range(1) .eq. 0) then goto 130 else if (range(2) .eq. 0) then nfit = nfit + 1 ifit(1,nfit) = range(1) ifit(2,nfit) = range(1) else if (range(3) .eq. 0) then nfit = nfit + 1 ifit(1,nfit) = range(1) ifit(2,nfit) = range(2) else delta = range(3) - range(1) do i = range(1), range(2) nfit = nfit + 1 ifit(1,nfit) = i ifit(2,nfit) = i + delta end do end if end do 130 continue end if c c decide on the use of periodic boundary conditions c dopbc = .false. if (use_bounds) then call nextarg (answer,exist) if (.not. exist) then write (iout,140) 140 format (/,' Apply Periodic Boundary Conditions', & ' [N] : ',$) read (input,150) record 150 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') dopbc = .true. end if c c decide on the weighting to use for the coordinates c call nextarg (answer,exist) if (.not. exist) then write (iout,160) 160 format (/,' Use Mass- or Unit-Weighted Coordinates', & ' (M or [U]) : ',$) read (input,170) record 170 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'M') then do i = 1, nfit wfit(i) = 0.5d0 * (mass1(ifit(1,i)) + mass2(ifit(2,i))) end do else do i = 1, nfit wfit(i) = 1.0d0 end do end if c c decide whether to write the best fit set of coordinates c dowrite = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,180) 180 format (/,' Write Best-Fit Coordinates of 2nd Molecule', & ' [N] : ',$) read (input,190) record 190 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') dowrite = .true. c c chose cutoff value for output of atom pair deviations c cutoff = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=200,end=200) cutoff 200 continue if (cutoff .lt. 0.0d0) then cutoff = 0.0d0 write (iout,210) 210 format (/,' Cutoff Value for Listing RMS Deviations', & ' [0.0] : ',$) read (input,220,err=230,end=230) cutoff 220 format (f20.0) 230 continue end if c c information about structures to be superimposed c write (iout,240) file1(1:leng1) 240 format (/,' Structure File 1 : ',a) write (iout,250) file2(1:leng2) 250 format (/,' Structure File 2 : ',a) c c reopen the coordinate files with structures to superimpose c ifile1 = freeunit () call suffix (file1,'xyz','old') open (unit=ifile1,file=file1,status ='old') rewind (unit=ifile1) call suffix (file2,'xyz','old') if (file1 .eq. file2) then ifile2 = ifile1 self = .true. same = .true. do i = 1, nfit if (ifit(1,i) .ne. ifit(2,i)) same = .false. end do else ifile2 = freeunit () open (unit=ifile2,file=file2,status ='old') rewind (unit=ifile2) self = .false. same = .false. end if c c read initial structure set from the first coordinate file c last1 = 0 frame1 = 1 call readxyz (ifile1) n1 = n do i = 1, n1 x1(i) = x(i) y1(i) = y(i) z1(i) = z(i) end do c c read initial structure set from the second coordinate file c frame2 = 1 if (same) frame2 = 2 use_bounds = .false. call readxyz (ifile2) n2 = n do i = 1, n2 x2(i) = x(i) y2(i) = y(i) z2(i) = z(i) end do if (abort) then abort = .false. frame2 = 1 n2 = n1 do i = 1, n2 x2(i) = x1(i) y2(i) = y1(i) z2(i) = z1(i) end do end if c c perform the superposition of a structure pair c do while (.not. abort) write (iout,260) frame1,frame2 260 format (/,' File 1 Frame :',i6,13x,'File 2 Frame :',i6) write (iout,270) 270 format (/,' Summary of Results from Structural', & ' Superposition :') if (dopbc) then twin = .true. do i = 1, nfit i1 = ifit(1,i) i2 = ifit(2,i) if (i1 .ne. i2) twin = .false. end do if (twin) then do i = 1, n xr = x2(i) - x1(i) yr = y2(i) - y1(i) zr = z2(i) - z1(i) call image (xr,yr,zr) x2(i) = x1(i) + xr y2(i) = y1(i) + yr z2(i) = z1(i) + zr end do else do i = 1, nfit i1 = ifit(1,i) i2 = ifit(2,i) xr = x2(i2) - x1(i1) yr = y2(i2) - y1(i1) zr = z2(i2) - z1(i1) call image (xr,yr,zr) x2(i2) = x1(i1) + xr y2(i2) = y1(i1) + yr z2(i2) = z1(i1) + zr end do end if end if verbose = .true. call impose (n1,x1,y1,z1,n2,x2,y2,z2,rmsvalue) write (iout,280) rmsvalue,frame1,frame2 280 format (/,' Root Mean Square Distance :',11x,f15.6,2x,2i7) c c write out the results of the superposition c header = .true. do i = 1, nfit i1 = ifit(1,i) i2 = ifit(2,i) xr = x2(i2) - x1(i1) yr = y2(i2) - y1(i1) zr = z2(i2) - z1(i1) dist = sqrt(xr*xr + yr*yr + zr*zr) if (dist .ge. cutoff) then if (header) then header = .false. write (iout,290) 290 format (/,' Atom in the',9x,'Atom in the',12x, & 'Distance',10x,'Weight' & /,' First Structure',5x,'Second Structure', & 8x,'Separated',10x,'in Fit'/) end if write (iout,300) i1,name1(i1),i2,name2(i2),dist,wfit(i) 300 format (3x,i7,'-',a3,9x,i7,'-',a3,7x,f13.6,4x,f12.4) end if end do if (.not. header) then write (iout,310) rmsvalue 310 format (/,' Root Mean Square Distance :',11x,f15.6) end if c c create output file for superimposed second structure c if (dowrite) then do i = 1, n x(i) = x2(i) y(i) = y2(i) z(i) = z2(i) end do ixyz = freeunit () xyzfile = file2(1:leng)//'.xyz' if (frame1 .eq. last1) then call version (xyzfile,'old') open (unit=ixyz,file=xyzfile,status='old', & position='append') else last1 = frame1 call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') end if call prtxyz (ixyz) close (unit=ixyz) end if c c attempt to get next structure pair from coordinate files c frame2 = frame2 + 1 use_bounds = .false. call readxyz (ifile2) n2 = n do i = 1, n2 x2(i) = x(i) y2(i) = y(i) z2(i) = z(i) end do if (abort) then abort = .false. if (self) then rewind (unit=ifile1) do i = 1, frame1 call readxyz (ifile1) end do end if frame1 = frame1 + 1 call readxyz (ifile1) n1 = n do i = 1, n1 x1(i) = x(i) y1(i) = y(i) z1(i) = z(i) end do if (.not. abort) then frame2 = frame1 + 1 if (.not. same) then frame2 = 1 rewind (unit=ifile2) end if use_bounds = .false. call readxyz (ifile2) n2 = n do i = 1, n2 x2(i) = x(i) y2(i) = y(i) z2(i) = z(i) end do end if end if end do c c perform deallocation of some local arrays c deallocate (atomic1) deallocate (mass1) deallocate (x1) deallocate (y1) deallocate (z1) deallocate (name1) deallocate (atomic2) deallocate (mass2) deallocate (x2) deallocate (y2) deallocate (z2) deallocate (name2) c c perform any final tasks before program exit c close (unit=ifile1) if (.not. self) close (unit=ifile2) call final end c c c ################################################################ c ## COPYRIGHT (C) 1990 by Patrice Koehl & Jay William Ponder ## c ## All Rights Reserved ## c ################################################################ c c ############################################################### c ## ## c ## subroutine surface -- alpha shapes accessible surface ## c ## ## c ############################################################### c c c "surface" computes the weighted solvent accessible surface c area each atom via the inclusion-exclusion method of Herbert c Edelsbrunner based on alpha shapes c c note for small or symmetric structures where alpha shapes c may fail, switch to the Richmond method c c developed to facilitate calling UnionBall from Tinker by c Jay W. Ponder, Washington University, October 2023 c c literature references: c c P. Mach and P. Koehl, "Geometric Measures of Large Biomolecules: c Surface, Volume, and Pockets", Journal of Computational Chemistry, c 32, 3023-3038 (2011) c c P. Koehl, A. Akopyan and H. Edelsbrunner, "Computing the Volume, c Surface Area, Mean, and Gaussian Curvatures of Molecules and Their c Derivatives", Journal of Chemical Information and Modeling, 63, c 973-985 (2023) c c variables and parameters: c c nsphere number of spheres/balls in the system c coords coordinates of the center of each sphere c radii radius value for each sphere c weight weight value for each sphere c probe radius value of the probe sphere c surf weighted surface area of union of spheres c usurf unweighted surface area of union of spheres c asurf weighted area contribution of each sphere c c subroutine surface (rad,weight,probe,surf,asurf) use atoms implicit none integer i,nsphere integer nsize,nfudge integer nredundant integer, allocatable :: redlist(:) real*8 surf,usurf,eps real*8 probe,alpha real*8 rad(*) real*8 weight(*) real*8 asurf(*) real*8, allocatable :: radii(:) real*8, allocatable :: asurfx(:) real*8, allocatable :: coords(:,:) logical dowiggle character*6 symmtyp c c c check coordinates for linearity, planarity and symmetry c symmtyp = 'NONE' call chksymm (symmtyp) dowiggle = .false. if (n.gt.2 .and. symmtyp.eq.'LINEAR') dowiggle = .true. if (n.gt.3 .and. symmtyp.eq.'PLANAR') dowiggle = .true. c c use Richmond method for small symmetric structures c if (dowiggle) then call richmond (n,x,y,z,rad,weight,probe,surf,asurf) return end if c c perform dynamic allocation of some local arrays c nfudge = 10 nsize = n + nfudge allocate (radii(nsize)) allocate (asurfx(nsize)) allocate (coords(3,nsize)) allocate (redlist(nsize)) c c set the coordinates and sphere radii plus probe` c nsphere = n do i = 1, n coords(1,i) = x(i) coords(2,i) = y(i) coords(3,i) = z(i) radii(i) = 0.0d0 if (rad(i) .ne. 0.0d0) radii(i) = rad(i) + probe end do c c random coordinate perturbation to avoid numerical issues c if (dowiggle) then eps = 0.001d0 call wiggle (n,coords,eps) end if c c transfer coordinates, complete to minimum of four spheres c if needed, set Delaunay and alpha complex arrays c call setunion (nsphere,coords,radii) c c compute the weighted Delaunay triangulation c call regular3 (nredundant,redlist) c c compute the alpha complex for fixed value of alpha c alpha = 0.0d0 call alfcx (alpha,nredundant,redlist) c c if fewer than four balls, set artificial spheres as redundant c call readjust_sphere (nsphere,nredundant,redlist) c c get accessible surface area via the UnionBall method c call ball_surf (weight,surf,usurf,asurfx) c c copy surface area of each sphere into Tinker array c do i = 1, n asurf(i) = asurfx(i) end do c c perform deallocation of some local arrays c deallocate (radii) deallocate (asurfx) deallocate (coords) deallocate (redlist) return end c c c ############################################################## c ## ## c ## subroutine surface1 -- alpha shapes surface & derivs ## c ## ## c ############################################################## c c c "surface1" computes the weighted solvent accessible surface c area of each atom and the first derivatives of the area with c respect to Cartesian coordinates via the inclusion-exclusion c method of Herbert Edelsbrunner based on alpha shapes c c note for small or symmetric structures where alpha shapes c may fail, switch to the Richmond method c c developed to facilitate calling UnionBall from Tinker by c Jay W. Ponder, Washington University, October 2023 c c literature references: c c P. Mach and P. Koehl, "Geometric Measures of Large Biomolecules: c Surface, Volume, and Pockets", Journal of Computational Chemistry, c 32, 3023-3038 (2011) c c P. Koehl, A. Akopyan and H. Edelsbrunner, "Computing the Volume, c Surface Area, Mean, and Gaussian Curvatures of Molecules and Their c Derivatives", Journal of Chemical Information and Modeling, 63, c 973-985 (2023) c c variables and parameters: c c nsphere number of spheres/balls in the system c coords coordinates of the center of each sphere c radii radius value for each sphere c weight weight value for each sphere c probe radius value of the probe sphere c surf weighted surface area of union of spheres c usurf unweighted surface area of union of spheres c asurf weighted area contribution of each sphere c dsurf derivatives of the weighted surface area over c coordinates of the sphere centers c c subroutine surface1 (rad,weight,probe,surf,asurf,dsurf) use atoms implicit none integer i,nsphere integer nsize,nfudge integer nredundant integer, allocatable :: redlist(:) real*8 surf,usurf,eps real*8 probe,alpha real*8 rad(*) real*8 weight(*) real*8 asurf(*) real*8 dsurf(3,*) real*8, allocatable :: radii(:) real*8, allocatable :: asurfx(:) real*8, allocatable :: coords(:,:) real*8, allocatable :: dsurfx(:,:) logical dowiggle character*6 symmtyp c c c check coordinates for linearity, planarity and symmetry c symmtyp = 'NONE' call chksymm (symmtyp) dowiggle = .false. if (n.gt.2 .and. symmtyp.eq.'LINEAR') dowiggle = .true. if (n.gt.3 .and. symmtyp.eq.'PLANAR') dowiggle = .true. c c use Richmond method for small symmetric structures c if (dowiggle) then call richmond1 (n,x,y,z,rad,weight,probe,surf,asurf,dsurf) return end if c c perform dynamic allocation of some local arrays c nfudge = 10 nsize = n + nfudge allocate (radii(nsize)) allocate (asurfx(nsize)) allocate (coords(3,nsize)) allocate (dsurfx(3,nsize)) allocate (redlist(nsize)) c c set the coordinates and sphere radii plus probe` c nsphere = n do i = 1, n coords(1,i) = x(i) coords(2,i) = y(i) coords(3,i) = z(i) radii(i) = 0.0d0 if (rad(i) .ne. 0.0d0) radii(i) = rad(i) + probe end do c c random coordinate perturbation to avoid numerical issues c if (dowiggle) then eps = 0.001d0 call wiggle (n,coords,eps) end if c c transfer coordinates, complete to minimum of four spheres c if needed, set Delaunay and alpha complex arrays c call setunion (nsphere,coords,radii) c c compute the weighted Delaunay triangulation c call regular3 (nredundant,redlist) c c compute the alpha complex for fixed value of alpha c alpha = 0.0d0 call alfcx (alpha,nredundant,redlist) c c if fewer than four balls, set artificial spheres as redundant c call readjust_sphere (nsphere,nredundant,redlist) c c get accessible surface area via the UnionBall method c call ball_dsurf (weight,surf,usurf,asurfx,dsurfx) c c copy surface area of each sphere into Tinker array c do i = 1, n asurf(i) = asurfx(i) dsurf(1,i) = dsurfx(1,i) dsurf(2,i) = dsurfx(2,i) dsurf(3,i) = dsurfx(3,i) end do c c perform deallocation of some local arrays c deallocate (radii) deallocate (asurfx) deallocate (coords) deallocate (dsurfx) deallocate (redlist) return end c c c ################################################### c ## COPYRIGHT (C) 1996 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine surfatom -- exposed surface area of an atom ## c ## ## c ################################################################ c c c "surfatom" performs an analytical computation of the surface c area of a specified atom; a simplified version of "surface" c c literature references: c c T. J. Richmond, "Solvent Accessible Surface Area and c Excluded Volume in Proteins", Journal of Molecular Biology, c 178, 63-89 (1984) c c L. Wesson and D. Eisenberg, "Atomic Solvation Parameters c Applied to Molecular Dynamics of Proteins in Solution", c Protein Science, 1, 227-235 (1992) c c variables and parameters: c c ir number of atom for which area is desired c area accessible surface area of the atom c radius radii of each of the individual atoms c c subroutine surfatom (ir,area,radius) use atoms use iounit use math implicit none integer maxarc parameter (maxarc=1000) integer i,j,k,m integer ii,ib,jb integer io,ir integer mi,ni,narc integer key(maxarc) integer intag(maxarc) integer intag1(maxarc) integer lt(maxarc) integer kent(maxarc) integer kout(maxarc) real*8 area,arcsum real*8 arclen,exang real*8 delta,delta2 real*8 eps,rmove real*8 xr,yr,zr real*8 rr,rrsq real*8 rplus,rminus real*8 axx,axy,axz real*8 ayx,ayy real*8 azx,azy,azz real*8 uxj,uyj,uzj real*8 tx,ty,tz real*8 txb,tyb,td real*8 tr2,tr,txr,tyr real*8 tk1,tk2 real*8 thec,the,t,tb real*8 txk,tyk,tzk real*8 t1,ti,tf,tt real*8 txj,tyj,tzj real*8 ccsq,cc,xysq real*8 bsqk,bk,cosine real*8 dsqj,gi,pix2 real*8 therk,dk,gk real*8 risqk,rik real*8 radius(*) real*8 ri(maxarc),risq(maxarc) real*8 bsq(maxarc),bsq1(maxarc) real*8 dsq(maxarc),dsq1(maxarc) real*8 arci(maxarc),arcf(maxarc) real*8 ex(maxarc),gr(maxarc) real*8 b(maxarc),b1(maxarc) real*8 bg(maxarc),ther(maxarc) real*8 xc(maxarc),xc1(maxarc) real*8 yc(maxarc),yc1(maxarc) real*8 zc(maxarc),zc1(maxarc) real*8 ux(maxarc),uy(maxarc) real*8 uz(maxarc) logical moved,top logical omit(maxarc) c c c zero out the surface area for the sphere of interest c area = 0.0d0 if (radius(ir) .eq. 0.0d0) return c c set the overlap significance and connectivity shift c pix2 = 2.0d0 * pi delta = 1.0d-8 delta2 = delta * delta eps = 1.0d-8 moved = .false. rmove = 1.0d-8 c c store coordinates and radius of the sphere of interest c xr = x(ir) yr = y(ir) zr = z(ir) rr = radius(ir) rrsq = rr * rr c c initialize values of some counters and summations c 10 continue io = 0 jb = 0 ib = 0 arclen = 0.0d0 exang = 0.0d0 c c test each sphere to see if it overlaps the sphere of interest c do i = 1, n if (i.eq.ir .or. radius(i).eq.0.0d0) goto 30 rplus = rr + radius(i) tx = x(i) - xr if (abs(tx) .ge. rplus) goto 30 ty = y(i) - yr if (abs(ty) .ge. rplus) goto 30 tz = z(i) - zr if (abs(tz) .ge. rplus) goto 30 c c check for sphere overlap by testing distance against radii c xysq = tx*tx + ty*ty if (xysq .lt. delta2) then tx = delta ty = 0.0d0 xysq = delta2 end if ccsq = xysq + tz*tz cc = sqrt(ccsq) if (rplus-cc .le. delta) goto 30 rminus = rr - radius(i) c c check to see if sphere of interest is completely buried c if (cc-abs(rminus) .le. delta) then if (rminus .le. 0.0d0) goto 170 goto 30 end if c c check for too many overlaps with sphere of interest c if (io .ge. maxarc) then write (iout,20) 20 format (/,' SURFATOM -- Increase the Value of MAXARC') call fatal end if c c get overlap between current sphere and sphere of interest c io = io + 1 xc1(io) = tx yc1(io) = ty zc1(io) = tz dsq1(io) = xysq bsq1(io) = ccsq b1(io) = cc gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io)) intag1(io) = i omit(io) = .false. 30 continue end do c c case where no other spheres overlap the sphere of interest c if (io .eq. 0) then area = 4.0d0 * pi * rrsq return end if c c case where only one sphere overlaps the sphere of interest c if (io .eq. 1) then area = pix2 * (1.0d0 + gr(1)) area = mod(area,4.0d0*pi) * rrsq return end if c c case where many spheres intersect the sphere of interest; c sort the intersecting spheres by their degree of overlap c call sort2 (io,gr,key) do i = 1, io k = key(i) intag(i) = intag1(k) xc(i) = xc1(k) yc(i) = yc1(k) zc(i) = zc1(k) dsq(i) = dsq1(k) b(i) = b1(k) bsq(i) = bsq1(k) end do c c get radius of each overlap circle on surface of the sphere c do i = 1, io gi = gr(i) * rr bg(i) = b(i) * gi risq(i) = rrsq - gi*gi ri(i) = sqrt(risq(i)) ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i)))) end do c c find boundary of inaccessible area on sphere of interest c do k = 1, io-1 if (.not. omit(k)) then txk = xc(k) tyk = yc(k) tzk = zc(k) bk = b(k) therk = ther(k) c c check to see if J circle is intersecting K circle; c get distance between circle centers and sum of radii c do j = k+1, io if (omit(j)) goto 60 cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j)) cc = acos(min(1.0d0,max(-1.0d0,cc))) td = therk + ther(j) c c check to see if circles enclose separate regions c if (cc .ge. td) goto 60 c c check for circle J completely inside circle K c if (cc+ther(j) .lt. therk) goto 40 c c check for circles that are essentially parallel c if (cc .gt. delta) goto 50 40 continue omit(j) = .true. goto 60 c c check to see if sphere of interest is completely buried c 50 continue if (pix2-cc .le. td) goto 170 60 continue end do end if end do c c find T value of circle intersections c do k = 1, io if (omit(k)) goto 110 omit(k) = .true. narc = 0 top = .false. txk = xc(k) tyk = yc(k) tzk = zc(k) dk = sqrt(dsq(k)) bsqk = bsq(k) bk = b(k) gk = gr(k) * rr risqk = risq(k) rik = ri(k) therk = ther(k) c c rotation matrix elements c t1 = tzk / (bk*dk) axx = txk * t1 axy = tyk * t1 axz = dk / bk ayx = tyk / dk ayy = txk / dk azx = txk / bk azy = tyk / bk azz = tzk / bk do j = 1, io if (.not. omit(j)) then txj = xc(j) tyj = yc(j) tzj = zc(j) c c rotate spheres so K vector colinear with z-axis c uxj = txj*axx + tyj*axy - tzj*axz uyj = tyj*ayy - txj*ayx uzj = txj*azx + tyj*azy + tzj*azz cosine = min(1.0d0,max(-1.0d0,uzj/b(j))) if (acos(cosine) .lt. therk+ther(j)) then dsqj = uxj*uxj + uyj*uyj tb = uzj*gk - bg(j) txb = uxj * tb tyb = uyj * tb td = rik * dsqj tr2 = risqk*dsqj - tb*tb tr2 = max(eps,tr2) tr = sqrt(tr2) txr = uxj * tr tyr = uyj * tr c c get T values of intersection for K circle c tb = (txb+tyr) / td tb = min(1.0d0,max(-1.0d0,tb)) tk1 = acos(tb) if (tyb-txr .lt. 0.0d0) tk1 = pix2 - tk1 tb = (txb-tyr) / td tb = min(1.0d0,max(-1.0d0,tb)) tk2 = acos(tb) if (tyb+txr .lt. 0.0d0) tk2 = pix2 - tk2 thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j)) if (abs(thec) .lt. 1.0d0) then the = -acos(thec) else if (thec .ge. 1.0d0) then the = 0.0d0 else if (thec .le. -1.0d0) then the = -pi end if c c see if "tk1" is entry or exit point; check t=0 point; c "ti" is exit point, "tf" is entry point c cosine = min(1.0d0,max(-1.0d0, & (uzj*gk-uxj*rik)/(b(j)*rr))) if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then ti = tk2 tf = tk1 else ti = tk2 tf = tk1 end if narc = narc + 1 if (narc .ge. maxarc) then write (iout,70) 70 format (/,' SURFATOM -- Increase the Value', & ' of MAXARC') call fatal end if if (tf .le. ti) then arcf(narc) = tf arci(narc) = 0.0d0 tf = pix2 lt(narc) = j ex(narc) = the top = .true. narc = narc + 1 end if arcf(narc) = tf arci(narc) = ti lt(narc) = j ex(narc) = the ux(j) = uxj uy(j) = uyj uz(j) = uzj end if end if end do omit(k) = .false. c c special case; K circle without intersections c if (narc .le. 0) goto 90 c c general case; sum up arclength and set connectivity code c call sort2 (narc,arci,key) arcsum = arci(1) mi = key(1) t = arcf(mi) ni = mi if (narc .gt. 1) then do j = 2, narc m = key(j) if (t .lt. arci(j)) then arcsum = arcsum + arci(j) - t exang = exang + ex(ni) jb = jb + 1 if (jb .ge. maxarc) then write (iout,80) 80 format (/,' SURFATOM -- Increase the Value', & ' of MAXARC') call fatal end if i = lt(ni) kent(jb) = maxarc*i + k i = lt(m) kout(jb) = maxarc*k + i end if tt = arcf(m) if (tt .ge. t) then t = tt ni = m end if end do end if arcsum = arcsum + pix2 - t if (.not. top) then exang = exang + ex(ni) jb = jb + 1 i = lt(ni) kent(jb) = maxarc*i + k i = lt(mi) kout(jb) = maxarc*k + i end if goto 100 90 continue arcsum = pix2 ib = ib + 1 100 continue arclen = arclen + gr(k)*arcsum 110 continue end do if (arclen .eq. 0.0d0) goto 170 if (jb .eq. 0) goto 150 c c find number of independent boundaries and check connectivity c j = 0 do k = 1, jb if (kout(k) .ne. 0) then i = k 120 continue m = kout(i) kout(i) = 0 j = j + 1 do ii = 1, jb if (m .eq. kent(ii)) then if (ii .eq. k) then ib = ib + 1 if (j .eq. jb) goto 150 goto 130 end if i = ii goto 120 end if end do 130 continue end if end do ib = ib + 1 c c attempt to fix connectivity error by moving atom slightly c if (moved) then write (iout,140) ir 140 format (/,' SURFATOM -- Connectivity Error at Atom',i6) else moved = .true. xr = xr + rmove yr = yr + rmove zr = zr + rmove goto 10 end if c c compute the exposed surface area for the sphere of interest c 150 continue area = ib*pix2 + exang + arclen area = mod(area,4.0d0*pi) * rrsq c c attempt to fix negative area by moving atom slightly c if (area .lt. 0.0d0) then if (moved) then write (iout,160) ir 160 format (/,' SURFATOM -- Negative Area at Atom',i6) else moved = .true. xr = xr + rmove yr = yr + rmove zr = zr + rmove goto 10 end if end if 170 continue return end c c c ################################################################# c ## ## c ## subroutine surfatom1 -- surface area and derivs of atom ## c ## ## c ################################################################# c c c "surfatom1" performs an analytical computation of the surface c area and first derivatives with respect to Cartesian coordinates c of a specified atom c c subroutine surfatom1 (ir,area,darea,radius) use atoms use iounit use math implicit none integer maxarc parameter (maxarc=1000) integer i,j,k,m integer ii,ib,jb integer io,ir,in integer mi,ni,narc integer key(maxarc) integer intag(maxarc) integer intag1(maxarc) integer lt(maxarc) integer kent(maxarc) integer kout(maxarc) integer ider(maxarc) integer sign_yder(maxarc) real*8 area,arcsum real*8 arclen,exang real*8 delta,delta2 real*8 wxl,wxlsq real*8 p,s,v,rcn real*8 eps,rmove real*8 xr,yr,zr real*8 rr,rin real*8 rrx2,rrsq real*8 rplus,rminus real*8 axx,axy,axz real*8 ayx,ayy real*8 azx,azy,azz real*8 uxj,uyj,uzj real*8 tx,ty,tz real*8 txb,tyb,td real*8 tr2,tr,txr,tyr real*8 tk1,tk2 real*8 thec,the,t,tb real*8 txk,tyk,tzk real*8 t1,ti,tf,tt real*8 txj,tyj,tzj real*8 ccsq,cc,xysq real*8 bgl,bsqk,bsql real*8 bk,cosine real*8 gl,uzl,t2 real*8 dsqj,gi,pix2 real*8 dax,day,daz real*8 deal,decl real*8 dtkal,dtkcl real*8 dtlal,dtlcl real*8 therk,dk,gk real*8 risqk,rik,risql real*8 faca,facb,facc real*8 gaca,gacb real*8 radius(*) real*8 darea(3,*) real*8 ri(maxarc),risq(maxarc) real*8 bsq(maxarc),bsq1(maxarc) real*8 dsq(maxarc),dsq1(maxarc) real*8 arci(maxarc),arcf(maxarc) real*8 ex(maxarc),gr(maxarc) real*8 b(maxarc),b1(maxarc) real*8 bg(maxarc),ther(maxarc) real*8 xc(maxarc),xc1(maxarc) real*8 yc(maxarc),yc1(maxarc) real*8 zc(maxarc),zc1(maxarc) real*8 ux(maxarc),uy(maxarc) real*8 uz(maxarc) logical moved,top logical omit(maxarc) c c c zero out the area and derivatives for sphere of interest c area = 0.0d0 do i = 1, n darea(1,i) = 0.0d0 darea(2,i) = 0.0d0 darea(3,i) = 0.0d0 end do if (radius(ir) .eq. 0.0d0) return c c set the overlap significance and connectivity shift c pix2 = 2.0d0 * pi delta = 1.0d-8 delta2 = delta * delta eps = 1.0d-8 moved = .false. rmove = 1.0d-8 do i = 1, maxarc ider(i) = 0 sign_yder(i) = 0 end do c c store coordinates and radius of the sphere of interest c xr = x(ir) yr = y(ir) zr = z(ir) rr = radius(ir) rrx2 = 2.0d0 * rr rrsq = rr * rr c c initialize values of some counters and summations c 10 continue io = 0 jb = 0 ib = 0 arclen = 0.0d0 exang = 0.0d0 c c test each sphere to see if it overlaps the sphere of interest c do i = 1, n if (i.eq.ir .or. radius(i).eq.0.0d0) goto 30 rplus = rr + radius(i) tx = x(i) - xr if (abs(tx) .ge. rplus) goto 30 ty = y(i) - yr if (abs(ty) .ge. rplus) goto 30 tz = z(i) - zr if (abs(tz) .ge. rplus) goto 30 c c check for sphere overlap by testing distance against radii c xysq = tx*tx + ty*ty if (xysq .lt. delta2) then tx = delta ty = 0.0d0 xysq = delta2 end if ccsq = xysq + tz*tz cc = sqrt(ccsq) if (rplus-cc .le. delta) goto 30 rminus = rr - radius(i) c c check to see if sphere of interest is completely buried c if (cc-abs(rminus) .le. delta) then if (rminus .le. 0.0d0) goto 170 goto 30 end if c c check for too many overlaps with sphere of interest c if (io .ge. maxarc) then write (iout,20) 20 format (/,' SURFATOM1 -- Increase the Value of MAXARC') call fatal end if c c get overlap between current sphere and sphere of interest c io = io + 1 xc1(io) = tx yc1(io) = ty zc1(io) = tz dsq1(io) = xysq bsq1(io) = ccsq b1(io) = cc gr(io) = (ccsq+rplus*rminus) / (2.0d0*rr*b1(io)) intag1(io) = i omit(io) = .false. 30 continue end do c c case where no other spheres overlap the sphere of interest c if (io .eq. 0) then area = 4.0d0 * pi * rrsq return end if c c case where only one sphere overlaps the sphere of interest c if (io .eq. 1) then k = 1 txk = xc1(1) tyk = yc1(1) tzk = zc1(1) bsqk = bsq1(1) bk = b1(1) intag(1) = intag1(1) arcsum = pix2 ib = ib + 1 arclen = arclen + gr(k)*arcsum if (.not. moved) then in = intag(k) rin = radius(in) t1 = arcsum*rrsq*(bsqk-rrsq+rin*rin) / (rrx2*bsqk*bk) darea(1,ir) = darea(1,ir) - txk*t1 darea(2,ir) = darea(2,ir) - tyk*t1 darea(3,ir) = darea(3,ir) - tzk*t1 darea(1,in) = darea(1,in) + txk*t1 darea(2,in) = darea(2,in) + tyk*t1 darea(3,in) = darea(3,in) + tzk*t1 end if area = pix2 * (1.0d0 + gr(1)) area = mod(area,4.0d0*pi) * rrsq return end if c c case where many spheres intersect the sphere of interest; c sort the intersecting spheres by their degree of overlap c call sort2 (io,gr,key) do i = 1, io k = key(i) intag(i) = intag1(k) xc(i) = xc1(k) yc(i) = yc1(k) zc(i) = zc1(k) dsq(i) = dsq1(k) b(i) = b1(k) bsq(i) = bsq1(k) end do c c get radius of each overlap circle on surface of the sphere c do i = 1, io gi = gr(i) * rr bg(i) = b(i) * gi risq(i) = rrsq - gi*gi ri(i) = sqrt(risq(i)) ther(i) = 0.5d0*pi - asin(min(1.0d0,max(-1.0d0,gr(i)))) end do c c find boundary of inaccessible area on sphere of interest c do k = 1, io-1 if (.not. omit(k)) then txk = xc(k) tyk = yc(k) tzk = zc(k) bk = b(k) therk = ther(k) c c check to see if J circle is intersecting K circle; c get distance between circle centers and sum of radii c do j = k+1, io if (omit(j)) goto 60 cc = (txk*xc(j)+tyk*yc(j)+tzk*zc(j))/(bk*b(j)) cc = acos(min(1.0d0,max(-1.0d0,cc))) td = therk + ther(j) c c check to see if circles enclose separate regions c if (cc .ge. td) goto 60 c c check for circle J completely inside circle K c if (cc+ther(j) .lt. therk) goto 40 c c check for circles that are essentially parallel c if (cc .gt. delta) goto 50 40 continue omit(j) = .true. goto 60 c c check to see if sphere of interest is completely buried c 50 continue if (pix2-cc .le. td) goto 170 60 continue end do end if end do c c find T value of circle intersections c do k = 1, io if (omit(k)) goto 110 omit(k) = .true. narc = 0 top = .false. txk = xc(k) tyk = yc(k) tzk = zc(k) dk = sqrt(dsq(k)) bsqk = bsq(k) bk = b(k) gk = gr(k) * rr risqk = risq(k) rik = ri(k) therk = ther(k) c c rotation matrix elements c t1 = tzk / (bk*dk) axx = txk * t1 axy = tyk * t1 axz = dk / bk ayx = tyk / dk ayy = txk / dk azx = txk / bk azy = tyk / bk azz = tzk / bk do j = 1, io if (.not. omit(j)) then txj = xc(j) tyj = yc(j) tzj = zc(j) c c rotate spheres so K vector colinear with z-axis c uxj = txj*axx + tyj*axy - tzj*axz uyj = tyj*ayy - txj*ayx uzj = txj*azx + tyj*azy + tzj*azz cosine = min(1.0d0,max(-1.0d0,uzj/b(j))) if (acos(cosine) .lt. therk+ther(j)) then dsqj = uxj*uxj + uyj*uyj tb = uzj*gk - bg(j) txb = uxj * tb tyb = uyj * tb td = rik * dsqj tr2 = risqk*dsqj - tb*tb tr2 = max(eps,tr2) tr = sqrt(tr2) txr = uxj * tr tyr = uyj * tr c c get T values of intersection for K circle c tb = (txb+tyr) / td tb = min(1.0d0,max(-1.0d0,tb)) tk1 = acos(tb) if (tyb-txr .lt. 0.0d0) tk1 = pix2 - tk1 tb = (txb-tyr) / td tb = min(1.0d0,max(-1.0d0,tb)) tk2 = acos(tb) if (tyb+txr .lt. 0.0d0) tk2 = pix2 - tk2 thec = (rrsq*uzj-gk*bg(j)) / (rik*ri(j)*b(j)) if (abs(thec) .lt. 1.0d0) then the = -acos(thec) else if (thec .ge. 1.0d0) then the = 0.0d0 else if (thec .le. -1.0d0) then the = -pi end if c c see if "tk1" is entry or exit point; check t=0 point; c "ti" is exit point, "tf" is entry point c cosine = min(1.0d0,max(-1.0d0, & (uzj*gk-uxj*rik)/(b(j)*rr))) if ((acos(cosine)-ther(j))*(tk2-tk1) .le. 0.0d0) then ti = tk2 tf = tk1 else ti = tk2 tf = tk1 end if narc = narc + 1 if (narc .ge. maxarc) then write (iout,70) 70 format (/,' SURFATOM1 -- Increase the Value', & ' of MAXARC') call fatal end if if (tf .le. ti) then arcf(narc) = tf arci(narc) = 0.0d0 tf = pix2 lt(narc) = j ex(narc) = the top = .true. narc = narc + 1 end if arcf(narc) = tf arci(narc) = ti lt(narc) = j ex(narc) = the ux(j) = uxj uy(j) = uyj uz(j) = uzj end if end if end do omit(k) = .false. c c special case; K circle without intersections c if (narc .le. 0) goto 90 c c general case; sum up arclength and set connectivity code c call sort2 (narc,arci,key) arcsum = arci(1) mi = key(1) t = arcf(mi) ni = mi if (narc .gt. 1) then do j = 2, narc m = key(j) if (t .lt. arci(j)) then arcsum = arcsum + arci(j) - t exang = exang + ex(ni) jb = jb + 1 if (jb .ge. maxarc) then write (iout,80) 80 format (/,' SURFATOM1 -- Increase the Value', & ' of MAXARC') call fatal end if i = lt(ni) ider(i) = ider(i) + 1 sign_yder(i) = sign_yder(i) + 1 kent(jb) = maxarc*i + k i = lt(m) ider(i) = ider(i) + 1 sign_yder(i) = sign_yder(i) - 1 kout(jb) = maxarc*k + i end if tt = arcf(m) if (tt .ge. t) then t = tt ni = m end if end do end if arcsum = arcsum + pix2 - t if (.not. top) then exang = exang + ex(ni) jb = jb + 1 i = lt(ni) ider(i) = ider(i) + 1 sign_yder(i) = sign_yder(i) + 1 kent(jb) = maxarc*i + k i = lt(mi) ider(i) = ider(i) + 1 sign_yder(i) = sign_yder(i) - 1 kout(jb) = maxarc*k + i end if c c calculate the surface area derivatives c do j = 1, io if (ider(j) .ne. 0) then rcn = ider(j) * rrsq ider(j) = 0 uzl = uz(j) gl = gr(j) * rr bgl = bg(j) bsql = bsq(j) risql = risq(j) wxlsq = bsql - uzl**2 wxl = sqrt(wxlsq) p = bgl - gk*uzl v = risqk*wxlsq - p**2 v = max(eps,v) v = sqrt(v) t1 = rr * (gk*(bgl-bsql)+uzl*(bgl-rrsq)) & / (v*risql*bsql) deal = -wxl*t1 decl = -uzl*t1 - rr/v dtkal = (wxlsq-p) / (wxl*v) dtkcl = (uzl-gk) / v s = gk*b(j) - gl*uzl t1 = 2.0d0*gk - uzl t2 = rrsq - bgl dtlal = -(risql*wxlsq*b(j)*t1 & -s*(wxlsq*t2+risql*bsql)) & / (risql*wxl*bsql*v) dtlcl = -(risql*b(j)*(uzl*t1-bgl)-uzl*t2*s) & / (risql*bsql*v) gaca = rcn * (deal-(gk*dtkal-gl*dtlal)/rr) / wxl gacb = (gk-uzl*gl/b(j)) * sign_yder(j) * rr / wxlsq sign_yder(j) = 0 if (.not. moved) then faca = ux(j)*gaca - uy(j)*gacb facb = uy(j)*gaca + ux(j)*gacb facc = rcn * (decl-(gk*dtkcl-gl*dtlcl)/rr) dax = axx*faca - ayx*facb + azx*facc day = axy*faca + ayy*facb + azy*facc daz = azz*facc - axz*faca in = intag(j) darea(1,ir) = darea(1,ir) + dax darea(2,ir) = darea(2,ir) + day darea(3,ir) = darea(3,ir) + daz darea(1,in) = darea(1,in) - dax darea(2,in) = darea(2,in) - day darea(3,in) = darea(3,in) - daz end if end if end do goto 100 90 continue arcsum = pix2 ib = ib + 1 100 continue arclen = arclen + gr(k)*arcsum if (.not. moved) then in = intag(k) rin = radius(in) t1 = arcsum*rrsq*(bsqk-rrsq+rin*rin) / (rrx2*bsqk*bk) darea(1,ir) = darea(1,ir) - txk*t1 darea(2,ir) = darea(2,ir) - tyk*t1 darea(3,ir) = darea(3,ir) - tzk*t1 darea(1,in) = darea(1,in) + txk*t1 darea(2,in) = darea(2,in) + tyk*t1 darea(3,in) = darea(3,in) + tzk*t1 end if 110 continue end do if (arclen .eq. 0.0d0) goto 170 if (jb .eq. 0) goto 150 c c find number of independent boundaries and check connectivity c j = 0 do k = 1, jb if (kout(k) .ne. 0) then i = k 120 continue m = kout(i) kout(i) = 0 j = j + 1 do ii = 1, jb if (m .eq. kent(ii)) then if (ii .eq. k) then ib = ib + 1 if (j .eq. jb) goto 150 goto 130 end if i = ii goto 120 end if end do 130 continue end if end do ib = ib + 1 c c attempt to fix connectivity error by moving atom slightly c if (moved) then write (iout,140) ir 140 format (/,' SURFATOM1 -- Connectivity Error at Atom',i6) else moved = .true. xr = xr + rmove yr = yr + rmove zr = zr + rmove goto 10 end if c c compute the exposed surface area for the sphere of interest c 150 continue area = ib*pix2 + exang + arclen area = mod(area,4.0d0*pi) * rrsq c c attempt to fix negative area by moving atom slightly c if (area .lt. 0.0d0) then if (moved) then write (iout,160) ir 160 format (/,' SURFATOM1 -- Negative Area at Atom',i6) else moved = .true. xr = xr + rmove yr = yr + rmove zr = zr + rmove goto 10 end if end if 170 continue return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## subroutine switch -- get switching function coefficients ## c ## ## c ################################################################## c c c "switch" sets the coeffcients used by the fifth and seventh c order polynomial switching functions for spherical cutoffs c c subroutine switch (mode) use limits use nonpol use shunt implicit none real*8 denom,term real*8 off3,off4,off5 real*8 off6,off7 real*8 cut3,cut4,cut5 real*8 cut6,cut7 character*6 mode c c c get the switching window for the current potential type c if (mode(1:3) .eq. 'VDW') then off = vdwcut cut = vdwtaper else if (mode(1:6) .eq. 'REPULS') then off = repcut cut = reptaper else if (mode(1:4) .eq. 'DISP') then off = dispcut cut = disptaper else if (mode(1:6) .eq. 'CHARGE') then off = chgcut cut = chgtaper else if (mode(1:6) .eq. 'CHGDPL') then off = sqrt(chgcut*dplcut) cut = sqrt(chgtaper*dpltaper) else if (mode(1:6) .eq. 'DIPOLE') then off = dplcut cut = dpltaper else if (mode(1:5) .eq. 'MPOLE') then off = mpolecut cut = mpoletaper else if (mode(1:6) .eq. 'CHGTRN') then off = ctrncut cut = ctrntaper else if (mode(1:5) .eq. 'EWALD') then off = ewaldcut cut = ewaldcut else if (mode(1:6) .eq. 'DEWALD') then off = dewaldcut cut = dewaldcut else if (mode(1:6) .eq. 'USOLVE') then off = usolvcut cut = usolvcut else if (mode(1:3) .eq. 'GKV') then off = spoff cut = spcut else if (mode(1:4) .eq. 'GKSA') then off = stcut cut = stoff else off = min(vdwcut,repcut,dispcut,chgcut, & dplcut,mpolecut,ctrncut) cut = min(vdwtaper,reptaper,disptaper,chgtaper, & dpltaper,mpoletaper,ctrntaper) end if c c test for replicate periodic boundaries at this cutoff c call replica (off) c c set switching coefficients to zero for truncation cutoffs c c0 = 0.0d0 c1 = 0.0d0 c2 = 0.0d0 c3 = 0.0d0 c4 = 0.0d0 c5 = 0.0d0 f0 = 0.0d0 f1 = 0.0d0 f2 = 0.0d0 f3 = 0.0d0 f4 = 0.0d0 f5 = 0.0d0 f6 = 0.0d0 f7 = 0.0d0 c c store the powers of the switching window cutoffs c off2 = off * off off3 = off2 * off off4 = off2 * off2 off5 = off2 * off3 off6 = off3 * off3 off7 = off3 * off4 cut2 = cut * cut cut3 = cut2 * cut cut4 = cut2 * cut2 cut5 = cut2 * cut3 cut6 = cut3 * cut3 cut7 = cut3 * cut4 c c get 5th degree multiplicative switching function coefficients c if (cut .lt. off) then denom = (off-cut)**5 c0 = off*off2 * (off2-5.0d0*off*cut+10.0d0*cut2) / denom c1 = -30.0d0 * off2*cut2 / denom c2 = 30.0d0 * (off2*cut+off*cut2) / denom c3 = -10.0d0 * (off2+4.0d0*off*cut+cut2) / denom c4 = 15.0d0 * (off+cut) / denom c5 = -6.0d0 / denom end if c c get 7th degree additive switching function coefficients c if (cut.lt.off .and. mode(1:6).eq.'CHARGE') then term = 9.3d0 * cut*off / (off-cut) denom = cut7 - 7.0d0*cut6*off + 21.0d0*cut5*off2 & - 35.0d0*cut4*off3 + 35.0d0*cut3*off4 & - 21.0d0*cut2*off5 + 7.0d0*cut*off6 - off7 denom = term * denom f0 = cut3*off3 * (-39.0d0*cut+64.0d0*off) / denom f1 = cut2*off2 & * (117.0d0*cut2-100.0d0*cut*off-192.0d0*off2) / denom f2 = cut*off * (-117.0d0*cut3-84.0d0*cut2*off & +534.0d0*cut*off2+192.0d0*off3) / denom f3 = (39.0d0*cut4+212.0d0*cut3*off-450.0d0*cut2*off2 & -612.0d0*cut*off3-64.0d0*off4) / denom f4 = (-92.0d0*cut3+66.0d0*cut2*off & +684.0d0*cut*off2+217.0d0*off3) / denom f5 = (42.0d0*cut2-300.0d0*cut*off-267.0d0*off2) / denom f6 = (36.0d0*cut+139.0d0*off) / denom f7 = -25.0d0 / denom 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 syntrn -- synchronous transit path definition ## c ## ## c ############################################################## c c c tpath value of the path coordinate (0=reactant, 1=product) c ppath path coordinate for extra point in quadratic transit c xmin1 reactant coordinates as array of optimization variables c xmin2 product coordinates as array of optimization variables c xm extra coordinate set for quadratic synchronous transit c c module syntrn implicit none real*8 tpath real*8 ppath real*8, allocatable :: xmin1(:) real*8, allocatable :: xmin2(:) real*8, allocatable :: xm(:) save end c c c ################################################################ c ## COPYRIGHT (C) 2013 by Xiao Zhu, Pengyu Ren & Jay W. Ponder ## c ## All Rights Reserved ## c ################################################################ c c ############################################################## c ## ## c ## module tarray -- store dipole-dipole matrix elements ## c ## ## c ############################################################## c c c ntpair number of stored dipole-dipole matrix elements c tindex index into stored dipole-dipole matrix values c tdipdip stored dipole-dipole matrix element values c c module tarray implicit none integer ntpair integer, allocatable :: tindex(:,:) real*8, allocatable :: tdipdip(:,:) save end c c c ############################################################# c ## COPYRIGHT (C) 2018 by Zhi Wang and Jay William Ponder ## c ## All Rights Reserved ## c ############################################################# c c ########################################################### c ## ## c ## subroutine induce0b -- truncated CG dipole solver ## c ## ## c ########################################################### c c c "induce0b" computes and stores the induced dipoles via c the truncated conjugate gradient (TCG) method c c subroutine induce0b use poltcg implicit none c c c choose the options for computation of TCG induced dipoles c if (tcgguess) then call indtcgb else call indtcga end if return end c c c ################################################################# c ## ## c ## subroutine indtcga -- TCG zero guess and preconditioner ## c ## ## c ################################################################# c c c "indtcga" computes the induced dipoles and intermediates used c in polarization force calculation for the TCG method with dp c cross terms = true, initial guess mu0 = 0 and using a diagonal c preconditioner c c subroutine indtcga use atoms use limits use mpole use polar use poltcg use potent implicit none integer i,j,order real*8 n0,np0,g0 real*8 n1,np1,g1,beta1 real*8 n2,np2,g2,beta2 real*8 n3,beta3 real*8 a100,a101,a102 real*8 a103,b111 real*8, allocatable :: rsd(:,:,:) real*8, allocatable :: r0(:,:,:) real*8, allocatable :: p1(:,:,:) real*8, allocatable :: p2(:,:,:) real*8, allocatable :: p3(:,:,:) real*8, allocatable :: tp(:,:,:) c c c zero out the induced dipoles at each site c do i = 1, n do j = 1, 3 uind(j,i) = 0.0d0 uinp(j,i) = 0.0d0 end do end do if (.not. use_polar) return c c set up nab based on tcgorder value c order = tcgorder call tcg_resource (order) c c perform dynamic allocation for some global arrays c if (.not. allocated(uad)) allocate (uad(3,n,tcgnab)) if (.not. allocated(uap)) allocate (uap(3,n,tcgnab)) if (.not. allocated(ubd)) allocate (ubd(3,n,tcgnab)) if (.not. allocated(ubp)) allocate (ubp(3,n,tcgnab)) uad = 0.0d0 uap = 0.0d0 ubd = 0.0d0 ubp = 0.0d0 c c perform dynamic allocation for some local arrays c allocate (rsd(3,n,2)) allocate (r0(3,n,2)) allocate (p1(3,n,2)) allocate (p2(3,n,2)) allocate (p3(3,n,2)) allocate (tp(3,n,2)) c c get the electrostaic field due to permanent multipoles c because mu0 = 0, r0 = field - T.mu0 = field c if (use_ewald) then call dfield0c (r0(:,:,1),r0(:,:,2)) else if (use_mlist) then call dfield0b (r0(:,:,1),r0(:,:,2)) else call dfield0a (r0(:,:,1),r0(:,:,2)) end if c c udir = alpha.E = alpha.r0 c call tcg_alpha22 (r0(:,:,1),r0(:,:,2),udir,udirp) c c compute the following tcg1 intermediates: c p0 = alpha*r0 = udir, n0 = r0*a*r0, and np0 = p0*T*p0 c call tcg_alphaquad (n0,r0(:,:,1),r0(:,:,2)) call tcg_t0 (udir,udirp,tp(:,:,1),tp(:,:,2)) call tcg_dotprod (np0,3*npole,tp(:,:,1),udirp) g0 = 0.0d0 if (np0 .ne. 0.0d0) g0 = n0 / np0 c c set r1 = r0 - gamma0*T*p0, n1 = r1*a*r1, and p1 <- r1, p0 c rsd = r0 - g0 * tp call tcg_alphaquad (n1,rsd(:,:,1),rsd(:,:,2)) beta1 = 0.0d0 if (n0 .ne. 0.0d0) beta1 = n1 / n0 p1(:,:,1) = udir p1(:,:,2) = udirp call tcg_update (p1(:,:,1),rsd(:,:,1),beta1) call tcg_update (p1(:,:,2),rsd(:,:,2),beta1) c c set ua(1) = mu1 = g0 * p0, ub(1) <- p0, and xde <- p0, p1 c uad(:,:,1) = g0*udir uap(:,:,1) = g0*udirp ubd(:,:,1) = ubd(:,:,1) + 0.5d0*g0*udir ubp(:,:,1) = ubp(:,:,1) + 0.5d0*g0*udirp uind = uind + g0*(1.0d0-beta1)*udir + g0*p1(:,:,1) uinp = uinp + g0*(1.0d0-beta1)*udirp + g0*p1(:,:,2) c c the tcg1 energy and force are finished c if (order .eq. 1) goto 10 c c np1 = p1*T*p1 c g1 = n1 / np1 c r2 = r1 - g1 * T*p1 c n2 = r2*a*r2 c beta2 = n2 / n1 c call tcg_t0 (p1(:,:,1),p1(:,:,2),tp(:,:,1),tp(:,:,2)) call tcg_dotprod (np1,3*npole,tp(:,:,1),p1(:,:,2)) g1 = 0.0d0 if (np1 .ne. 0.0d0) g1 = n1 / np1 rsd = rsd - g1 * tp call tcg_alphaquad (n2,rsd(:,:,1),rsd(:,:,2)) beta2 = 0.0d0 if (n1 .ne. 0.0d0) beta2 = n2 / n1 c c p2 <- r2, p1 c np2 = p2*T*p2 c g2 = n2 / np2 c p2 = p1 call tcg_update (p2(:,:,1),rsd(:,:,1),beta2) call tcg_update (p2(:,:,2),rsd(:,:,2),beta2) call tcg_t0 (p2(:,:,1),p2(:,:,2),tp(:,:,1),tp(:,:,2)) call tcg_dotprod (np2,3*npole,tp(:,:,1),p2(:,:,2)) g2 = 0.0d0 if (np2 .ne. 0.0d0) g2 = n2 / np2 c c r3 = r2 - g2 * T*p2 c n3 = r3*a*r3 c beta3 = n3 / n2 c rsd = rsd - g2*tp call tcg_alphaquad (n3,rsd(:,:,1),rsd(:,:,2)) beta3 = 0.0d0 if (n2 .ne. 0.0d0) beta3 = n3 / n2 c c p3 <- r3, p2 c p3 = p2 call tcg_update (p3(:,:,1),rsd(:,:,1),beta3) call tcg_update (p3(:,:,2),rsd(:,:,2),beta3) c c ua(2) = mu2 = g1 * p1 c ub(1) <- p1, p2 c ub(2) <- p1 c xde <- p0, p1 c b111 = (1.0d0-beta2) * g1 a103 = 0.0d0 if (g2 .ne. 0.0d0) a103 = g0 * g1 / g2 a102 = (1.0d0-beta2)*g0 + (1.0d0+beta1)*g1 - (1.0d0+beta3)*a103 a101 = (beta2**2-1.0d0)*g0 + (1.0d0-beta2-beta1*beta2)*g1 & + beta2*a103 a100 = (1.0d0-beta2) * g0 * beta1 uad(:,:,2) = g1*p1(:,:,1) uap(:,:,2) = g1*p1(:,:,2) ubd(:,:,1) = ubd(:,:,1) + b111*p1(:,:,1) + g1*p2(:,:,1) ubp(:,:,1) = ubp(:,:,1) + b111*p1(:,:,2) + g1*p2(:,:,2) ubd(:,:,2) = ubd(:,:,2) + 0.5d0*g1*p1(:,:,1) ubp(:,:,2) = ubp(:,:,2) + 0.5d0*g1*p1(:,:,2) uind = uind + a103*p3(:,:,1) + a102*p2(:,:,1) + a101*p1(:,:,1) & + a100*udir uinp = uinp + a103*p3(:,:,2) + a102*p2(:,:,2) + a101*p1(:,:,2) & + a100*udirp c c perform deallocation for some local arrays c 10 continue deallocate (rsd) deallocate (r0) deallocate (p1) deallocate (p2) deallocate (p3) deallocate (tp) return end c c c ################################################################# c ## ## c ## subroutine indtcgb -- TCG direct guess and precondition ## c ## ## c ################################################################# c c c "indtcgb" computes the induced dipoles and intermediates used c in polarization force calculation for the TCG method with dp c cross terms = true, initial guess mu0 = direct and using diagonal c preconditioner c c subroutine indtcgb use atoms use limits use mpole use polar use poltcg use potent implicit none integer i,j,order real*8 chi,xi0,xi1 real*8 n0,np0,g0 real*8 n1,np1,g1,beta1 real*8 n2,np2,g2,beta2 real*8 n3,beta3 real*8 a100,a101,a102 real*8 a103,b111 real*8 c100,c101,c102 real*8 c200,c201,c202 real*8 c203,c204 real*8 d111,d210,d211 real*8 d212,d213,d222 real*8, allocatable :: xdr0(:,:,:) real*8, allocatable :: rsd(:,:,:) real*8, allocatable :: p0(:,:,:) real*8, allocatable :: p1(:,:,:) real*8, allocatable :: p2(:,:,:) real*8, allocatable :: p3(:,:,:) real*8, allocatable :: tp(:,:,:) c c c zero out the induced dipoles at each site c do i = 1, n do j = 1, 3 uind(j,i) = 0.0d0 uinp(j,i) = 0.0d0 end do end do if (.not. use_polar) return c c set up nab based on tcgorder value c order = tcgorder call tcg_resource (order) c c perform dynamic allocation for some global arrays c if (.not. allocated(uad)) allocate (uad(3,n,tcgnab)) if (.not. allocated(uap)) allocate (uap(3,n,tcgnab)) if (.not. allocated(ubd)) allocate (ubd(3,n,tcgnab)) if (.not. allocated(ubp)) allocate (ubp(3,n,tcgnab)) uad = 0.0d0 uap = 0.0d0 ubd = 0.0d0 ubp = 0.0d0 c c perform dynamic allocation for some local arrays c allocate (xdr0(3,n,2)) allocate (rsd(3,n,2)) allocate (p0(3,n,2)) allocate (p1(3,n,2)) allocate (p2(3,n,2)) allocate (p3(3,n,2)) allocate (tp(3,n,2)) xdr0 = 0.0d0 c c chi = omega - 1 c chi = tcgpeek - 1.0d0 c c get the electrostatic field due to permanent multipoles c and mu0 = alpha*E; use tp to store the multipole field c if (use_ewald) then call dfield0c (tp(:,:,1),tp(:,:,2)) else if (use_mlist) then call dfield0b (tp(:,:,1),tp(:,:,2)) else call dfield0a (tp(:,:,1),tp(:,:,2)) end if call tcg_alpha22 (tp(:,:,1),tp(:,:,2),udir,udirp) c c compute the following tcg1 intermediates: c r0 = -Tu*mu0 c n0 = r0*a*r0 c p0 = a*r0 c xi0 c np0 = p0*T*p0 c g0 c call tcg_ufield (udir,udirp,rsd(:,:,1),rsd(:,:,2)) call tcg_alphaquad (n0,rsd(:,:,1),rsd(:,:,2)) call tcg_alpha22 (rsd(:,:,1),rsd(:,:,2),p0(:,:,1),p0(:,:,2)) call tcg_dotprod (xi0,3*npole,rsd(:,:,1),udirp) xi0 = 0.0d0 if (n0 .ne. 0.0d0) xi0 = xi0 / n0 call tcg_t0 (p0(:,:,1),p0(:,:,2),tp(:,:,1),tp(:,:,2)) call tcg_dotprod (np0,3*npole,tp(:,:,1),p0(:,:,2)) g0 = 0.0d0 if (np0 .ne. 0.0d0) g0 = n0 / np0 c c set r1 = r0 - g0*T*p0, n1 and beta1 c rsd = rsd - g0*tp call tcg_alphaquad (n1,rsd(:,:,1),rsd(:,:,2)) beta1 = 0.0d0 if (n0 .ne. 0.0d0) beta1 = n1 / n0 c c set p1 <- r1, p0 c p1 = p0 call tcg_update (p1(:,:,1),rsd(:,:,1),beta1) call tcg_update (p1(:,:,2),rsd(:,:,2),beta1) c c compute "Residual Mutual 1" c ua(1) <- mu0 c ua(2) <- mu1 = g0 * p0 c ub(2) <- p0 c xdr0 <- p0, p1 c uad(:,:,1) = udir uap(:,:,1) = udirp ubd(:,:,1) = ubd(:,:,1) + 0.5d0*udir ubp(:,:,1) = ubp(:,:,1) + 0.5d0*udirp uad(:,:,2) = g0*p0(:,:,1) uap(:,:,2) = g0*p0(:,:,2) ubd(:,:,2) = ubd(:,:,2) + 0.5d0*g0*p0(:,:,1) ubp(:,:,2) = ubp(:,:,2) + 0.5d0*g0*p0(:,:,2) xdr0 = xdr0 + g0*(1.0d0-beta1)*p0 + g0*p1 c c get the tcg1 energy and force; tp array works as xde array c if (order .eq. 1) then c100 = 0.5d0*(1.0d0-g0) c101 = (0.5d0 - beta1*(1.0d0-xi0))*g0 c102 = g0*(1.0d0-xi0) d111 = 0.5d0*(1.0d0-xi0)*g0 xdr0(:,:,1) = xdr0(:,:,1) + chi*(c100*udir & + c101*p0(:,:,1) + c102*p1(:,:,1)) xdr0(:,:,2) = xdr0(:,:,2) + chi*(c100*udirp & + c101*p0(:,:,2) + c102*p1(:,:,2)) ubd(:,:,1) = ubd(:,:,1) + xdr0(:,:,1) ubp(:,:,1) = ubp(:,:,1) + xdr0(:,:,2) ubd(:,:,2) = ubd(:,:,2) + chi*(d111*p0(:,:,1)+0.5d0*udir) ubp(:,:,2) = ubp(:,:,2) + chi*(d111*p0(:,:,2)+0.5d0*udirp) call tcg_ufield (xdr0(:,:,1),xdr0(:,:,2),tp(:,:,1),tp(:,:,2)) call tcg_alpha12 (tp(:,:,1),tp(:,:,2)) tp(:,:,1) = tp(:,:,1) + chi*0.5d0*p1(:,:,1) & + (1.0d0-chi*beta1*0.5d0)*p0(:,:,1) + udir tp(:,:,2) = tp(:,:,2) + chi*0.5d0*p1(:,:,2) & + (1.0d0-chi*beta1*0.5d0)*p0(:,:,2) + udirp goto 10 end if c c compute the tcg2 intermediates: xi1, np1 and g1 c call tcg_dotprod (xi1,3*npole,rsd(:,:,1),udirp) if (n1 .ne. 0.0d0) xi1 = xi1 / n1 xi1 = xi1 + xi0 call tcg_t0 (p1(:,:,1),p1(:,:,2),tp(:,:,1),tp(:,:,2)) call tcg_dotprod (np1,3*npole,tp(:,:,1),p1(:,:,2)) g1 = 0.0d0 if (np1 .ne. 0.0d0) g1 = n1 / np1 c c r2 = r1 - g1*T*p1 c n2, beta2 c p2 <- r2, p1 c np2, g2 c rsd = rsd - g1*tp call tcg_alphaquad (n2,rsd(:,:,1),rsd(:,:,2)) beta2 = 0.0d0 if (n1 .ne. 0.0d0) beta2 = n2 / n1 p2 = p1 call tcg_update (p2(:,:,1),rsd(:,:,1),beta2) call tcg_update (p2(:,:,2),rsd(:,:,2),beta2) call tcg_t0 (p2(:,:,1),p2(:,:,2),tp(:,:,1),tp(:,:,2)) call tcg_dotprod (np2,3*npole,tp(:,:,1),p2(:,:,2)) g2 = 0.0d0 if (np2 .ne. 0.0d0) g2 = n2 / np2 c c r3 = r2 - g2*T*p2 c n3, beta3 c p3 <- r3, p2 c rsd = rsd - g2*tp call tcg_alphaquad (n3,rsd(:,:,1),rsd(:,:,2)) beta3 = 0.0d0 if (n2 .ne. 0.0d0) beta3 = n3 / n2 p3 = p2 call tcg_update (p3(:,:,1),rsd(:,:,1),beta3) call tcg_update (p3(:,:,2),rsd(:,:,2),beta3) c c compute "Residual Mutual 2" c ub(2) <- p1, p2 c ua(3) <- mu2 = g1 * p1 c ub(3) <- p1 c xdr0 <- p0, p1, p2, p3 c b111 = (1.0d0-beta2) * g1 a103 = 0.0d0 if (g2 .ne. 0.0d0) a103 = g0 * g1 / g2 a102 = (1.0d0-beta2)*g0 + (1.0d0+beta1)*g1 - (1.0d0+beta3)*a103 a101 = (beta2**2-1.0d0)*g0 + (1.0d0-beta2-beta1*beta2)*g1 & + beta2*a103 a100 = (1.0d0-beta2) * g0 * beta1 ubd(:,:,2) = ubd(:,:,2)+ b111*p1(:,:,1) + g1*p2(:,:,1) ubp(:,:,2) = ubp(:,:,2)+ b111*p1(:,:,2) + g1*p2(:,:,2) uad(:,:,3) = g1*p1(:,:,1) uap(:,:,3) = g1*p1(:,:,2) ubd(:,:,3) = ubd(:,:,3) + 0.5d0*g1*p1(:,:,1) ubp(:,:,3) = ubp(:,:,3) + 0.5d0*g1*p1(:,:,2) xdr0 = xdr0 + a100*p0 + a101*p1 + a102*p2 + a103*p3 c c get the tcg2 energy and force; tp array works as xde array c if (order .eq. 2) then c200 = 0.5d0*((1.0d0-g0)*(1.0d0-g1)-beta1*g1) c201 = 0.5d0*(1.0d0-g1)*g0 + (xi0-xi1)*g1*beta1**2 & + (xi1-1.0d0)*beta1*beta2*g0 & + (xi0+g0-xi0*g0)*beta1*g1 c202 = 0.0d0 c203 = 0.0d0 c204 = 0.0d0 if (g2 .ne. 0.0d0) then c202 = 0.5d0*g1 + (1.0d0-xi1)*beta2*g0*g1/g2 & + (1.0d0-xi1)*(beta2*g0-(1.0d0+beta1)*g1)*beta2 & + (xi0*g0-xi0-g0)*g1 & + (beta2*g0-beta1*g1)*(xi0-xi1) c203 = (xi1-1.0d0)*(1.0d0+beta3)*g0*g1/g2 & + (g1+beta1*g1-beta2*g0)*(1.0d0-xi1) & + (1.0d0-xi0)*g0 c204 = (1.0d0-xi1) * g0 * g1 / g2 end if d210 = 0.5d0 * (1.0d0-g1) d211 = 0.5d0 * (1.0d0-xi0)*(1.0d0-g1)*g0 d212 = ((1.0d0-xi0)-(1.0d0-xi1)*beta2) * g1 d213 = (1.0d0-xi1) * g1 d222 = 0.5d0 * d213 xdr0(:,:,1) = xdr0(:,:,1) + chi*(c204*p3(:,:,1) & + c203*p2(:,:,1) + c202*p1(:,:,1) & + c201*p0(:,:,1) + c200*udir) xdr0(:,:,2) = xdr0(:,:,2) + chi*(c204*p3(:,:,2) & + c203*p2(:,:,2) + c202*p1(:,:,2) & + c201*p0(:,:,2) + c200*udirp) ubd(:,:,1) = ubd(:,:,1) + xdr0(:,:,1) ubp(:,:,1) = ubp(:,:,1) + xdr0(:,:,2) ubd(:,:,2) = ubd(:,:,2) + chi*(d213*p2(:,:,1) + d212*p1(:,:,1) & + d211*p0(:,:,1) + d210*udir) ubp(:,:,2) = ubp(:,:,2) + chi*(d213*p2(:,:,2) + d212*p1(:,:,2) & + d211*p0(:,:,2) + d210*udirp) ubd(:,:,3) = ubd(:,:,3) + chi*(d222*p1(:,:,1) + 0.5d0*udir) ubp(:,:,3) = ubp(:,:,3) + chi*(d222*p1(:,:,2) + 0.5d0*udirp) call tcg_ufield (xdr0(:,:,1),xdr0(:,:,2),tp(:,:,1),tp(:,:,2)) call tcg_alpha12 (tp(:,:,1),tp(:,:,2)) tp(:,:,1) = tp(:,:,1) + p0(:,:,1) + udir & + chi*0.5d0*(p2(:,:,1)-beta2*p1(:,:,1)) tp(:,:,2) = tp(:,:,2) + p0(:,:,2) + udirp & + chi*0.5d0*(p2(:,:,2)-beta2*p1(:,:,2)) goto 10 end if c c store induced dipoles from elements of the xde arrays c 10 continue uind = tp(:,:,1) uinp = tp(:,:,2) c c perform deallocation for some local arrays c deallocate (xdr0) deallocate (rsd) deallocate (p0) deallocate (p1) deallocate (p2) deallocate (p3) deallocate (tp) return end c c c ################################ c ## ## c ## subroutine tcg_alphaquad ## c ## ## c ################################ c c c "tcg_alphaquad" computes the quadratic form, , c where alpha is the diagonal atomic polarizability matrix c c subroutine tcg_alphaquad (sum,a,b) use mpole use polar implicit none integer i,j,k real*8 sum real*8 a(3,*) real*8 b(3,*) c c sum = 0.0d0 !$OMP PARALLEL default(shared) private(i,j,k) !$OMP DO reduction(+:sum) schedule(guided) do i = 1, npole k = ipole(i) do j = 1, 3 sum = sum + a(j,k)*b(j,k)*polarity(k) end do end do !$OMP END DO !$OMP END PARALLEL return end c c c ############################### c ## ## c ## subroutine tcg_resource ## c ## ## c ############################### c c c "tcg_resource" sets the number of mutual induced dipole c pairs based on the passed argument c c subroutine tcg_resource (order) use iounit use poltcg implicit none integer order c c if (order.lt.1 .or. order.gt.2) then write (iout,10) 10 format (/,' TCG_RESOURCE -- Argument ORDER Is Out of Range') call fatal end if tcgnab = order if (tcgguess) tcgnab = tcgnab + 1 return end c c c ############################## c ## ## c ## subroutine tcg_alpha12 ## c ## ## c ############################## c c c "tcg_alpha12" computes source1 = alpha*source1 and c source2 = alpha*source2 c c subroutine tcg_alpha12 (source1,source2) use mpole use polar implicit none integer i,j,k real*8 source1(3,*) real*8 source2(3,*) c c !$OMP PARALLEL default(shared) private(i,j,k) !$OMP DO schedule(guided) do i = 1, npole k = ipole(i) do j = 1, 3 source1(j,k) = polarity(k) * source1(j,k) source2(j,k) = polarity(k) * source2(j,k) end do end do !$OMP END DO !$OMP END PARALLEL return end c c c ############################## c ## ## c ## subroutine tcg_alpha22 ## c ## ## c ############################## c c c "tcg_alpha22" computes result1 = alpha*source1 and c result2 = alpha*source2 c c subroutine tcg_alpha22 (source1,source2,result1,result2) use mpole use polar implicit none integer i,j,k real*8 source1(3,*) real*8 source2(3,*) real*8 result1(3,*) real*8 result2(3,*) c c !$OMP PARALLEL default(shared) private(i,j,k) !$OMP DO schedule(guided) do i = 1, npole k = ipole(i) do j = 1, 3 result1(j,k) = polarity(k) * source1(j,k) result2(j,k) = polarity(k) * source2(j,k) end do end do !$OMP END DO !$OMP END PARALLEL return end c c c ############################## c ## ## c ## subroutine tcg_dotprod ## c ## ## c ############################## c c c "tcg_dotprod" computes the dot product of two vectors c of length n elements c c subroutine tcg_dotprod (sum,n,a,b) implicit none integer i,n real*8 sum real*8 a(*) real*8 b(*) c c c find value of the scalar dot product c sum = 0.0d0 !$OMP PARALLEL default(shared) private(i) !$OMP DO reduction(+:sum) schedule(guided) do i = 1, n sum = sum + a(i)*b(i) end do !$OMP END DO !$OMP END PARALLEL return end c c c ############################# c ## ## c ## subroutine tcg_ufield ## c ## ## c ############################# c c c "tcg_ufield" applies -Tu to ind/p and returns v3d/p c c subroutine tcg_ufield (ind,inp,v3d,v3p) use limits use mpole use polar implicit none real*8 ind(3,*) real*8 inp(3,*) real*8 v3d(3,*) real*8 v3p(3,*) c c c swap TCG components with induced dipoles c call tcgswap (uind,uinp,ind,inp) c c compute mutual field c if (use_ewald) then call ufield0c (v3d,v3p) else if (use_mlist) then call ufield0b (v3d,v3p) else call ufield0a (v3d,v3p) end if c c swap TCG components with induced dipoles c call tcgswap (uind,uinp,ind,inp) return end c c c ######################### c ## ## c ## subroutine tcg_t0 ## c ## ## c ######################### c c c "tcg_t0" applies T matrix to ind/p, and returns v3d/p c T = 1/alpha + Tu c c subroutine tcg_t0 (ind,inp,v3d,v3p) use limits use mpole use polar implicit none integer i,j,k real*8 polk,polmin real*8 ind(3,*) real*8 inp(3,*) real*8 v3d(3,*) real*8 v3p(3,*) c c c apply -Tu to ind/p c call tcg_ufield (ind,inp,v3d,v3p) c c compute the 1/alpha contribution c polmin = 0.00000001d0 !$OMP PARALLEL default(shared) private(i,j,k,polk) !$OMP DO schedule(guided) do i = 1, npole k = ipole(i) if (douind(k)) then polk = max(polmin,polarity(k)) do j = 1, 3 v3d(j,k) = ind(j,k)/polk - v3d(j,k) v3p(j,k) = inp(j,k)/polk - v3p(j,k) end do end if end do !$OMP END DO !$OMP END PARALLEL return end c c c ################################################################ c ## ## c ## subroutine tcgswap -- swap induced dipoles for TCG use ## c ## ## c ################################################################ c c c "tcgswap" switches two sets of induced dipole quantities for c use with the TCG induced dipole solver c c subroutine tcgswap (uind1,uinp1,uind2,uinp2) use mpole implicit none integer i,j,k real*8 dterm,pterm real*8 uind1(3,*) real*8 uinp1(3,*) real*8 uind2(3,*) real*8 uinp2(3,*) c c c swap sets of induced dipoles for use with the TCG method c !$OMP PARALLEL default(shared) private(i,j,k,dterm,pterm) !$OMP DO schedule(guided) do i = 1, npole k = ipole(i) do j = 1, 3 dterm = uind1(j,k) pterm = uinp1(j,k) uind1(j,k) = uind2(j,k) uinp1(j,k) = uinp2(j,k) uind2(j,k) = dterm uinp2(j,k) = pterm end do end do !$OMP END DO !$OMP END PARALLEL return end c c c ############################################################## c ## ## c ## subroutine tcg_update -- get an updated TCG p-vector ## c ## ## c ############################################################## c c c "tcg_update" computes pvec = alpha*rvec + beta*pvec; c if the preconditioner is not used, then alpha = identity c c subroutine tcg_update (pvec,rvec,beta) use mpole use polar use poltcg implicit none integer i,j,k real*8 beta,alpha real*8 pvec(3,*) real*8 rvec(3,*) c c c computes an updated pvec from prior intermediates c !$OMP PARALLEL default(shared) private(i,j,k,alpha) !$OMP DO schedule(guided) do i = 1, npole k = ipole(i) alpha = polarity(k) do j = 1, 3 pvec(j,k) = alpha*rvec(j,k) + beta*pvec(j,k) end do end do !$OMP END DO !$OMP END PARALLEL return end c c c ############################################################# c ## COPYRIGHT (C) 2003 by Alan Grossfield & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################# c c ############################################################## c ## ## c ## subroutine temper -- thermostat applied at full-step ## c ## ## c ############################################################## c c c "temper" computes the instantaneous temperature and applies a c thermostat via Berendsen or Bussi-Parrinello velocity scaling, c Andersen stochastic collisions or Nose-Hoover chains; also uses c Berendsen scaling for any iEL induced dipole variables c c literature references: c c H. J. C. Berendsen, J. P. M. Postma, W. F. van Gunsteren, c A. DiNola and J. R. Hauk, "Molecular Dynamics with Coupling c to an External Bath", Journal of Chemical Physics, 81, c 3684-3690 (1984) c c G. Bussi and M. Parrinello, "Stochastic Thermostats: Comparison c of Local and Global Schemes", Computer Physics Communications, c 179, 26-29 (2008) c c H. C. Andersen, "Molecular Dynamics Simulations at Constant c Pressure and/or Temperature", Journal of Chemical Physics, c 72, 2384-2393 (1980) c c subroutine temper (dt,eksum,ekin,temp) use atomid use atoms use bath use group use mdstuf use molcul use moldyn use rgddyn use units use usage implicit none integer i,j,k,m integer nc,ns real*8 dt,dtc,dts real*8 dt2,dt4,dt8 real*8 eksum,ekt real*8 scale,speed real*8 c,d,r,s,si real*8 random,normal real*8 kt,rate,trial real*8 temp,expterm real*8 w(3) real*8 ekin(3,3) external random,normal c c c get the kinetic energy and instantaneous temperature c call kinetic (eksum,ekin,temp) if (.not. isothermal) return c c couple to external temperature bath via Berendsen scaling c if (thermostat .eq. 'BERENDSEN') then scale = 1.0d0 if (temp .ne. 0.0d0) & scale = sqrt(1.0d0 + (dt/tautemp)*(kelvin/temp-1.0d0)) if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp do j = 1, 3 vcm(j,i) = scale * vcm(j,i) wcm(j,i) = scale * wcm(j,i) end do end do else do i = 1, nuse k = iuse(i) do j = 1, 3 v(j,k) = scale * v(j,k) end do end do end if c c couple to external temperature bath via Bussi scaling c else if (thermostat .eq. 'BUSSI') then if (temp .eq. 0.0d0) temp = 0.1d0 c = exp(-dt/tautemp) d = (1.0d0-c) * (kelvin/temp) / dble(nfree) r = normal () s = 0.0d0 do i = 1, nfree-1 si = normal () s = s + si*si end do scale = c + (s+r*r)*d + 2.0d0*r*sqrt(c*d) scale = sqrt(scale) if (r+sqrt(c/d) .lt. 0.0d0) scale = -scale eta = eta * scale if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp do j = 1, 3 vcm(j,i) = scale * vcm(j,i) wcm(j,i) = scale * wcm(j,i) end do end do else do i = 1, nuse k = iuse(i) do j = 1, 3 v(j,k) = scale * v(j,k) end do end do end if c c select random velocities via Andersen stochastic collisions c else if (thermostat .eq. 'ANDERSEN') then kt = boltzmann * kelvin rate = 1000.0d0 * dt * collide if (integrate .eq. 'RIGIDBODY') then rate = rate / dble(ngrp)**(2.0d0/3.0d0) do i = 1, ngrp trial = random () if (trial .lt. rate) then speed = sqrt(kt/grpmass(i)) do j = 1, 3 vcm(j,i) = speed * normal () end do end if end do else if (barostat.eq.'MONTECARLO' .and. & volscale.eq.'MOLECULAR') then rate = rate / dble(nmol)**(2.0d0/3.0d0) do i = 1, nmol trial = random () if (trial .lt. rate) then do j = imol(1,i), imol(2,i) k = kmol(j) speed = sqrt(kt/mass(k)) do m = 1, 3 v(m,k) = speed * normal () end do end do end if end do else rate = rate / dble(nuse)**(2.0d0/3.0d0) do i = 1, nuse k = iuse(i) trial = random () if (trial .lt. rate) then speed = sqrt(kt/mass(k)) do j = 1, 3 v(j,k) = speed * normal () end do end if end do end if c c make full-step velocity correction for Nose-Hoover system c else if (thermostat .eq. 'NOSE-HOOVER') then ekt = gasconst * kelvin nc = 5 ns = 3 dtc = dt / dble(nc) w(1) = 1.0d0 / (2.0d0-2.0d0**(1.0d0/3.0d0)) w(2) = 1.0d0 - 2.0d0*w(1) w(3) = w(1) scale = 1.0d0 do i = 1, nc do j = 1, ns dts = w(j) * dtc dt2 = 0.5d0 * dts dt4 = 0.25d0 * dts dt8 = 0.125d0 * dts gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4) vnh(4) = vnh(4) + gnh(4)*dt4 gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3) expterm = exp(-vnh(4)*dt8) vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4) gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2) expterm = exp(-vnh(3)*dt8) vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4) gnh(1) = (2.0d0*eksum-dble(nfree)*ekt) / qnh(1) expterm = exp(-vnh(2)*dt8) vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4) expterm = exp(-vnh(1)*dt2) scale = scale * expterm eksum = eksum * expterm * expterm gnh(1) = (2.0d0*eksum-dble(nfree)*ekt) / qnh(1) expterm = exp(-vnh(2)*dt8) vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4) gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2) expterm = exp(-vnh(3)*dt8) vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4) gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3) expterm = exp(-vnh(4)*dt8) vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4) gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4) vnh(4) = vnh(4) + gnh(4)*dt4 end do end do if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp do j = 1, 3 vcm(j,i) = scale * vcm(j,i) wcm(j,i) = scale * wcm(j,i) end do end do else do i = 1, nuse k = iuse(i) do j = 1, 3 v(j,k) = scale * v(j,k) end do end do end if end if c c recompute kinetic energy and instantaneous temperature c call kinetic (eksum,ekin,temp) return end c c c ############################################################### c ## ## c ## subroutine temper2 -- thermostat applied at half-step ## c ## ## c ############################################################### c c c "temper2" applies a velocity correction at the half time step c as needed for the Nose-Hoover thermostat c c literature references: c c D. Frenkel and B. Smit, "Understanding Molecular Simulation, c 2nd Edition", Academic Press, San Diego, CA, 2002; see Appendix c E.2 for implementation details c c G. J. Martyna, M. E. Tuckerman, D. J. Tobias and M. L. Klein, c "Explicit Reversible Integrators for Extended Systems Dynamics", c Molecular Physics, 87, 1117-1157 (1996) c c subroutine temper2 (dt,temp) use atoms use bath use group use ielscf use mdstuf use moldyn use rgddyn use units use usage implicit none integer i,j,k integer nc,ns real*8 dt,dtc,dts real*8 dt2,dt4,dt8 real*8 eksum,ekt real*8 scale,temp real*8 expterm real*8 scalep real*8 temp_aux real*8 temp_auxp real*8 w(3) real*8 ekin(3,3) c c c get the kinetic energy and instantaneous temperature c call kinetic (eksum,ekin,temp) c c make half-step velocity correction for Nose-Hoover system c if (isothermal .and. thermostat.eq.'NOSE-HOOVER') then ekt = gasconst * kelvin nc = 5 ns = 3 dtc = dt / dble(nc) w(1) = 1.0d0 / (2.0d0-2.0d0**(1.0d0/3.0d0)) w(2) = 1.0d0 - 2.0d0*w(1) w(3) = w(1) scale = 1.0d0 do i = 1, nc do j = 1, ns dts = w(j) * dtc dt2 = 0.5d0 * dts dt4 = 0.25d0 * dts dt8 = 0.125d0 * dts gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4) vnh(4) = vnh(4) + gnh(4)*dt4 gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3) expterm = exp(-vnh(4)*dt8) vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4) gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2) expterm = exp(-vnh(3)*dt8) vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4) gnh(1) = (2.0d0*eksum-dble(nfree)*ekt) / qnh(1) expterm = exp(-vnh(2)*dt8) vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4) expterm = exp(-vnh(1)*dt2) scale = scale * expterm eksum = eksum * expterm * expterm gnh(1) = (2.0d0*eksum-dble(nfree)*ekt) / qnh(1) expterm = exp(-vnh(2)*dt8) vnh(1) = expterm * (vnh(1)*expterm+gnh(1)*dt4) gnh(2) = (qnh(1)*vnh(1)*vnh(1)-ekt) / qnh(2) expterm = exp(-vnh(3)*dt8) vnh(2) = expterm * (vnh(2)*expterm+gnh(2)*dt4) gnh(3) = (qnh(2)*vnh(2)*vnh(2)-ekt) / qnh(3) expterm = exp(-vnh(4)*dt8) vnh(3) = expterm * (vnh(3)*expterm+gnh(3)*dt4) gnh(4) = (qnh(3)*vnh(3)*vnh(3)-ekt) / qnh(4) vnh(4) = vnh(4) + gnh(4)*dt4 end do end do if (integrate .eq. 'RIGIDBODY') then do i = 1, ngrp do j = 1, 3 vcm(j,i) = scale * vcm(j,i) wcm(j,i) = scale * wcm(j,i) end do end do else do i = 1, nuse k = iuse(i) do j = 1, 3 v(j,k) = scale * v(j,k) end do end do end if call kinetic (eksum,ekin,temp) end if c c use Berendsen scaling for iEL auxiliary dipole velocities c if (use_ielscf) then call kinaux (temp_aux,temp_auxp) scale = 1.0d0 scalep = 1.0d0 if (temp_aux .ne. 0.0d0) then scale = sqrt(1.0d0+(dt/tautemp_aux) & *(kelvin_aux/temp_aux-1.0d0)) end if if (temp_auxp .ne. 0.0d0) then scalep = sqrt(1.0d0+(dt/tautemp_aux) & *(kelvin_aux/temp_auxp-1.0d0)) end if do i = 1, nuse k = iuse(i) do j = 1, 3 vaux(j,k) = scale * vaux(j,k) vpaux(j,k) = scalep * vpaux(j,k) 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 ## program testgrad -- derivative test; Cartesian version ## c ## ## c ################################################################ c c c "testgrad" computes and compares the analytical and numerical c gradient vectors of the potential energy function with respect c to Cartesian coordinates c c program testgrad use atoms use deriv use energi use files use inform use inter use iounit use solpot use usage implicit none integer i,j,ixyz integer next,frame integer freeunit real*8 etot,f,f0,eps,eps0,old,energy real*8 eb0,ea0,eba0,eub0,eaa0,eopb0 real*8 eopd0,eid0,eit0,et0,ept0,ebt0 real*8 eat0,ett0,ev0,er0,edsp0,ec0 real*8 ecd0,ed0,em0,ep0,ect0,erxf0 real*8 es0,elf0,eg0,ex0 real*8 totnorm,ntotnorm,rms,nrms real*8, allocatable :: denorm(:) real*8, allocatable :: ndenorm(:) real*8, allocatable :: detot(:,:) real*8, allocatable :: ndetot(:,:) real*8, allocatable :: ndeb(:,:) real*8, allocatable :: ndea(:,:) real*8, allocatable :: ndeba(:,:) real*8, allocatable :: ndeub(:,:) real*8, allocatable :: ndeaa(:,:) real*8, allocatable :: ndeopb(:,:) real*8, allocatable :: ndeopd(:,:) real*8, allocatable :: ndeid(:,:) real*8, allocatable :: ndeit(:,:) real*8, allocatable :: ndet(:,:) real*8, allocatable :: ndept(:,:) real*8, allocatable :: ndebt(:,:) real*8, allocatable :: ndeat(:,:) real*8, allocatable :: ndett(:,:) real*8, allocatable :: ndev(:,:) real*8, allocatable :: nder(:,:) real*8, allocatable :: ndedsp(:,:) real*8, allocatable :: ndec(:,:) real*8, allocatable :: ndecd(:,:) real*8, allocatable :: nded(:,:) real*8, allocatable :: ndem(:,:) real*8, allocatable :: ndep(:,:) real*8, allocatable :: ndect(:,:) real*8, allocatable :: nderxf(:,:) real*8, allocatable :: ndes(:,:) real*8, allocatable :: ndelf(:,:) real*8, allocatable :: ndeg(:,:) real*8, allocatable :: ndex(:,:) logical exist,query logical doanalyt,donumer,dofull character*1 answer character*1 axis(3) character*240 xyzfile character*240 record character*240 string data axis / 'X','Y','Z' / c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c decide whether to do an analytical gradient calculation c doanalyt = .true. call nextarg (answer,exist) if (.not. exist) then write (iout,10) 10 format (/,' Compute the Analytical Gradient Vector [Y] : ',$) read (input,20) record 20 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'N') doanalyt = .false. c c decide whether to do a numerical gradient calculation c donumer = .true. call nextarg (answer,exist) if (.not. exist) then write (iout,30) 30 format (/,' Compute the Numerical Gradient Vector [Y] : ',$) read (input,40) record 40 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'N') donumer = .false. c c get the stepsize for numerical gradient calculation c if (donumer) then eps = -1.0d0 eps0 = 0.00001d0 if (solvtyp.eq.'GK' .or. solvtyp.eq.'PB') eps0 = 0.001d0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=50,end=50) eps query = .false. end if 50 continue if (query) then write (iout,60) eps0 60 format (/,' Enter Finite Difference Stepsize [',d8.1, & ' Ang] : ',$) read (input,70,err=50) eps 70 format (f20.0) end if if (eps .le. 0.0d0) eps = eps0 end if c c decide whether to output results by gradient component c dofull = .true. if (n .gt. 100) then dofull = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,80) 80 format (/,' Output Breakdown by Gradient Component', & ' [N] : ',$) read (input,90) record 90 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') dofull = .true. end if c c reopen the coordinates file and read the first structure c frame = 0 ixyz = freeunit () xyzfile = filename call suffix (xyzfile,'xyz','old') open (unit=ixyz,file=xyzfile,status ='old') rewind (unit=ixyz) call readxyz (ixyz) c c perform dynamic allocation of some local arrays c allocate (denorm(n)) allocate (detot(3,n)) if (donumer) then allocate (ndenorm(n)) allocate (ndetot(3,n)) allocate (ndeb(3,n)) allocate (ndea(3,n)) allocate (ndeba(3,n)) allocate (ndeub(3,n)) allocate (ndeaa(3,n)) allocate (ndeopb(3,n)) allocate (ndeopd(3,n)) allocate (ndeid(3,n)) allocate (ndeit(3,n)) allocate (ndet(3,n)) allocate (ndept(3,n)) allocate (ndebt(3,n)) allocate (ndeat(3,n)) allocate (ndett(3,n)) allocate (ndev(3,n)) allocate (nder(3,n)) allocate (ndedsp(3,n)) allocate (ndec(3,n)) allocate (ndecd(3,n)) allocate (nded(3,n)) allocate (ndem(3,n)) allocate (ndep(3,n)) allocate (ndect(3,n)) allocate (nderxf(3,n)) allocate (ndes(3,n)) allocate (ndelf(3,n)) allocate (ndeg(3,n)) allocate (ndex(3,n)) end if c c perform analysis for each successive coordinate structure c do while (.not. abort) frame = frame + 1 if (frame .gt. 1) then write (iout,100) frame 100 format (/,' Analysis for Archive Structure :',8x,i8) end if c c compute the analytical gradient components c if (doanalyt) then call gradient (etot,detot) end if c c print the total potential energy of the system c if (doanalyt) then if (digits .ge. 8) then write (iout,110) etot 110 format (/,' Total Potential Energy :',8x,f20.8, & ' Kcal/mole') else if (digits .ge. 6) then write (iout,120) etot 120 format (/,' Total Potential Energy :',8x,f18.6, & ' Kcal/mole') else write (iout,130) etot 130 format (/,' Total Potential Energy :',8x,f16.4, & ' Kcal/mole') end if c c print the energy breakdown over individual components c write (iout,140) 140 format (/,' Potential Energy Breakdown by Individual', & ' Components :') if (digits .ge. 8) then write (iout,150) 150 format (/,' Energy',7x,'EB',14x,'EA',14x,'EBA', & 13x,'EUB', & /,' Terms',8x,'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') write (iout,160) 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 160 format (/,6x,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 write (iout,170) 170 format (/,' Energy',6x,'EB',12x,'EA',12x,'EBA', & 11x,'EUB',11x,'EAA', & /,' Terms',7x,'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') write (iout,180) 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 180 format (/,6x,5f14.6,/,6x,5f14.6,/,6x,5f14.6,/,6x,5f14.6, & /,6x,5f14.6,/,6x,3f14.6) else write (iout,190) 190 format (/,' Energy',6x,'EB',10x,'EA',10x,'EBA', & 9x,'EUB',9x,'EAA',9x,'EOPB', & /,' Terms',7x,'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') write (iout,200) 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 200 format (/,6x,6f12.4,/,6x,6f12.4,/,6x,6f12.4,/,6x,6f12.4, & /,6x,4f12.4) end if end if c c print a header for the gradients of individual potentials c if (dofull) then write (iout,210) 210 format (/,' Cartesian Gradient Breakdown by Individual', & ' Components :') if (digits .ge. 8) then write (iout,220) 220 format (/,2x,'Atom',9x,'d EB',12x,'d EA',12x,'d EBA', & 11x,'d EUB', & /,2x,'Axis',9x,'d EAA',11x,'d EOPB',10x,'d EOPD', & 10x,'d EID', & /,2x,'Type',9x,'d EIT',11x,'d ET',12x,'d EPT', & 11x,'d EBT', & /,15x,'d EAT',11x,'d ETT',11x,'d EV',12x,'d ER', & /,15x,'d EDSP',10x,'d EC',12x,'d ECD',11x,'d ED', & /,15x,'d EM',12x,'d EP',12x,'d ECT',11x,'d ERXF', & /,15x,'d ES',12x,'d ELF',11x,'d EG',12x,'d EX') else if (digits .ge. 6) then write (iout,230) 230 format (/,2x,'Atom',8x,'d EB',10x,'d EA',10x,'d EBA', & 9x,'d EUB',9x,'d EAA', & /,2x,'Axis',8x,'d EOPB',8x,'d EOPD',8x,'d EID', & 9x,'d EIT',9x,'d ET', & /,2x,'Type',8x,'d EPT',9x,'d EBT',9x,'d EAT', & 9x,'d ETT',9x,'d EV', & /,14x,'d ER',10x,'d EDSP',8x,'d EC',10x,'d ECD', & 9x,'d ED', & /,14x,'d EM',10x,'d EP',10x,'d ECT',9x,'d ERXF', & 8x,'d ES', & /,14x,'d ELF',9x,'d EG',10x,'d EX') else write (iout,240) 240 format (/,2x,'Atom',6x,'d EB',8x,'d EA',8x,'d EBA', & 7x,'d EUB',7x,'d EAA',7x,'d EOPB', & /,2x,'Axis',6x,'d EOPD',6x,'d EID',7x,'d EIT', & 7x,'d ET',8x,'d EPT',7x,'d EBT', & /,2x,'Type',6x,'d EAT',7x,'d ETT',7x,'d EV', & 8x,'d ER',8x,'d EDSP',6x,'d EC', & /,12x,'d ECD',7x,'d ED',8x,'d EM',8x,'d EP', & 8x,'d ECT',7x,'d ERXF', & /,12x,'d ES',8x,'d ELF',7x,'d EG',8x,'d EX') end if end if c c get the Cartesian component two-sided numerical gradients c do i = 1, n if (donumer .and. use(i)) then do j = 1, 3 if (j .eq. 1) then old = x(i) x(i) = x(i) - 0.5d0*eps else if (j .eq. 2) then old = y(i) y(i) = y(i) - 0.5d0*eps else if (j .eq. 3) then old = z(i) z(i) = z(i) - 0.5d0*eps end if f0 = energy () eb0 = eb ea0 = ea eba0 = eba eub0 = eub eaa0 = eaa eopb0 = eopb eopd0 = eopd eid0 = eid eit0 = eit et0 = et ept0 = ept ebt0 = ebt eat0 = eat ett0 = ett ev0 = ev er0 = er edsp0 = edsp ec0 = ec ecd0 = ecd ed0 = ed em0 = em ep0 = ep ect0 = ect erxf0 = erxf es0 = es elf0 = elf eg0 = eg ex0 = ex if (j .eq. 1) then x(i) = x(i) + eps else if (j .eq. 2) then y(i) = y(i) + eps else if (j .eq. 3) then z(i) = z(i) + eps end if f = energy () if (j .eq. 1) then x(i) = old else if (j .eq. 2) then y(i) = old else if (j .eq. 3) then z(i) = old end if ndetot(j,i) = (f - f0) / eps ndeb(j,i) = (eb - eb0) / eps ndea(j,i) = (ea - ea0) / eps ndeba(j,i) = (eba - eba0) / eps ndeub(j,i) = (eub - eub0) / eps ndeaa(j,i) = (eaa - eaa0) / eps ndeopb(j,i) = (eopb - eopb0) / eps ndeopd(j,i) = (eopd - eopd0) / eps ndeid(j,i) = (eid - eid0) / eps ndeit(j,i) = (eit - eit0) / eps ndet(j,i) = (et - et0) / eps ndept(j,i) = (ept - ept0) / eps ndebt(j,i) = (ebt - ebt0) / eps ndeat(j,i) = (eat - eat0) / eps ndett(j,i) = (ett - ett0) / eps ndev(j,i) = (ev - ev0) / eps nder(j,i) = (er - er0) / eps ndedsp(j,i) = (edsp - edsp0) / eps ndec(j,i) = (ec - ec0) / eps ndecd(j,i) = (ecd - ecd0) / eps nded(j,i) = (ed - ed0) / eps ndem(j,i) = (em - em0) / eps ndep(j,i) = (ep - ep0) / eps ndect(j,i) = (ect - ect0) / eps nderxf(j,i) = (erxf - erxf0) / eps ndes(j,i) = (es - es0) / eps ndelf(j,i) = (elf - elf0) / eps ndeg(j,i) = (eg - eg0) / eps ndex(j,i) = (ex - ex0) / eps end do end if c c print analytical gradients of each energy term for each atom c if (dofull .and. use(i)) then do j = 1, 3 if (doanalyt) then if (digits .ge. 8) then write (iout,250) i,deb(j,i),dea(j,i),deba(j,i), & deub(j,i),axis(j),deaa(j,i), & deopb(j,i),deopd(j,i), & deid(j,i),deit(j,i),det(j,i), & dept(j,i),debt(j,i),deat(j,i), & dett(j,i),dev(j,i),der(j,i), & dedsp(j,i),dec(j,i),decd(j,i), & ded(j,i),dem(j,i),dep(j,i), & dect(j,i),derxf(j,i), & des(j,i),delf(j,i),deg(j,i), & dex(j,i) 250 format (/,i6,4f16.8,/,5x,a1,4f16.8, & /,' Anlyt',4f16.8,/,6x,4f16.8, & /,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8) else if (digits .ge. 6) then write (iout,260) i,deb(j,i),dea(j,i),deba(j,i), & deub(j,i),deaa(j,i),axis(j), & deopb(j,i),deopd(j,i), & deid(j,i),deit(j,i),det(j,i), & dept(j,i),debt(j,i),deat(j,i), & dett(j,i),dev(j,i),der(j,i), & dedsp(j,i),dec(j,i),decd(j,i), & ded(j,i),dem(j,i),dep(j,i), & dect(j,i),derxf(j,i), & des(j,i),delf(j,i),deg(j,i), & dex(j,i) 260 format (/,i6,5f14.6,/,5x,a1,5f14.6, & /,' Anlyt',5f14.6,/,6x,5f14.6, & /,6x,5f14.6,/,6x,3f14.6) else write (iout,270) i,deb(j,i),dea(j,i),deba(j,i), & deub(j,i),deaa(j,i), & deopb(j,i),axis(j),deopd(j,i), & deid(j,i),deit(j,i),det(j,i), & dept(j,i),debt(j,i),deat(j,i), & dett(j,i),dev(j,i),der(j,i), & dedsp(j,i),dec(j,i),decd(j,i), & ded(j,i),dem(j,i),dep(j,i), & dect(j,i),derxf(j,i), & des(j,i),delf(j,i),deg(j,i), & dex(j,i) 270 format (/,i6,6f12.4,/,5x,a1,6f12.4, & /,' Anlyt',6f12.4,/,6x,6f12.4, & /,6x,4f12.4) end if end if c c print numerical gradients of each energy term for each atom c if (donumer) then if (digits .ge. 8) then write (iout,280) i,ndeb(j,i),ndea(j,i), & ndeba(j,i),ndeub(j,i), & axis(j),ndeaa(j,i), & ndeopb(j,i),ndeopd(j,i), & ndeid(j,i),ndeit(j,i), & ndet(j,i),ndept(j,i), & ndebt(j,i),ndeat(j,i), & ndett(j,i),ndev(j,i), & nder(j,i),ndedsp(j,i), & ndec(j,i),ndecd(j,i), & nded(j,i),ndem(j,i), & ndep(j,i),ndect(j,i), & nderxf(j,i),ndes(j,i), & ndelf(j,i),ndeg(j,i), & ndex(j,i) 280 format (/,i6,4f16.8,/,5x,a1,4f16.8, & /,' Numer',4f16.8,/,6x,4f16.8, & /,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8) else if (digits .ge. 6) then write (iout,290) i,ndeb(j,i),ndea(j,i), & ndeba(j,i),ndeub(j,i), & ndeaa(j,i),axis(j), & ndeopb(j,i),ndeopd(j,i), & ndeid(j,i),ndeit(j,i), & ndet(j,i),ndept(j,i), & ndebt(j,i),ndeat(j,i), & ndett(j,i),ndev(j,i), & nder(j,i),ndedsp(j,i), & ndec(j,i),ndecd(j,i), & nded(j,i),ndem(j,i), & ndep(j,i),ndect(j,i), & nderxf(j,i),ndes(j,i), & ndelf(j,i),ndeg(j,i), & ndex(j,i) 290 format (/,i6,5f14.6,/,5x,a1,5f14.6, & /,' Numer',5f14.6,/,6x,5f14.6, & /,6x,5f14.6,/,6x,3f14.6) else write (iout,300) i,ndeb(j,i),ndea(j,i), & ndeba(j,i),ndeub(j,i), & ndeaa(j,i),ndeopb(j,i), & axis(j),ndeopd(j,i), & ndeid(j,i),ndeit(j,i), & ndet(j,i),ndept(j,i), & ndebt(j,i),ndeat(j,i), & ndett(j,i),ndev(j,i), & nder(j,i),ndedsp(j,i), & ndec(j,i),ndecd(j,i), & nded(j,i),ndem(j,i), & ndep(j,i),ndect(j,i), & nderxf(j,i),ndes(j,i), & ndelf(j,i),ndeg(j,i), & ndex(j,i) 300 format (/,i6,6f12.4,/,5x,a1,6f12.4, & /,' Numer',6f12.4,/,6x,6f12.4, & /,6x,4f12.4) end if end if end do end if end do c c print the total gradient components for each atom c if (doanalyt .or. donumer) then write (iout,310) 310 format (/,' Cartesian Gradient Breakdown over Individual', & ' Atoms :') if (digits .ge. 8) then write (iout,320) 320 format (/,2x,'Type',4x,'Atom',10x,'dE/dX',11x,'dE/dY', & 11x,'dE/dZ',11x,'Norm',/) else if (digits .ge. 6) then write (iout,330) 330 format (/,2x,'Type',6x,'Atom',11x,'dE/dX',9x,'dE/dY', & 9x,'dE/dZ',11x,'Norm',/) else write (iout,340) 340 format (/,2x,'Type',6x,'Atom',14x,'dE/dX',7x,'dE/dY', & 7x,'dE/dZ',10x,'Norm',/) end if end if totnorm = 0.0d0 ntotnorm = 0.0d0 do i = 1, n if (doanalyt .and. use(i)) then denorm(i) = detot(1,i)**2 + detot(2,i)**2 & + detot(3,i)**2 totnorm = totnorm + denorm(i) denorm(i) = sqrt(denorm(i)) if (digits .ge. 8) then write (iout,350) i,(detot(j,i),j=1,3),denorm(i) 350 format (' Anlyt',i8,1x,3f16.8,f16.8) else if (digits .ge. 6) then write (iout,360) i,(detot(j,i),j=1,3),denorm(i) 360 format (' Anlyt',2x,i8,3x,3f14.6,2x,f14.6) else write (iout,370) i,(detot(j,i),j=1,3),denorm(i) 370 format (' Anlyt',2x,i8,7x,3f12.4,2x,f12.4) end if end if if (donumer .and. use(i)) then ndenorm(i) = ndetot(1,i)**2 + ndetot(2,i)**2 & + ndetot(3,i)**2 ntotnorm = ntotnorm + ndenorm(i) ndenorm(i) = sqrt(ndenorm(i)) if (digits .ge. 8) then write (iout,380) i,(ndetot(j,i),j=1,3),ndenorm(i) 380 format (' Numer',i8,1x,3f16.8,f16.8) else if (digits .ge. 6) then write (iout,390) i,(ndetot(j,i),j=1,3),ndenorm(i) 390 format (' Numer',2x,i8,3x,3f14.6,2x,f14.6) else write (iout,400) i,(ndetot(j,i),j=1,3),ndenorm(i) 400 format (' Numer',2x,i8,7x,3f12.4,2x,f12.4) end if end if end do c c print the total norm for the analytical gradient c if (doanalyt .or. donumer) then write (iout,410) 410 format (/,' Total Gradient Norm and RMS Gradient', & ' per Atom :',/) end if if (doanalyt) then totnorm = sqrt(totnorm) if (digits .ge. 8) then write (iout,420) totnorm 420 format (' Anlyt',6x,'Total Gradient Norm Value', & 6x,f20.8) else if (digits .ge. 6) then write (iout,430) totnorm 430 format (' Anlyt',6x,'Total Gradient Norm Value', & 6x,f18.6) else write (iout,440) totnorm 440 format (' Anlyt',6x,'Total Gradient Norm Value', & 6x,f16.4) end if end if c c print the total norm for the numerical gradient c if (donumer) then ntotnorm = sqrt(ntotnorm) if (digits .ge. 8) then write (iout,450) ntotnorm 450 format (' Numer',6x,'Total Gradient Norm Value', & 6x,f20.8) else if (digits .ge. 6) then write (iout,460) ntotnorm 460 format (' Numer',6x,'Total Gradient Norm Value', & 6x,f18.6) else write (iout,470) ntotnorm 470 format (' Numer',6x,'Total Gradient Norm Value', & 6x,f16.4) end if end if c c print the rms per atom norm for the analytical gradient c if (doanalyt .or. donumer) then write (iout,480) 480 format () end if if (doanalyt) then rms = totnorm / sqrt(dble(nuse)) if (digits .ge. 8) then write (iout,490) rms 490 format (' Anlyt',6x,'RMS Gradient over All Atoms', & 4x,f20.8) else if (digits .ge. 6) then write (iout,500) rms 500 format (' Anlyt',6x,'RMS Gradient over All Atoms', & 4x,f18.6) else write (iout,510) rms 510 format (' Anlyt',6x,'RMS Gradient over All Atoms', & 4x,f16.4) end if end if c c print the rms per atom norm for the numerical gradient c if (donumer) then nrms = ntotnorm / sqrt(dble(nuse)) if (digits .ge. 8) then write (iout,520) nrms 520 format (' Numer',6x,'RMS Gradient over All Atoms', & 4x,f20.8) else if (digits .ge. 6) then write (iout,530) nrms 530 format (' Numer',6x,'RMS Gradient over All Atoms', & 4x,f18.6) else write (iout,540) nrms 540 format (' Numer',6x,'RMS Gradient over All Atoms', & 4x,f16.4) end if end if c c attempt to read next structure from the coordinate file c call readxyz (ixyz) end do c c perform deallocation of some local arrays c deallocate (denorm) deallocate (detot) if (donumer) then deallocate (ndenorm) deallocate (ndetot) deallocate (ndeb) deallocate (ndea) deallocate (ndeba) deallocate (ndeub) deallocate (ndeaa) deallocate (ndeopb) deallocate (ndeopd) deallocate (ndeid) deallocate (ndeit) deallocate (ndet) deallocate (ndept) deallocate (ndebt) deallocate (ndeat) deallocate (ndett) deallocate (ndev) deallocate (nder) deallocate (ndedsp) deallocate (ndec) deallocate (ndecd) deallocate (nded) deallocate (ndem) deallocate (ndep) deallocate (ndect) deallocate (nderxf) deallocate (ndes) deallocate (ndelf) deallocate (ndeg) deallocate (ndex) end if 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 testhess -- Hessian matrix test; cart. version ## c ## ## c ################################################################ c c c "testhess" computes and compares the analytical and numerical c Hessian matrices of the potential energy function with respect c to Cartesian coordinates c c program testhess use atoms use files use hescut use inform use iounit use usage implicit none integer i,j,k,m integer ii,jj integer ixyz,ihes integer index,maxnum integer next,frame integer freeunit integer, allocatable :: hindex(:) integer, allocatable :: hinit(:,:) integer, allocatable :: hstop(:,:) real*8 energy,e,old,eps,eps0 real*8 diff,delta,sum real*8, allocatable :: h(:) real*8, allocatable :: g(:,:) real*8, allocatable :: g0(:,:) real*8, allocatable :: hdiag(:,:) real*8, allocatable :: nhess(:,:,:,:) logical doanalyt,donumer logical dograd,dofull logical exist,query logical identical character*1 answer character*1 axis(3) character*240 xyzfile character*240 hessfile character*240 record character*240 string external energy data axis / 'X','Y','Z' / c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c set difference threshhold via the energy precision c delta = 0.0001d0 if (digits .ge. 6) delta = 0.000001d0 if (digits .ge. 8) delta = 0.00000001d0 c c decide whether to do an analytical Hessian calculation c doanalyt = .true. call nextarg (answer,exist) if (.not. exist) then write (iout,10) 10 format (/,' Compute Analytical Hessian Matrix [Y] : ',$) read (input,20) record 20 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'N') doanalyt = .false. c c decide whether to do a numerical Hessian calculation c donumer = .false. maxnum = 300 if (n .le. maxnum) then donumer = .true. call nextarg (answer,exist) if (.not. exist) then write (iout,30) 30 format (/,' Compute Numerical Hessian Matrix [Y] : ',$) read (input,40) record 40 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'N') donumer = .false. end if c c get numerical Hessian from either gradient or energy c dograd = .true. if (donumer) then call nextarg (answer,exist) if (.not. exist) then write (iout,50) 50 format (/,' Numerical Hessian from Gradient', & ' or Energy [G] : ',$) read (input,60) record 60 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'E') dograd = .false. c c get the stepsize for numerical Hessian calculation c eps = -1.0d0 eps0 = 0.001d0 if (dograd) eps0 = 0.00001d0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=70,end=70) eps query = .false. end if 70 continue if (query) then write (iout,80) eps0 80 format (/,' Enter Finite Difference Stepsize [',d8.1, & ' Ang] : ',$) read (input,90,err=70) eps 90 format (f20.0) end if if (eps .le. 0.0d0) eps = eps0 end if c c decide whether to output results by Hessian component c dofull = .false. if (n.le.20 .and. donumer) then call nextarg (answer,exist) if (.not. exist) then write (iout,100) 100 format (/,' List Individual Hessian Components [N] : ',$) read (input,110) record 110 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') dofull = .true. end if c c reopen the coordinates file and read the first structure c frame = 0 ixyz = freeunit () xyzfile = filename call suffix (xyzfile,'xyz','old') open (unit=ixyz,file=xyzfile,status ='old') rewind (unit=ixyz) call readxyz (ixyz) c c perform dynamic allocation of some local arrays c allocate (hindex(3*n*(3*n-1)/2)) allocate (hinit(3,n)) allocate (hstop(3,n)) allocate (h(3*n*(3*n-1)/2)) allocate (g(3,n)) allocate (g0(3,n)) allocate (hdiag(3,n)) if (n .le. maxnum) allocate (nhess(3,n,3,n)) c c perform analysis for each successive coordinate structure c do while (.not. abort) frame = frame + 1 if (frame .gt. 1) then write (iout,120) frame 120 format (/,' Analysis for Archive Structure :',8x,i8) end if c c get the analytical Hessian matrix elements c identical = .true. if (doanalyt) then if (verbose) then write (iout,130) 130 format () end if hesscut = 0.0d0 call hessian (h,hinit,hstop,hindex,hdiag) end if c c get the two-sided numerical Hessian matrix elements c do i = 1, n if (donumer .and. use(i)) then old = x(i) x(i) = x(i) - 0.5d0*eps if (dograd) then call gradient (e,g) else call numgrad (energy,g,eps) end if do k = 1, n do j = 1, 3 g0(j,k) = g(j,k) end do end do x(i) = x(i) + eps if (dograd) then call gradient (e,g) else call numgrad (energy,g,eps) end if x(i) = old do k = 1, n do j = 1, 3 nhess(j,k,1,i) = (g(j,k)-g0(j,k)) / eps end do end do old = y(i) y(i) = y(i) - 0.5d0*eps if (dograd) then call gradient (e,g) else call numgrad (energy,g,eps) end if do k = 1, n do j = 1, 3 g0(j,k) = g(j,k) end do end do y(i) = y(i) + eps if (dograd) then call gradient (e,g) else call numgrad (energy,g,eps) end if y(i) = old do k = 1, n do j = 1, 3 nhess(j,k,2,i) = (g(j,k)-g0(j,k)) / eps end do end do old = z(i) z(i) = z(i) - 0.5d0*eps if (dograd) then call gradient (e,g) else call numgrad (energy,g,eps) end if do k = 1, n do j = 1, 3 g0(j,k) = g(j,k) end do end do z(i) = z(i) + eps if (dograd) then call gradient (e,g) else call numgrad (energy,g,eps) end if z(i) = old do k = 1, n do j = 1, 3 nhess(j,k,3,i) = (g(j,k)-g0(j,k)) / eps end do end do end if c c compare the analytical and numerical diagonal elements c if (doanalyt .and. donumer) then do j = 1, 3 diff = abs(hdiag(j,i)-nhess(j,i,j,i)) if (diff .gt. delta) then if (identical) then identical = .false. write (iout,140) 140 format (/,' Comparison of Analytical and', & ' Numerical Hessian Elements :', & //,3x,'1st Atom',4x,'2nd Atom', & 9x,'Analytical',8x,'Numerical', & 7x,'Difference',/) end if if (digits .ge. 8) then write (iout,150) i,axis(j),i,axis(j), & hdiag(j,i),nhess(j,i,j,i), & hdiag(j,i)-nhess(j,i,j,i) 150 format (1x,i6,' (',a1,') ',1x,i6,' (', & a1,') ',1x,3f17.8) else if (digits .ge. 6) then write (iout,160) i,axis(j),i,axis(j), & hdiag(j,i),nhess(j,i,j,i), & hdiag(j,i)-nhess(j,i,j,i) 160 format (1x,i6,' (',a1,') ',1x,i6,' (', & a1,') ',1x,3f17.6) else write (iout,170) i,axis(j),i,axis(j), & hdiag(j,i),nhess(j,i,j,i), & hdiag(j,i)-nhess(j,i,j,i) 170 format (1x,i6,' (',a1,') ',1x,i6,' (', & a1,') ',1x,3f17.4) end if end if c c compare the analytical and numerical off-diagonal elements c do k = hinit(j,i), hstop(j,i) index = hindex(k) jj = mod(index,3) if (jj .eq. 0) jj = 3 ii = (index+2) / 3 diff = abs(h(k)-nhess(jj,ii,j,i)) if (diff .gt. delta) then if (identical) then identical = .false. write (iout,180) 180 format (/,' Comparison of Analytical and', & ' Numerical Hessian Elements :', & //,3x,'1st Atom',4x,'2nd Atom', & 9x,'Analytical',8x,'Numerical', & 7x,'Difference',/) end if if (digits .ge. 8) then write (iout,190) i,axis(j),ii,axis(jj), & h(k),nhess(jj,ii,j,i), & h(k)-nhess(jj,ii,j,i) 190 format (1x,i6,' (',a1,') ',1x,i6,' (', & a1,') ',1x,3f17.8) else if (digits .ge. 6) then write (iout,200) i,axis(j),ii,axis(jj), & h(k),nhess(jj,ii,j,i), & h(k)-nhess(jj,ii,j,i) 200 format (1x,i6,' (',a1,') ',1x,i6,' (', & a1,') ',1x,3f17.6) else write (iout,210) i,axis(j),ii,axis(jj), & h(k),nhess(jj,ii,j,i), & h(k)-nhess(jj,ii,j,i) 210 format (1x,i6,' (',a1,') ',1x,i6,' (', & a1,') ',1x,3f17.4) end if end if end do end do end if end do c c success if the analytical and numerical elements are the same c if (doanalyt .and. donumer) then if (identical) then write (iout,220) 220 format (/,' Analytical and Numerical Hessian Elements', & ' are Identical') end if end if c c write out the diagonal Hessian elements for each atom c if (doanalyt) then if (digits .ge. 8) then write (iout,230) 230 format (/,' Diagonal Hessian Elements for Each Atom :', & //,6x,'Atom',21x,'X',19x,'Y',19x,'Z',/) else if (digits .ge. 6) then write (iout,240) 240 format (/,' Diagonal Hessian Elements for Each Atom :', & //,6x,'Atom',19x,'X',17x,'Y',17x,'Z',/) else write (iout,250) 250 format (/,' Diagonal Hessian Elements for Each Atom :', & //,6x,'Atom',17x,'X',15x,'Y',15x,'Z',/) end if do i = 1, n if (digits .ge. 8) then write (iout,260) i,(hdiag(j,i),j=1,3) 260 format (i10,5x,3f20.8) else if (digits .ge. 6) then write (iout,270) i,(hdiag(j,i),j=1,3) 270 format (i10,5x,3f18.6) else write (iout,280) i,(hdiag(j,i),j=1,3) 280 format (i10,5x,3f16.4) end if end do end if c c write out the Hessian trace as sum of diagonal elements c if (doanalyt) then sum = 0.0d0 do i = 1, n do j = 1, 3 sum = sum + hdiag(j,i) end do end do if (digits .ge. 8) then write (iout,290) sum 290 format (/,' Sum of Diagonal Hessian Elements :',8x,f20.8) else if (digits .ge. 6) then write (iout,300) sum 300 format (/,' Sum of Diagonal Hessian Elements :',8x,f18.6) else write (iout,310) sum 310 format (/,' Sum of Diagonal Hessian Elements :',8x,f16.4) end if end if c c write out the full matrix of numerical Hessian elements c if (dofull .and. donumer) then do i = 1, n do k = 1, n write (iout,320) i,k 320 format (/,' 3x3 Hessian Block for Atoms :',3x,2i8,/) do j = 1, 3 if (digits .ge. 8) then write (iout,330) (nhess(m,i,j,k),m=1,3) 330 format (' Numer',5x,3f20.8) else if (digits .ge. 6) then write (iout,340) (nhess(m,i,j,k),m=1,3) 340 format (' Numer',5x,3f18.6) else write (iout,350) (nhess(m,i,j,k),m=1,3) 350 format (' Numer',5x,3f16.4) end if end do end do end do end if c c write out the full matrix of analytical Hessian elements c if (doanalyt .and. .not.donumer) then ihes = freeunit () hessfile = filename(1:leng)//'.hes' call version (hessfile,'new') open (unit=ihes,file=hessfile,status='new') write (iout,360) hessfile 360 format (/,' Hessian Matrix written to File : ',a40) write (ihes,370) 370 format (/,' Diagonal Hessian Elements (3 per Atom)',/) if (digits .ge. 8) then write (ihes,380) ((hdiag(j,i),j=1,3),i=1,n) 380 format (4f16.8) else if (digits .ge. 6) then write (ihes,390) ((hdiag(j,i),j=1,3),i=1,n) 390 format (5f14.6) else write (ihes,400) ((hdiag(j,i),j=1,3),i=1,n) 400 format (6f12.4) end if do i = 1, n do j = 1, 3 if (hinit(j,i) .le. hstop(j,i)) then write (ihes,410) i,axis(j) 410 format (/,' Off-diagonal Hessian Elements for Atom' &, i6,1x,a1,/) if (digits .ge. 8) then write (ihes,420) (h(k),k=hinit(j,i),hstop(j,i)) 420 format (4f16.8) else if (digits .ge. 6) then write (ihes,430) (h(k),k=hinit(j,i),hstop(j,i)) 430 format (5f14.6) else write (ihes,440) (h(k),k=hinit(j,i),hstop(j,i)) 440 format (6f12.4) end if end if end do end do close (unit=ihes) end if c c attempt to read next structure from the coordinate file c call readxyz (ixyz) end do c c perform deallocation of some local arrays c deallocate (hindex) deallocate (hinit) deallocate (hstop) deallocate (h) deallocate (g) deallocate (g0) deallocate (hdiag) if (allocated(nhess)) deallocate (nhess) 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 ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## program testpair -- time various neighbor pair schemes ## c ## ## c ################################################################ c c c "testpair" performs a set of timing tests to compare the c evaluation of potential energy and energy/gradient using c different methods for finding pairwise neighbors c c program testpair use atoms use deriv use energi use inform use iounit use light use neigh use potent use vdwpot implicit none integer i,j,k,m integer kgy,kgz integer start,stop integer ncalls,lmax integer npair,nterm real*8 xi,yi,zi real*8 xr,yr,zr,r2 real*8 wall,cpu,delta real*8 vrms,erms real*8 off,off2 real*8 eloop,elight,elist real*8, allocatable :: xsort(:) real*8, allocatable :: ysort(:) real*8, allocatable :: zsort(:) real*8, allocatable :: gloop(:,:) real*8, allocatable :: glight(:,:) real*8, allocatable :: glist(:,:) logical exist,query logical header,match logical unique,repeat character*1 axis(3) character*6 mode character*240 string data axis / 'X','Y','Z' / c c c read the molecular system and setup molecular mechanics c call initial call getxyz call mechanic c c set difference threshhold via the energy precision c delta = 1.0d-4 if (digits .ge. 6) delta = 1.0d-6 if (digits .ge. 8) delta = 1.0d-8 c c get the number of calculation cycles to be performed c ncalls = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) ncalls query = .false. end if 10 continue if (query) then write (iout,20) 20 format (/,' Enter Desired Number of Repetitions [1] : ',$) read (input,30,err=10) ncalls 30 format (i10) end if if (ncalls .eq. 0) ncalls = 1 c c initialize number of pairs and generic cutoff distance c npair = 0 nterm = 0 if (use_vdw) nterm = nterm + 1 if (use_repel) nterm = nterm + 1 if (use_disp) nterm = nterm + 1 if (use_charge) nterm = nterm + 1 if (use_chgdpl) nterm = nterm + 1 if (use_dipole) nterm = nterm + 1 if (use_mpole) nterm = nterm + 1 if (use_polar) nterm = nterm + 1 if (use_chgtrn) nterm = nterm + 1 nterm = nterm * ncalls off = 5.0d0 off2 = off * off c c perform dynamic allocation of some local arrays c lmax = 8 * n allocate (xsort(lmax)) allocate (ysort(lmax)) allocate (zsort(lmax)) allocate (gloop(3,n)) allocate (glight(3,n)) allocate (glist(3,n)) c c get the timing for setup of double nested loop c mode = 'LOOP' call setpair (mode) call settime do m = 1, nterm do i = 1, n-1 xi = x(i) yi = y(i) zi = z(i) do j = i+1, n xr = x(j) - xi yr = y(j) - yi zr = z(j) - zi call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .lt. off2) npair = npair + 1 end do end do end do call gettime (wall,cpu) write (iout,40) ncalls 40 format (/,' Total Wall Clock and CPU Time in Seconds for', & i6,' Evaluations :') write (iout,50) 50 format (/,' Computation Overhead',8x,'Wall',8x,'CPU') write (iout,60) wall,cpu 60 format (/,' Double Nested Loop',3x,2f11.3) c c get the timing for setup of method of lights c mode = 'LIGHTS' call setpair (mode) call settime unique = .true. do m = 1, nterm do i = 1, n xsort(i) = x(i) ysort(i) = y(i) zsort(i) = z(i) end do call lights (off,n,xsort,ysort,zsort,unique) do i = 1, n xi = xsort(rgx(i)) yi = ysort(rgy(i)) zi = zsort(rgz(i)) if (kbx(i) .le. kex(i)) then repeat = .false. start = kbx(i) + 1 stop = kex(i) else repeat = .true. start = 1 stop = kex(i) end if 70 continue do j = start, stop k = locx(j) kgy = rgy(k) if (kby(i) .le. key(i)) then if (kgy.lt.kby(i) .or. kgy.gt.key(i)) goto 80 else if (kgy.lt.kby(i) .and. kgy.gt.key(i)) goto 80 end if kgz = rgz(k) if (kbz(i) .le. kez(i)) then if (kgz.lt.kbz(i) .or. kgz.gt.kez(i)) goto 80 else if (kgz.lt.kbz(i) .and. kgz.gt.kez(i)) goto 80 end if xr = xi - xsort(j) yr = yi - ysort(kgy) zr = zi - zsort(kgz) call image (xr,yr,zr) r2 = xr*xr + yr*yr + zr*zr if (r2 .lt. off2) npair = npair + 1 80 continue end do if (repeat) then repeat = .false. start = kbx(i) + 1 stop = nlight goto 70 end if end do end do call gettime (wall,cpu) write (iout,90) wall,cpu 90 format (' Method of Lights',5x,2f11.3) if (npair .lt. 0) call fatal c c get the timing for setup of pair neighbor list c mode = 'LIST' call setpair (mode) call settime do m = 1, ncalls dovlst = .true. dodlst = .true. doclst = .true. domlst = .true. doulst = .true. call nblist end do call gettime (wall,cpu) write (iout,100) wall,cpu 100 format (' Pair Neighbor List',3x,2f11.3) c c perform dynamic allocation of some global arrays c allocate (dev(3,n)) allocate (der(3,n)) allocate (dedsp(3,n)) allocate (dec(3,n)) allocate (decd(3,n)) allocate (ded(3,n)) allocate (dem(3,n)) allocate (dep(3,n)) allocate (dect(3,n)) c c zero out each of the energy and gradient components c 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 do i = 1, n do j = 1, 3 dev(j,i) = 0.0d0 der(j,i) = 0.0d0 dedsp(j,i) = 0.0d0 dec(j,i) = 0.0d0 decd(j,i) = 0.0d0 ded(j,i) = 0.0d0 dem(j,i) = 0.0d0 dep(j,i) = 0.0d0 dect(j,i) = 0.0d0 end do end do c c get the timing for energy terms via double nested loop c mode = 'LOOP' call setpair (mode) call settime do k = 1, ncalls if (use_vdw) then if (vdwtyp .eq. 'LENNARD-JONES') call elj if (vdwtyp .eq. 'BUCKINGHAM') call ebuck if (vdwtyp .eq. 'MM3-HBOND') call emm3hb if (vdwtyp .eq. 'BUFFERED-14-7') call ehal if (vdwtyp .eq. 'GAUSSIAN') call egauss end if if (use_repel) call erepel if (use_disp) call edisp if (use_charge) call echarge if (use_chgdpl) call echgdpl if (use_dipole) call edipole if (use_mpole) call empole if (use_polar) call epolar if (use_chgtrn) call echgtrn end do call gettime (wall,cpu) write (iout,110) 110 format (/,' Potential Energy Only',7x,'Wall',8x,'CPU', & 13x,'Evdw',11x,'Eelect') eloop = ev + er + edsp + ec + ecd + ed + em + ep + ect if (digits .ge. 8) then write (iout,120) wall,cpu,ev+er+edsp,eloop-ev-er-edsp 120 format (/,' Double Nested Loop',3x,2f11.3,2f17.8) else if (digits .ge. 6) then write (iout,130) wall,cpu,ev+er+edsp,eloop-ev-er-edsp 130 format (/,' Double Nested Loop',3x,2f11.3,2f17.6) else write (iout,140) wall,cpu,ev+er+edsp,eloop-ev-er-edsp 140 format (/,' Double Nested Loop',3x,2f11.3,2f17.4) end if c c get the timing for energy terms via method of lights c mode = 'LIGHTS' call setpair (mode) call settime do k = 1, ncalls if (use_vdw) then if (vdwtyp .eq. 'LENNARD-JONES') call elj if (vdwtyp .eq. 'BUCKINGHAM') call ebuck if (vdwtyp .eq. 'MM3-HBOND') call emm3hb if (vdwtyp .eq. 'BUFFERED-14-7') call ehal if (vdwtyp .eq. 'GAUSSIAN') call egauss end if if (use_repel) call erepel if (use_disp) call edisp if (use_charge) call echarge if (use_chgdpl) call echgdpl if (use_dipole) call edipole if (use_mpole) call empole if (use_polar) call epolar if (use_chgtrn) call echgtrn end do call gettime (wall,cpu) elight = ev + er + edsp + ec + ecd + ed + em + ep + ect if (digits .ge. 8) then write (iout,150) wall,cpu,ev+er+edsp,elight-ev-er-edsp 150 format (' Method of Lights',5x,2f11.3,2f17.8) else if (digits .ge. 6) then write (iout,160) wall,cpu,ev+er+edsp,elight-ev-er-edsp 160 format (' Method of Lights',5x,2f11.3,2f17.6) else write (iout,170) wall,cpu,ev+er+edsp,elight-ev-er-edsp 170 format (' Method of Lights',5x,2f11.3,2f17.4) end if c c get the timing for energy terms via pair neighbor list c mode = 'LIST' call setpair (mode) call settime do k = 1, ncalls if (use_vdw) then if (vdwtyp .eq. 'LENNARD-JONES') call elj if (vdwtyp .eq. 'BUCKINGHAM') call ebuck if (vdwtyp .eq. 'MM3-HBOND') call emm3hb if (vdwtyp .eq. 'BUFFERED-14-7') call ehal if (vdwtyp .eq. 'GAUSSIAN') call egauss end if if (use_repel) call erepel if (use_disp) call edisp if (use_charge) call echarge if (use_chgdpl) call echgdpl if (use_dipole) call edipole if (use_mpole) call empole if (use_polar) call epolar if (use_chgtrn) call echgtrn end do call gettime (wall,cpu) elist = ev + er + edsp + ec + ecd + ed + em + ep + ect if (digits .ge. 8) then write (iout,180) wall,cpu,ev+er+edsp,elist-ev-er-edsp 180 format (' Pair Neighbor List',3x,2f11.3,2f17.8) else if (digits .ge. 6) then write (iout,190) wall,cpu,ev+er+edsp,elist-ev-er-edsp 190 format (' Pair Neighbor List',3x,2f11.3,2f17.6) else write (iout,200) wall,cpu,ev+er+edsp,elist-ev-er-edsp 200 format (' Pair Neighbor List',3x,2f11.3,2f17.4) end if c c compare the nonbond energies from the various methods c match = .true. if (abs(elight-eloop).gt.delta .or. abs(elist-eloop).gt.delta) & match = .false. if (match) then write (iout,210) 210 format (/,' Energies Computed via all Neighbor Methods', & ' are Identical') end if c c get the timing for gradient via double nested loop c mode = 'LOOP' call setpair (mode) call settime do k = 1, ncalls if (use_vdw) then if (vdwtyp .eq. 'LENNARD-JONES') call elj1 if (vdwtyp .eq. 'BUCKINGHAM') call ebuck1 if (vdwtyp .eq. 'MM3-HBOND') call emm3hb1 if (vdwtyp .eq. 'BUFFERED-14-7') call ehal1 if (vdwtyp .eq. 'GAUSSIAN') call egauss1 end if if (use_repel) call erepel1 if (use_disp) call edisp1 if (use_charge) call echarge1 if (use_chgdpl) call echgdpl1 if (use_dipole) call edipole1 if (use_mpole) call empole1 if (use_polar) call epolar1 if (use_chgtrn) call echgtrn1 end do call gettime (wall,cpu) c c store the double loop gradient and get rms values c vrms = 0.0d0 erms = 0.0d0 do i = 1, n do j = 1, 3 gloop(j,i) = dev(j,i) + der(j,i) + dedsp(j,i) & + dec(j,i) + decd(j,i) + ded(j,i) & + dem(j,i) + dep(j,i) + dect(j,i) vrms = vrms + dev(j,i)**2 + der(j,i)**2 + dedsp(j,i)**2 erms = erms + dec(j,i)**2 + decd(j,i)**2 + ded(j,i)**2 & + dem(j,i)**2 + dep(j,i)**2 + dect(j,i)**2 end do end do vrms = sqrt(vrms/dble(n)) erms = sqrt(erms/dble(n)) write (iout,220) 220 format (/,' Energy and Gradient',9x,'Wall',8x,'CPU', & 13x,'Dvdw',11x,'Delect') if (digits .ge. 8) then write (iout,230) wall,cpu,vrms,erms 230 format (/,' Double Nested Loop',3x,2f11.3,2f17.8) else if (digits .ge. 6) then write (iout,240) wall,cpu,vrms,erms 240 format (/,' Double Nested Loop',3x,2f11.3,2f17.6) else write (iout,250) wall,cpu,vrms,erms 250 format (/,' Double Nested Loop',3x,2f11.3,2f17.4) end if c c get the timing for gradient via method of lights c mode = 'LIGHTS' call setpair (mode) call settime do k = 1, ncalls if (use_vdw) then if (vdwtyp .eq. 'LENNARD-JONES') call elj1 if (vdwtyp .eq. 'BUCKINGHAM') call ebuck1 if (vdwtyp .eq. 'MM3-HBOND') call emm3hb1 if (vdwtyp .eq. 'BUFFERED-14-7') call ehal1 if (vdwtyp .eq. 'GAUSSIAN') call egauss1 end if if (use_repel) call erepel1 if (use_disp) call edisp1 if (use_charge) call echarge1 if (use_chgdpl) call echgdpl1 if (use_dipole) call edipole1 if (use_mpole) call empole1 if (use_polar) call epolar1 if (use_chgtrn) call echgtrn1 end do call gettime (wall,cpu) c c store the method of lights gradient and get rms values c vrms = 0.0d0 erms = 0.0d0 do i = 1, n do j = 1, 3 glight(j,i) = dev(j,i) + der(j,i) + dedsp(j,i) & + dec(j,i) + decd(j,i) + ded(j,i) & + dem(j,i) + dep(j,i) + dect(j,i) vrms = vrms + dev(j,i)**2 + der(j,i)**2 + dedsp(j,i)**2 erms = erms + dec(j,i)**2 + decd(j,i)**2 + ded(j,i)**2 & + dem(j,i)**2 + dep(j,i)**2 + dect(j,i)**2 end do end do vrms = sqrt(vrms/dble(n)) erms = sqrt(erms/dble(n)) if (digits .ge. 8) then write (iout,260) wall,cpu,vrms,erms 260 format (' Method of Lights',5x,2f11.3,2f17.8) else if (digits .ge. 6) then write (iout,270) wall,cpu,vrms,erms 270 format (' Method of Lights',5x,2f11.3,2f17.6) else write (iout,280) wall,cpu,vrms,erms 280 format (' Method of Lights',5x,2f11.3,2f17.4) end if c c get the timing for gradient via pair neighbor list c mode = 'LIST' call setpair (mode) call settime do k = 1, ncalls if (use_vdw) then if (vdwtyp .eq. 'LENNARD-JONES') call elj1 if (vdwtyp .eq. 'BUCKINGHAM') call ebuck1 if (vdwtyp .eq. 'MM3-HBOND') call emm3hb1 if (vdwtyp .eq. 'BUFFERED-14-7') call ehal1 if (vdwtyp .eq. 'GAUSSIAN') call egauss1 end if if (use_repel) call erepel1 if (use_disp) call edisp1 if (use_charge) call echarge1 if (use_chgdpl) call echgdpl1 if (use_dipole) call edipole1 if (use_mpole) call empole1 if (use_polar) call epolar1 if (use_chgtrn) call echgtrn1 end do call gettime (wall,cpu) c c get the pair neighbor list gradient rms values c vrms = 0.0d0 erms = 0.0d0 do i = 1, n do j = 1, 3 glist(j,i) = dev(j,i) + der(j,i) + dedsp(j,i) & + dec(j,i) + decd(j,i) + ded(j,i) & + dem(j,i) + dep(j,i) + dect(j,i) vrms = vrms + dev(j,i)**2 + der(j,i)**2 + dedsp(j,i)**2 erms = erms + dec(j,i)**2 + decd(j,i)**2 + ded(j,i)**2 & + dem(j,i)**2 + dep(j,i)**2 + dect(j,i)**2 end do end do vrms = sqrt(vrms/dble(n)) erms = sqrt(erms/dble(n)) if (digits .ge. 8) then write (iout,290) wall,cpu,vrms,erms 290 format (' Pair Neighbor List',3x,2f11.3,2f17.8) else if (digits .ge. 6) then write (iout,300) wall,cpu,vrms,erms 300 format (' Pair Neighbor List',3x,2f11.3,2f17.6) else write (iout,310) wall,cpu,vrms,erms 310 format (' Pair Neighbor List',3x,2f11.3,2f17.4) end if c c compare the nonbond gradients from the various methods c match = .true. header = .true. do i = 1, n do j = 1, 3 if (abs(glight(j,i)-gloop(j,i)).gt.delta .or. & abs(glist(j,i)-gloop(j,i)).gt.delta) then if (header) then match = .false. header = .false. write (iout,320) 320 format (/,' Comparison of Nonbond Gradients from', & ' Different Methods :', & //,11x,'Component',14x,'Loop',12x,'Lights', & 14x,'List',/) end if if (digits .ge. 8) then write (iout,330) i,axis(j),gloop(j,i),glight(j,i), & glist(j,i) 330 format (10x,i6,' (',a1,')',3f18.8) else if (digits .ge. 6) then write (iout,340) i,axis(j),gloop(j,i),glight(j,i), & glist(j,i) 340 format (10x,i6,' (',a1,')',3f18.6) else write (iout,350) i,axis(j),gloop(j,i),glight(j,i), & glist(j,i) 350 format (10x,i6,' (',a1,')',3f18.4) end if end if end do end do if (match) then write (iout,360) 360 format (/,' Gradients Computed via all Methods are Identical') end if c c perform deallocation of some local arrays c deallocate (xsort) deallocate (ysort) deallocate (zsort) deallocate (gloop) deallocate (glight) deallocate (glist) c c perform any final tasks before program exit c call final end c c c ################################################################ c ## ## c ## program setpair -- list setup and cutoffs for testpair ## c ## ## c ################################################################ c c c "setpair" is a service routine that assigns flags, sets cutoffs c and allocates arrays used by different pairwise neighbor methods c c subroutine setpair (mode) use atoms use limits use neigh use polpot use tarray implicit none character*6 mode c c c set control flags to handle use of neighbor lists c if (mode .eq. 'LIST') then use_list = .true. use_vlist = .true. use_dlist = .true. use_clist = .true. use_mlist = .true. use_ulist = .true. dovlst = .true. dodlst = .true. doclst = .true. domlst = .true. doulst = .true. else use_list = .false. use_vlist = .false. use_dlist = .false. use_clist = .false. use_mlist = .false. use_ulist = .false. dovlst = .false. dodlst = .false. doclst = .false. domlst = .false. doulst = .false. end if c c fix the dipole preconditioner cutoff at 4.5 Angstroms c if (mode .eq. 'LOOP') then use_lights = .false. usolvcut = 4.5 else if (mode .eq. 'LIGHTS') then use_lights = .true. usolvcut = 4.5 else if (mode .eq. 'LIST') then use_lights = .false. usolvcut = 4.5 - pbuffer ubuf2 = (usolvcut+pbuffer)**2 ubufx = (usolvcut+2.0d0*pbuffer)**2 end if c c allocate the arrays needed by the pair neighbor lists c if (mode .eq. 'LIST') then if (.not.allocated(nvlst)) allocate (nvlst(n)) if (.not.allocated(vlst)) allocate (vlst(maxvlst,n)) if (.not.allocated(xvold)) allocate (xvold(n)) if (.not.allocated(yvold)) allocate (yvold(n)) if (.not.allocated(zvold)) allocate (zvold(n)) if (.not.allocated(nelst)) allocate (nelst(n)) if (.not.allocated(elst)) allocate (elst(maxelst,n)) if (.not.allocated(xeold)) allocate (xeold(n)) if (.not.allocated(yeold)) allocate (yeold(n)) if (.not.allocated(zeold)) allocate (zeold(n)) if (.not.allocated(nulst)) allocate (nulst(n)) if (.not.allocated(ulst)) allocate (ulst(maxulst,n)) if (.not.allocated(xuold)) allocate (xuold(n)) if (.not.allocated(yuold)) allocate (yuold(n)) if (.not.allocated(zuold)) allocate (zuold(n)) if (poltyp .eq. 'MUTUAL') then if (.not.allocated(tindex)) allocate (tindex(2,n*maxelst)) if (.not.allocated(tdipdip)) & allocate (tdipdip(6,n*maxelst)) end if end if c c generate the pair neighbor lists if they are in use c if (mode .eq. 'LIST') call nblist return end c c c ################################################### c ## COPYRIGHT (C) 2012 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## program testpol -- check convergence of induced dipoles ## c ## ## c ################################################################# c c c "testpol" compares the induced dipoles from direct polarization, c mutual SCF iterations, perturbation theory extrapolation (OPT), c and truncated conjugate gradient (TCG) solvers c c program testpol use atoms use bound use inform use iounit use limits use minima use mpole use polar use polopt use polpot use poltcg use potent use rigid use units use usage implicit none integer i,j,k,m integer next,kpcg integer nvar,size integer itercut integer saveopt integer savetcg integer iter,ntest real*8 sum,epscut real*8 ux,uy,uz,u2 real*8 rdirect,rpcg real*8 rxpt,rtcg real*8 step,delta real*8 optfit real*8, allocatable :: var(:) real*8, allocatable :: rms(:) real*8, allocatable :: drms(:) real*8, allocatable :: tdirect(:) real*8, allocatable :: tpcg(:) real*8, allocatable :: txpt(:) real*8, allocatable :: ttcg(:) real*8, allocatable :: ddirect(:,:) real*8, allocatable :: dpcg(:,:) real*8, allocatable :: dxpt(:,:) real*8, allocatable :: dtcg(:,:) real*8, allocatable :: udirect(:,:) real*8, allocatable :: upcg(:,:) real*8, allocatable :: uxpt(:,:) real*8, allocatable :: utcg(:,:) real*8, allocatable :: ustore(:,:,:) logical exist,done logical dofull logical dofitopt character*1 answer character*1 digit character*6 savetyp character*240 record external optfit c c c get the coordinates and required force field parameters c call initial call getxyz call mechanic if (use_solv) call born c c check to make sure mutual polarization is being used c if (.not. use_polar) then write (iout,10) 10 format (/,' TESTPOL -- Induced Dipole Polarization Model', & ' Not in Use') call fatal end if c c decide whether to output results by gradient component c dofull = .true. if (n .gt. 100) then dofull = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,20) 20 format (/,' Output Induced Dipole Components by Atom', & ' [N] : ',$) read (input,30) record 30 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') dofull = .true. end if c c decide whether to output results by gradient component c dofitopt = .false. call nextarg (answer,exist) if (.not. exist) then write (iout,40) 40 format (/,' Optimize OPT Coefficients for Current System', & ' [N] : ',$) read (input,50) record 50 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') dofitopt = .true. c c maintain any periodic boundary conditions c if (use_bounds .and. .not.use_rigid) call bounds c c store the original polarization type for the system c if (optorder .eq. 0) optorder = 4 if (tcgorder .eq. 0) tcgorder = 2 if (poltyp .eq. 'OPT') then size = 1 call numeral (optorder,digit,size) poltyp = 'OPT'//digit//' ' else if (poltyp .eq. 'TCG') then size = 1 call numeral (tcgorder,digit,size) poltyp = 'TCG'//digit//' ' end if saveopt = optorder savetcg = tcgorder savetyp = poltyp c c generate neighbor lists for iterative SCF solver c poltyp = 'MUTUAL' call cutoffs if (use_list) call nblist c c set tolerances and rotate multipoles to global frame c maxiter = 100 itercut = politer epscut = poleps poleps = 0.0000000001d0 debug = .false. call chkpole call rotpole ('MPOLE') c c perform dynamic allocation of some local arrays c allocate (rms(0:maxiter)) allocate (drms(maxiter)) allocate (tdirect(n)) allocate (tpcg(n)) allocate (txpt(n)) allocate (ttcg(n)) allocate (ddirect(3,n)) allocate (dpcg(3,n)) allocate (dxpt(3,n)) allocate (dtcg(3,n)) allocate (udirect(3,n)) allocate (upcg(3,n)) allocate (uxpt(3,n)) allocate (utcg(3,n)) allocate (ustore(3,n,0:maxiter)) c c perform dynamic allocation of some global arrays c allocate (uexact(3,n)) if (use_solv) then if (allocated(uopts)) deallocate (uopts) if (allocated(uoptps)) deallocate (uoptps) allocate (uopts(0:optorder,3,n)) allocate (uoptps(0:optorder,3,n)) end if c c find PCG induced dipoles for increasing iteration counts c poltyp = 'MUTUAL' done = .false. do k = 1, maxiter politer = k call induce do i = 1, n do j = 1, 3 if (use_solv) then ustore(j,i,k) = debye * uinds(j,i) else ustore(j,i,k) = debye * uind(j,i) end if end do end do sum = 0.0d0 do i = 1, n do j = 1, 3 sum = sum + (ustore(j,i,k)-ustore(j,i,k-1))**2 end do end do drms(k) = sqrt(sum/dble(npolar)) if (.not. done) then if (k.eq.itercut .or. drms(k).lt.epscut) then done = .true. kpcg = k do i = 1, n do j = 1, 3 upcg(j,i) = ustore(j,i,k) end do end do end if end if if (drms(k) .lt. 0.5d0*poleps) goto 60 end do 60 continue maxiter = politer do i = 1, n do j = 1, 3 uexact(j,i) = ustore(j,i,maxiter) end do end do c c print the fully converged SCF induced dipole moments c if (dofull) then write (iout,70) 70 format (/,' Exact SCF Induced Dipole Moments :', & //,4x,'Atom',14x,'X',13x,'Y',13x,'Z',12x,'Norm',/) do i = 1, n if (use(i) .and. douind(i)) then ux = uexact(1,i) uy = uexact(2,i) uz = uexact(3,i) u2 = sqrt(ux*ux+uy*uy+uz*uz) write (iout,80) i,ux,uy,uz,u2 80 format (i8,4x,4f14.6) end if end do end if c c print the iterative PCG induced dipole moments c if (dofull) then write (iout,90) kpcg 90 format (/,' Iterative PCG Induced Dipole Moments :', & 4x,'(',i3,' Iterations)', & //,4x,'Atom',15x,'X',13x,'Y',13x,'Z',12x,'Norm',/) do i = 1, n if (use(i) .and. douind(i)) then ux = upcg(1,i) uy = upcg(2,i) uz = upcg(3,i) u2 = sqrt(ux*ux+uy*uy+uz*uz) write (iout,100) i,ux,uy,uz,u2 100 format (i8,4x,4f14.6) end if end do end if c c get induced dipoles for direct polarization only c poltyp = 'DIRECT' call induce do i = 1, n do j = 1, 3 if (use_solv) then udirect(j,i) = debye * uinds(j,i) else udirect(j,i) = debye * uind(j,i) end if ustore(j,i,0) = udirect(j,i) end do end do c c print the direct polarization induced dipole moments c if (dofull) then write (iout,110) 110 format (/,' Direct Induced Dipole Moments :', & //,4x,'Atom',15x,'X',13x,'Y',13x,'Z',12x,'Norm',/) do i = 1, n if (use(i) .and. douind(i)) then ux = udirect(1,i) uy = udirect(2,i) uz = udirect(3,i) u2 = sqrt(ux*ux+uy*uy+uz*uz) write (iout,120) i,ux,uy,uz,u2 120 format (i8,4x,4f14.6) end if end do end if c c get induced dipoles from OPT extrapolation method c poltyp = savetyp if (poltyp(1:3) .ne. 'OPT') poltyp = 'OPT ' call kpolar call induce do i = 1, n do j = 1, 3 if (use_solv) then uxpt(j,i) = debye * uinds(j,i) else uxpt(j,i) = debye * uind(j,i) end if end do end do c c print the OPT extrapolation induced dipole moments c if (dofull) then write (iout,130) optorder 130 format (/,' Analytical OPT',i1,' Induced Dipole Moments :', & //,4x,'Atom',15x,'X',13x,'Y',13x,'Z',12x,'Norm',/) do i = 1, n if (use(i) .and. douind(i)) then ux = uxpt(1,i) uy = uxpt(2,i) uz = uxpt(3,i) u2 = sqrt(ux*ux+uy*uy+uz*uz) write (iout,140) i,ux,uy,uz,u2 140 format (i8,4x,4f14.6) end if end do end if c c get induced dipoles from TCG analytical dipole method c poltyp = savetyp if (poltyp(1:3) .ne. 'TCG') poltyp = 'TCG ' call kpolar call induce do i = 1, n do j = 1, 3 utcg(j,i) = debye * uind(j,i) end do end do c c print the TCG analytical induced dipole moments c if (dofull .and. .not.use_solv) then write (iout,150) tcgorder 150 format (/,' Analytical TCG',i1,' Induced Dipole Moments :', & //,4x,'Atom',15x,'X',13x,'Y',13x,'Z',12x,'Norm',/) do i = 1, n if (use(i) .and. douind(i)) then ux = utcg(1,i) uy = utcg(2,i) uz = utcg(3,i) u2 = sqrt(ux*ux+uy*uy+uz*uz) write (iout,160) i,ux,uy,uz,u2 160 format (i8,4x,4f14.6) end if end do end if c c find differences between approximate and exact dipoles c rdirect = 0.0d0 rpcg = 0.0d0 rxpt = 0.0d0 rtcg = 0.0d0 m = 0 do i = 1, n if (use(i) .and. douind(i)) then m = m + 1 do j = 1, 3 ddirect(j,i) = udirect(j,i) - uexact(j,i) dpcg(j,i) = upcg(j,i) - uexact(j,i) dxpt(j,i) = uxpt(j,i) - uexact(j,i) dtcg(j,i) = utcg(j,i) - uexact(j,i) end do tdirect(i) = sqrt(ddirect(1,i)**2+ddirect(2,i)**2 & +ddirect(3,i)**2) tpcg(i) = sqrt(dpcg(1,i)**2+dpcg(2,i)**2+dpcg(3,i)**2) txpt(i) = sqrt(dxpt(1,i)**2+dxpt(2,i)**2+dxpt(3,i)**2) ttcg(i) = sqrt(dtcg(1,i)**2+dtcg(2,i)**2+dtcg(3,i)**2) rdirect = rdirect + tdirect(i)**2 rpcg = rpcg + tpcg(i)**2 rxpt = rxpt + txpt(i)**2 rtcg = rtcg + ttcg(i)**2 end if end do rdirect = sqrt(rdirect/dble(m)) rpcg = sqrt(rpcg/dble(m)) rxpt = sqrt(rxpt/dble(m)) rtcg = sqrt(rtcg/dble(m)) c c print the RMS between approximate and exact dipoles c if (use_solv) then write (iout,170) saveopt 170 format (/,' Approximate vs. Exact Induced Dipoles :', & //,4x,'Atom',14x,'Direct',12x,'PCG',12x,'OPT',i1) else write (iout,180) saveopt,savetcg 180 format (/,' Approximate vs. Exact Induced Dipoles :', & //,4x,'Atom',14x,'Direct',12x,'PCG',12x,'OPT',i1, & 12x,'TCG',i1) end if if (dofull) then write (iout,190) 190 format () if (use_solv) then do i = 1, n if (use(i) .and. douind(i)) then write (iout,200) i,tdirect(i),tpcg(i),txpt(i) 200 format (i8,6x,3f16.10) end if end do else do i = 1, n if (use(i) .and. douind(i)) then write (iout,210) i,tdirect(i),tpcg(i),txpt(i),ttcg(i) 210 format (i8,6x,4f16.10) end if end do end if end if if (use_solv) then write (iout,220) rdirect,rpcg,rxpt 220 format (/,5x,'RMS',6x,3f16.10) else write (iout,230) rdirect,rpcg,rxpt,rtcg 230 format (/,5x,'RMS',6x,4f16.10) end if c c find the RMS of each iteration from the exact dipoles c do k = 0, maxiter sum = 0.0d0 m = 0 do i = 1, n if (use(i) .and. douind(i)) then m = m + 1 do j = 1, 3 sum = sum + (ustore(j,i,k)-uexact(j,i))**2 end do end if end do rms(k) = sqrt(sum/dble(m)) end do c c print the RMS between iterations and versus exact dipoles c write (iout,240) 240 format (/,' Iterative PCG Induced Dipole Convergence :', & //,4x,'Iter',12x,'RMS Change',11x,'RMS vs Exact') write (iout,250) 0,rms(0) 250 format (/,i8,15x,'----',6x,f20.10) do k = 1, maxiter write (iout,260) k,drms(k),rms(k) 260 format (i8,2x,f20.10,3x,f20.10) if (rms(k) .lt. 0.5d0*poleps) goto 270 end do 270 continue c c refine the extrapolated OPT coefficients via optimization c if (dofitopt) then poltyp = savetyp if (poltyp(1:3) .ne. 'OPT') poltyp = 'OPT ' call kpolar write (iout,280) optorder 280 format (/,' Analytical OPT',i1,' Coefficient Refinement :', & //,4x,'Iter',7x,'C0',5x,'C1',5x,'C2',5x,'C3', & 5x,'C4',5x,'C5',5x,'C6',5x,'RMS vs Exact',/) c c perform dynamic allocation of some local arrays c nvar = 0 do i = 0, optorder if (copt(i) .ne. 0.0d0) nvar = nvar + 1 end do allocate (var(nvar)) c c count number of variables and define the initial simplex c nvar = 0 do i = 0, optorder if (copt(i) .ne. 0.0d0) then nvar = nvar + 1 var(nvar) = copt(i) end if end do c c optimize OPT coefficients, then print refined values c iter = 0 maxiter = 3000 iprint = 0 ntest = 200 step = 0.03d0 delta = 0.0001d0 rxpt = 1000.0d0 call simplex (nvar,iter,ntest,var,rxpt,step,delta,optfit) nvar = 0 do i = 0, optorder if (copt(i) .ne. 0.0d0) then nvar = nvar + 1 copt(i) = var(nvar) end if end do write (iout,290) iter,(copt(i),i=0,6),rxpt 290 format (i8,3x,7f7.3,f16.10) end if c c perform deallocation of some local arrays c deallocate (rms) deallocate (drms) deallocate (tdirect) deallocate (tpcg) deallocate (txpt) deallocate (ttcg) deallocate (ddirect) deallocate (dpcg) deallocate (dxpt) deallocate (dtcg) deallocate (udirect) deallocate (upcg) deallocate (uxpt) deallocate (utcg) deallocate (ustore) if (dofitopt) deallocate (var) c c perform any final tasks before program exit c call final end c c c ############################################################## c ## ## c ## function optfit -- OPT dipole coefficient refinement ## c ## ## c ############################################################## c c function optfit (var) use atoms use iounit use polar use polopt use polpot use potent use units use usage implicit none integer i,j,k integer nvar,iter real*8 optfit real*8 rxpt real*8 var(*) real*8, allocatable :: uxpt(:,:) logical first save first,iter data first / .true. / c c c count the number of times the function has been called c if (first) then first = .false. iter = -1 end if iter = iter + 1 c c copy optimization variables into extrapolation coefficients c nvar = 0 do i = 0, maxopt if (copt(i) .ne. 0.0d0) then nvar = nvar + 1 copt(i) = var(nvar) end if end do c c perform dynamic allocation of some local arrays c allocate (uxpt(3,n)) c c compute RMS error between OPT and exact SCF dipoles c poltyp = 'OPT' call induce rxpt = 0.0d0 k = 0 do i = 1, n if (use(i) .and. douind(i)) then k = k + 1 do j = 1, 3 if (use_solv) then uxpt(j,i) = debye * uinds(j,i) else uxpt(j,i) = debye * uind(j,i) end if rxpt = rxpt + (uxpt(j,i)-uexact(j,i))**2 c rxpt = rxpt + (uxpt(j,i)-uexact(j,i))**6 end do end if end do rxpt = sqrt(rxpt/dble(k)) if (mod(iter,100) .eq. 0) then write (iout,10) iter,(copt(i),i=0,6),rxpt 10 format (i8,3x,7f7.3,f16.10) end if c c set the return value equal to the RMS error c optfit = rxpt c c perform deallocation of some local arrays c deallocate (uxpt) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## program testrot -- derivative test; torsional version ## c ## ## c ############################################################### c c c "testrot" computes and compares the analytical and numerical c gradient vectors of the potential energy function with respect c to rotatable torsional angles c c program testrot use domega use energi use inform use iounit use math use omega use zcoord implicit none integer i real*8 e,e0,etot,energy real*8 delta,delta0,eps real*8 eb0,ea0,eba0,eub0 real*8 eaa0,eopb0,eopd0 real*8 eid0,eit0,et0,ept0 real*8 ebt0,eat0,ett0,ev0 real*8 er0,edsp0,ec0,ecd0 real*8 ed0,em0,ep0,ect0 real*8 erxf0,es0,elf0 real*8 eg0,ex0 real*8, allocatable :: derivs(:) real*8, allocatable :: nderiv(:) logical exist,query character*240 string c c c set up the molecular mechanics calculation c call initial call getint call mechanic call initrot c c get the stepsize for numerical gradient calculation c delta = -1.0d0 delta0 = 1.0d-3 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) delta query = .false. end if 10 continue if (query) then write (iout,20) delta0 20 format (/,' Enter Finite Difference Stepsize [',d8.1, & ' Deg] : ',$) read (input,30,err=10) delta 30 format (f20.0) end if if (delta .le. 0.0d0) delta = delta0 eps = -delta / radian c c perform dynamic allocation of some local arrays c allocate (derivs(nomega)) c c make the call to get analytical torsional derivatives c call gradrot (etot,derivs) c c print the total potential energy of the system c if (digits .ge. 8) then write (iout,40) etot 40 format (/,' Total Potential Energy :',8x,f20.8,' Kcal/mole') else if (digits .ge. 6) then write (iout,50) etot 50 format (/,' Total Potential Energy :',8x,f18.6,' Kcal/mole') else write (iout,60) etot 60 format (/,' Total Potential Energy :',8x,f16.4,' Kcal/mole') end if c c print the energy breakdown over individual components c write (iout,70) 70 format (/,' Potential Energy Breakdown by Individual', & ' Components :') if (digits .ge. 8) then write (iout,80) 80 format (/,' Energy',7x,'EB',14x,'EA',14x,'EBA',13x,'EUB', & /,' Terms',8x,'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') write (iout,90) 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 90 format (/,6x,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 write (iout,100) 100 format (/,' Energy',6x,'EB',12x,'EA',12x,'EBA',11x,'EUB', & 11x,'EAA', & /,' Terms',7x,'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') write (iout,110) 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 110 format (/,6x,5f14.6,/,6x,5f14.6,/,6x,5f14.6,/,6x,5f14.6, & /,6x,5f14.6,/,6x,3f14.6) else write (iout,120) 120 format (/,' Energy',6x,'EB',10x,'EA',10x,'EBA',9x,'EUB', & 9x,'EAA',9x,'EOPB', & /,' Terms',7x,'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') write (iout,130) 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 130 format (/,6x,6f12.4,/,6x,6f12.4,/,6x,6f12.4,/,6x,6f12.4, & /,6x,4f12.4) end if c c print a header for the gradients of individual potentials c write (iout,140) 140 format (/,' Torsional Gradient Breakdown by Individual', & ' Components :') if (digits .ge. 8) then write (iout,150) 150 format (/,2x,'Atom',9x,'d EB',12x,'d EA',12x,'d EBA', & 11x,'d EUB', & /,2x,'Axis',9x,'d EAA',11x,'d EOPB',10x,'d EOPD', & 10x,'d EID', & /,2x,'Type',9x,'d EIT',11x,'d ET',12x,'d EPT', & 11x,'d EBT', & /,15x,'d EAT',10x,'d ETT',10x,'d EV',12x,'d ER', & /,15x,'d EDSP',10x,'d EC',12x,'d ECD',11x,'d ED', & /,15x,'d EM',12x,'d EP',12x,'d ECT',11x,'d ERXF', & /,15x,'d ES',12x,'d ELF',11x,'d EG',12x,'d EX') else if (digits .ge. 6) then write (iout,160) 160 format (/,2x,'Atom',8x,'d EB',10x,'d EA',10x,'d EBA', & 9x,'d EUB',9x,'d EAA', & /,2x,'Axis',8x,'d EOPB',8x,'d EOPD',8x,'d EID', & 9x,'d EIT',9x,'d ET', & /,2x,'Type',8x,'d EPT',9x,'d EBT',9x,'d EAT', & 9x,'d ETT',9x,'d EV', & /,14x,'d ER',10x,'d EDSP',8x,'d EC',10x,'d ECD', & 9x,'d ED', & /,14x,'d EM',10x,'d EP',10x,'d ECT',9x,'d ERXF', & 8x,'d ES', & /,14x,'d ELF',9x,'d EG',10x,'d EX') else write (iout,170) 170 format (/,2x,'Atom',6x,'d EB',8x,'d EA',8x,'d EBA', & 7x,'d EUB',7x,'d EAA',7x,'d EOPB', & /,2x,'Axis',6x,'d EOPD',6x,'d EID',7x,'d EIT', & 7x,'d ET',8x,'d EPT',7x,'d EBT', & /,2x,'Type',6x,'d EAT',7x,'d ETT',7x,'d EV', & 8x,'d ER',8x,'d EDSP',6x,'d EC', & /,12x,'d ECD',7x,'d ED',8x,'d EM',8x,'d EP', & 8x,'d ECT',7x,'d ERXF', & /,12x,'d ES',8x,'d ELF',7x,'d EG',8x,'d EX') end if c c perform dynamic allocation of some local arrays c allocate (nderiv(nomega)) c c get numerical derivatives for each of the rotatable torsions c do i = 1, nomega ztors(zline(i)) = ztors(zline(i)) + delta/2.0d0 call makexyz e0 = energy () eb0 = eb ea0 = ea eba0 = eba eub0 = eub eaa0 = eaa eopb0 = eopb eopd0 = eopd eid0 = eid eit0 = eit et0 = et ept0 = ept ebt0 = ebt eat0 = eat ett0 = ett ev0 = ev er0 = er edsp0 = edsp ec0 = ec ecd0 = ecd ed0 = ed em0 = em ep0 = ep ect0 = ect erxf0 = erxf es0 = es elf0 = elf eg0 = eg ex0 = ex ztors(zline(i)) = ztors(zline(i)) - delta call makexyz e = energy () ztors(zline(i)) = ztors(zline(i)) + delta/2.0d0 nderiv(i) = (e-e0) / eps c c print analytical gradients of each energy term for each atom c if (digits .ge. 8) then write (iout,180) iomega(2,i),teb(i),tea(i),teba(i),teub(i), & iomega(1,i),teaa(i),teopb(i),teopd(i), & teid(i),teit(i),tet(i),tept(i),tebt(i), & teat(i),tett(i),tev(i),ter(i),tedsp(i), & tec(i),tecd(i),ted(i),tem(i),tep(i), & tect(i),terxf(i),tes(i),telf(i),teg(i), & tex(i) 180 format (/,i6,4f16.8,/,i6,4f16.8,/,' Anlyt',4f16.8, & /,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8, & /,6x,4f16.8) else if (digits .ge. 6) then write (iout,190) iomega(2,i),teb(i),tea(i),teba(i),teub(i), & teaa(i),iomega(1,i),teopb(i),teopd(i), & teid(i),teit(i),tet(i),tept(i),tebt(i), & teat(i),tett(i),tev(i),ter(i),tedsp(i), & tec(i),tecd(i),ted(i),tem(i),tep(i), & tect(i),terxf(i),tes(i),telf(i),teg(i), & tex(i) 190 format (/,i6,5f14.6,/,i6,5f14.6,/,' Anlyt',5f14.6, & /,6x,5f14.6,/,6x,5f14.6,/,6x,3f14.6) else write (iout,200) iomega(2,i),teb(i),tea(i),teba(i),teub(i), & teaa(i),teopb(i),iomega(1,i),teopd(i), & teid(i),teit(i),tet(i),tept(i),tebt(i), & teat(i),tett(i),tev(i),ter(i),tedsp(i), & tec(i),tecd(i),ted(i),tem(i),tep(i), & tect(i),terxf(i),tes(i),telf(i),teg(i), & tex(i) 200 format (/,i6,6f12.4,/,i6,6f12.4,/,' Anlyt',6f12.4, & /,6x,6f12.4,/,6x,4f12.4) end if c c print numerical gradients of each energy term for each atom c if (digits .ge. 8) then write (iout,210) iomega(2,i),(eb-eb0)/eps,(ea-ea0)/eps, & (eba-eba0)/eps,(eub-eub0)/eps, & iomega(1,i),(eaa-eaa0)/eps, & (eopb-eopb0)/eps,(eopd-eopd0)/eps, & (eid-eid0)/eps,(eit-eit0)/eps, & (et-et0)/eps,(ept-ept0)/eps, & (ebt-ebt0)/eps,(eat-eat0)/eps, & (ett-ett0)/eps,(ev-ev0)/eps,(er-er0)/eps, & (edsp-edsp0)/eps,(ec-ec0)/eps, & (ecd-ecd0)/eps,(ed-ed0)/eps,(em-em0)/eps, & (ep-ep0)/eps,(ect-ect0)/eps, & (erxf-erxf0)/eps,(es-es0)/eps, & (elf-elf0)/eps,(eg-eg0)/eps,(ex-ex0)/eps 210 format (/,i6,4f16.8,/,i6,4f16.8,/,' Numer',4f16.8, & /,6x,4f16.8,/,6x,4f16.8,/,6x,4f16.8, & /,6x,4f14.8) else if (digits .ge. 6) then write (iout,220) iomega(2,i),(eb-eb0)/eps,(ea-ea0)/eps, & (eba-eba0)/eps,(eub-eub0)/eps, & (eaa-eaa0)/eps,iomega(1,i), & (eopb-eopb0)/eps,(eopd-eopd0)/eps, & (eid-eid0)/eps,(eit-eit0)/eps, & (et-et0)/eps,(ept-ept0)/eps, & (ebt-ebt0)/eps,(eat-eat0)/eps, & (ett-ett0)/eps,(ev-ev0)/eps,(er-er0)/eps, & (edsp-edsp0)/eps,(ec-ec0)/eps, & (ecd-ecd0)/eps,(ed-ed0)/eps,(em-em0)/eps, & (ep-ep0)/eps,(ect-ect0)/eps, & (erxf-erxf0)/eps,(es-es0)/eps, & (elf-elf0)/eps,(eg-eg0)/eps,(ex-ex0)/eps 220 format (/,i6,5f14.6,/,i6,5f14.6,/,' Numer',5f14.6, & /,6x,5f14.6,/,6x,5f14.6,/,6x,3f14.6) else write (iout,230) iomega(2,i),(eb-eb0)/eps,(ea-ea0)/eps, & (eba-eba0)/eps,(eub-eub0)/eps, & (eaa-eaa0)/eps,(eopb-eopb0)/eps, & iomega(1,i),(eopd-eopd0)/eps, & (eid-eid0)/eps,(eit-eit0)/eps, & (et-et0)/eps,(ept-ept0)/eps, & (ebt-ebt0)/eps,(eat-eat0)/eps, & (ett-ett0)/eps,(ev-ev0)/eps,(er-er0)/eps, & (edsp-edsp0)/eps,(ec-ec0)/eps, & (ecd-ecd0)/eps,(ed-ed0)/eps,(em-em0)/eps, & (ep-ep0)/eps,(ect-ect0)/eps, & (erxf-erxf0)/eps,(es-es0)/eps, & (elf-elf0)/eps,(eg-eg0)/eps,(ex-ex0)/eps 230 format (/,i6,6f12.4,/,i6,6f12.4,/,' Numer',6f12.4, & /,6x,6f12.4,/,6x,4f12.4) end if end do c c print a header for the analytical vs. numerical comparison c write (iout,240) 240 format (/,' Total Torsional Gradient Norm over Rotatable', & ' Bonds :') if (digits .ge. 8) then write (iout,250) 250 format (/,5x,'Torsion',19x,'Anlyt Deriv',9x,'Numer Deriv',/) else if (digits .ge. 6) then write (iout,260) 260 format (/,5x,'Torsion',18x,'Anlyt Deriv',7x,'Numer Deriv',/) else write (iout,270) 270 format (/,5x,'Torsion',17x,'Anlyt Deriv',5x,'Numer Deriv',/) end if c c print comparison of analytical and numerical derivatives c if (digits .ge. 8) then do i = 1, nomega write (iout,280) iomega(2,i),iomega(1,i),derivs(i), & nderiv(i) 280 format (1x,i5,'-',i5,10x,2f20.8) end do else if (digits .ge. 6) then do i = 1, nomega write (iout,290) iomega(2,i),iomega(1,i),derivs(i), & nderiv(i) 290 format (1x,i5,'-',i5,10x,2f18.6) end do else do i = 1, nomega write (iout,300) iomega(2,i),iomega(1,i),derivs(i), & nderiv(i) 300 format (1x,i5,'-',i5,10x,2f16.4) end do end if c c perform deallocation of some local arrays c deallocate (derivs) deallocate (nderiv) c c perform any final tasks before program exit c call final end c c c ################################################### c ## COPYRIGHT (C) 2023 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## subroutine testsurf -- find & compare area and volume ## c ## ## c ############################################################### c c c "testsurf" finds the accessible surface area, excluded volume c and their derivatives for a molecular system via the methods of c Tim Richmond, Michael Connolly, Craig Kundrot and Patrice Koehl c c program testsurf use atomid use atoms use files use iounit use kvdws use nonpol use ptable use vdwpot implicit none integer i,icrd integer nsize,nfudge integer freeunit real*8 surf,vol real*8 probe,rmax real*8 reentrant real*8 wall,cpu real*8, allocatable :: rsolv(:) real*8, allocatable :: weight(:) real*8, allocatable :: asurf(:) real*8, allocatable :: avol(:) real*8, allocatable :: dsurf(:,:) real*8, allocatable :: dvol(:,:) logical exist,query logical docrd logical doderiv,dovol character*240 crdfile character*240 string c c c set up the structure and values for the computation; c solute radii can be changed via the keyword mechanism c call initial call getxyz call active call field call katom call kvdw c c get probe radius for accessible area/excluded volume c probe = 0.0d0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) probe query = .false. end if 10 continue if (query) then probe = -1.0d0 write (iout,20) 20 format (/,' Enter a Value for the Probe Radius', & ' [1.4 Ang] : ',$) read (input,30) string 30 format (a240) read (string,*,err=40,end=40) probe goto 50 40 continue probe = 1.4d0 50 continue end if c c print out the total number of atoms c write (iout,60) 60 format (/,' Alternative Surface Area & Volume Methods') write (iout,70) n,probe 70 format (/,' Number of Atoms :',15x,i8, & /,' Probe Size :',16x,f12.4) c c perform dynamic allocation of some local arrays c nfudge = 10 nsize = n + nfudge allocate (rsolv(nsize)) allocate (weight(nsize)) allocate (asurf(nsize)) allocate (avol(nsize)) allocate (dsurf(3,nsize)) allocate (dvol(3,nsize)) c c if all radii are zero then switch to generic vdw radii c rmax = 0.0d0 do i = 1, n rmax = rad(i) if (rmax .gt. 0.0d0) goto 80 end do 80 continue if (rmax .eq. 0.0d0) then write (iout,90) 90 format (/,' Atomic Radii not Set, Using Generic VDW Values') do i = 1, n rad(i) = vdwrad(atomic(i)) end do end if c c set radii to use for surface area and volume calculation c do i = 1, n if (vdwindex .eq. 'CLASS') then rsolv(i) = rad(class(i)) else rsolv(i) = rad(type(i)) end if weight(i) = 1.0d0 end do c c initialize variables for Richmond and Connolly routines c surf = 0.0d0 vol = 0.0d0 reentrant = 0.0d0 do i = 1, n asurf(i) = 0.0d0 dsurf(1,i) = 0.0d0 dsurf(2,i) = 0.0d0 dsurf(3,i) = 0.0d0 end do c c compute accessible surface area via Richmond method c surf = 0.0d0 write (iout,100) 100 format (/,' Timothy Richmond Accessible Surface Area Method :') call settime call richmond (n,x,y,z,rsolv,weight,probe,surf,asurf) call gettime (wall,cpu) write (iout,110) cpu,wall 110 format (/,' CPU and Wall Times :',8x,2f12.4) write (iout,120) surf 120 format (/,' Total Surface Area :',8x,f12.4) c c compute accessible surface and derivatives via Richmond c surf = 0.0d0 write (iout,130) 130 format (/,' Timothy Richmond Surface Area Derivative Method :') call settime call richmond1 (n,x,y,z,rsolv,weight,probe,surf,asurf,dsurf) call gettime (wall,cpu) write (iout,140) cpu,wall 140 format (/,' CPU and Wall Times :',8x,2f12.4) write (iout,150) surf 150 format (/,' Total Surface Area :',8x,f12.4) write (iout,160) 160 format (/,' Surface Area Derivatives : (First Ten Atoms)', & //,5x,'Atom',11x,'dAx',7x,'dAy',7x'dAz',/) do i = 1, min(10,n) write (iout,170) i,dsurf(1,i),dsurf(2,i),dsurf(3,i) 170 format (i8,6x,3f10.4) end do c c compute surface area and excluded volume via Connolly c surf = 0.0d0 vol = 0.0d0 write (iout,180) 180 format (/,' Michael Connolly Molecular Area-Volume Method :') call settime call connolly (n,x,y,z,rsolv,probe,reentrant,surf,vol) call gettime (wall,cpu) write (iout,190) cpu,wall 190 format (/,' CPU and Wall Times :',8x,2f12.4) write (iout,200) surf 200 format (/,' Total Surface Area :',8x,f12.4) write (iout,210) vol 210 format (/,' Total Excluded Volume :',5x,f12.4) c c compute excluded volume derivatives via Kundrot method c do i = 1, n dvol(1,i) = 0.0d0 dvol(2,i) = 0.0d0 dvol(3,i) = 0.0d0 end do write (iout,220) 220 format (/,' Craig Kundrot Excluded Volume Derivative Method :') call settime call kundrot1 (n,x,y,z,rsolv,probe,dvol) call gettime (wall,cpu) write (iout,230) cpu,wall 230 format (/,' CPU and Wall Times :',8x,2f12.4) write (iout,240) 240 format (/,' Excluded Volume Derivatives : (First Ten Atoms)', & //,5x,'Atom',11x,'dVx',7x,'dVy',7x'dVz',/) do i = 1, min(10,n) write (iout,250) i,dvol(1,i),dvol(2,i),dvol(3,i) 250 format (i8,6x,3f10.4) end do c c initialize variables for Koehl UnionBall routines c doderiv = .true. dovol = .true. surf = 0.0d0 vol = 0.0d0 do i = 1, n asurf(i) = 0.0d0 avol(i) = 0.0d0 dsurf(1,i) = 0.0d0 dsurf(2,i) = 0.0d0 dsurf(3,i) = 0.0d0 dvol(1,i) = 0.0d0 dvol(2,i) = 0.0d0 dvol(3,i) = 0.0d0 end do c c print out structure in UnionBall coordinate format c docrd = .false. if (docrd) then icrd = freeunit () crdfile = filename(1:leng)//'.crd' call version (crdfile,'new') open (unit=icrd,file=crdfile,status='new') write (icrd,260) n 260 format (i8,/) do i = 1, n write (icrd,270) i,x(i),y(i),z(i),rsolv(i) 270 format (i8,3f14.6,f12.4) end do close (unit=icrd) end if c c compute area, volume and derivatives via UnionBall c write (iout,280) 280 format (/,' Patrice Koehl UnionBall Alpha Shape Method :') call settime call unionball (n,x,y,z,rsolv,weight,probe,doderiv,dovol, & surf,vol,asurf,avol,dsurf,dvol) call gettime (wall,cpu) write (iout,290) cpu,wall 290 format (/,' CPU and Wall Times :',8x,2f12.4) write (iout,300) surf 300 format (/,' Total Surface Area :',8x,f12.4) write (iout,310) vol 310 format (/,' Total Excluded Volume :',5x,f12.4) write (iout,320) 320 format (/,' Surface Area & Volume Derivatives :', & ' (First Ten Atoms)', & //,5x,'Atom',11x,'dAx',7x,'dAy',7x'dAz', & 7x,'dVx',7x,'dVy',7x,'dVz',/) do i = 1, min(10,n) write (iout,330) i,dsurf(1,i),dsurf(2,i),dsurf(3,i), & dvol(1,i),dvol(2,i),dvol(3,i) 330 format (i8,6x,6f10.4) end do c c perform deallocation of some local arrays c deallocate (rsolv) deallocate (weight) deallocate (asurf) deallocate (avol) deallocate (dsurf) deallocate (dvol) end c c c ################################################### c ## COPYRIGHT (C) 2018 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## program testvir -- check analytical & numerical virial ## c ## ## c ################################################################ c c c "testvir" computes the analytical internal virial and compares c it to a numerical virial derived from the finite difference c derivative of the energy with respect to lattice vectors c c program testvir use atoms use inform use iounit use virial implicit none integer i real*8 energy real*8, allocatable :: derivs(:,:) c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c set option control flags based desired analysis types c debug = .false. allocate (derivs(3,n)) call gradient (energy,derivs) deallocate (derivs) c c print the components of the analytical internal virial c write (iout,10) (vir(1,i),vir(2,i),vir(3,i),i=1,3) 10 format (/,' Analytical Virial Tensor :',9x,3f13.3, & /,36x,3f13.3,/,36x,3f13.3) c c get the numerical dE/dV value and a pressure estimate c call ptest c c perform any final tasks before program exit c call final end c c c ################################################################## c ## ## c ## subroutine ptest -- find pressure via finite differences ## c ## ## c ################################################################## c c c "ptest" determines the numerical virial tensor, and compares c analytical to numerical values for dE/dV and isotropic pressure c c original version written by John D. Chodera, University of c California, Berkeley, December 2010 c c modified for off-diagonal numerical virial by Jay W. Ponder, c Saint Louis, August 2018 c c subroutine ptest use atoms use bath use bound use boxes use iounit use math use units use virial implicit none integer i,j,k real*8 energy,epos,eneg real*8 eps,temp,lorig real*8 dedv_vir,dedv_num real*8 pres_vir,pres_num real*8 dedl(3,3) real*8 virn(3,3) real*8, allocatable :: xf(:) real*8, allocatable :: yf(:) real*8, allocatable :: zf(:) c c c set relative volume change for finite-differences c if (.not. use_bounds) return eps = 0.00003d0 c c set prism lattice type to the general triclinic case c if (.not. nonprism) then orthogonal = .false. monoclinic = .false. triclinic = .true. end if c c print out the lattice vectors as matrix rows c write (iout,10) (lvec(1,i),lvec(2,i),lvec(3,i),i=1,3) 10 format (/,' Lattice Vectors (Lvec) :',11x,3f13.3, & /,36x,3f13.3,/,36x,3f13.3) c c perform dynamic allocation of some local arrays c allocate (xf(n)) allocate (yf(n)) allocate (zf(n)) c c store the original fractional coordinate values c do i = 1, n xf(i) = x(i)*recip(1,1) + y(i)*recip(2,1) + z(i)*recip(3,1) yf(i) = x(i)*recip(1,2) + y(i)*recip(2,2) + z(i)*recip(3,2) zf(i) = x(i)*recip(1,3) + y(i)*recip(2,3) + z(i)*recip(3,3) end do c c get energy derivatives with respect to lattice vectors c do i = 1, 3 do j = i, 3 dedl(j,i) = 0.0d0 end do end do do i = 1, 3 do j = i, 3 lorig = lvec(j,i) lvec(j,i) = lorig - eps call cellang (xf,yf,zf) eneg = energy () lvec(j,i) = lorig + eps call cellang (xf,yf,zf) epos = energy () lvec(j,i) = lorig call cellang (xf,yf,zf) dedl(j,i) = 0.5d0 * (epos-eneg) / eps end do end do c c print out the partial derivatives of the energy c write (iout,20) (dedl(1,i),dedl(2,i),dedl(3,i),i=1,3) 20 format (/,' dE/dLvec Derivatives :',13x,3f13.3, & /,36x,3f13.3,/,36x,3f13.3) c c perform deallocation of some local arrays c deallocate (xf) deallocate (yf) deallocate (zf) c c compute and print numerical virial tensor components c do i = 1, 3 do j = 1, i virn(j,i) = 0.0d0 do k = 1, 3 virn(j,i) = virn(j,i) + dedl(k,j)*lvec(k,i) end do virn(i,j) = virn(j,i) end do end do if (dodecadron) then write (iout,30) (virn(1,1)+virn(2,2)+virn(3,3))/3.0d0 30 format (/,' Numerical Mean Diagonal :',10x,f13.3) else if (octahedron) then write (iout,40) virn(1,1),virn(2,2),virn(3,3) 40 format (/,' Numerical Virial Diagonal :',8x,3f13.3) else write (iout,50) (virn(1,i),virn(2,i),virn(3,i),i=1,3) 50 format (/,' Numerical Virial Tensor :',10x,3f13.3, & /,36x,3f13.3,/,36x,3f13.3) end if c c find the analytical and numerical values of dE/dV c dedv_vir = (vir(1,1)+vir(2,2)+vir(3,3)) / (3.0d0*volbox) dedv_num = (virn(1,1)+virn(2,2)+virn(3,3)) / (3.0d0*volbox) c c get analytical and numerical isotropic pressure values c temp = kelvin if (temp .eq. 0.0d0) temp = 298.0d0 pres_vir = prescon * (dble(n)*gasconst*temp/volbox-dedv_vir) pres_num = prescon * (dble(n)*gasconst*temp/volbox-dedv_num) write (iout,60) nint(temp),pres_vir 60 format (/,' Pressure (Analytical,',i4,' K) :',5x,f13.3, & ' Atmospheres') write (iout,70) nint(temp),pres_num 70 format (' Pressure (Numerical,',i4,' K) :',6x,f13.3, & ' Atmospheres') return end c c c ################################################################## c ## ## c ## subroutine cellang -- lattice vectors to cell parameters ## c ## ## c ################################################################## c c c "cellang" computes atomic coordinates and unit cell parameters c from fractional coordinates and lattice vectors c c subroutine cellang (xf,yf,zf) use atoms use boxes use math implicit none integer i real*8 amag,bmag,cmag real*8 abdot,acdot,bcdot real*8 xf(*),yf(*),zf(*) c c c update coordinates via fractionals and lattice vectors c do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do c c compute unit cell lengths and angles from lattice vectors c amag = sqrt(lvec(1,1)**2+lvec(1,2)**2+lvec(1,3)**2) bmag = sqrt(lvec(2,1)**2+lvec(2,2)**2+lvec(2,3)**2) cmag = sqrt(lvec(3,1)**2+lvec(3,2)**2+lvec(3,3)**2) abdot = lvec(1,1)*lvec(2,1) + lvec(1,2)*lvec(2,2) & + lvec(1,3)*lvec(2,3) acdot = lvec(1,1)*lvec(3,1) + lvec(1,2)*lvec(3,2) & + lvec(1,3)*lvec(3,3) bcdot = lvec(2,1)*lvec(3,1) + lvec(2,2)*lvec(3,2) & + lvec(2,3)*lvec(3,3) xbox = amag ybox = bmag zbox = cmag alpha = radian * acos(bcdot/(bmag*cmag)) beta = radian * acos(acdot/(amag*cmag)) gamma = radian * acos(abdot/(amag*bmag)) c c reset lattice parameters, box dimensions and volume c call lattice return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## program timer -- timer for Cartesian energy functions ## c ## ## c ############################################################### c c c "timer" measures the CPU time required for file reading and c parameter assignment, potential energy computation, energy c and gradient computation, and Hessian matrix evaluation c c program timer use atoms use hescut use inform use iounit use limits use polpot implicit none integer i,ncalls,next integer, allocatable :: hindex(:) integer, allocatable :: hinit(:,:) integer, allocatable :: hstop(:,:) real*8 value,energy real*8 wall,cpu real*8, allocatable :: h(:) real*8, allocatable :: hdiag(:,:) real*8, allocatable :: derivs(:,:) logical exist,query logical dohessian character*1 answer character*240 record character*240 string c c c read in the molecular system to be timed c call initial call getxyz c c get the number of calculation cycles to perform c ncalls = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) ncalls query = .false. end if 10 continue if (query) then write (iout,20) 20 format (/,' Enter Desired Number of Repetitions [1] : ',$) read (input,30) ncalls 30 format (i10) end if if (ncalls .eq. 0) ncalls = 1 c c decide whether to include timing of Hessian evaluations c dohessian = .false. if (n .le. 10000) then call nextarg (answer,exist) if (.not. exist) then write (iout,40) 40 format (/,' Include Timing for Hessian Evaluations', & ' [N] : ',$) read (input,50) record 50 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') dohessian = .true. end if c c perform dynamic allocation of some local arrays c if (dohessian) then allocate (hindex((3*n*(3*n-1))/2)) allocate (hinit(3,n)) allocate (hstop(3,n)) allocate (h((3*n*(3*n-1))/2)) allocate (hdiag(3,n)) end if allocate (derivs(3,n)) c c get the timing for setup of the calculation c call settime call mechanic if (use_list) call nblist call gettime (wall,cpu) write (iout,60) ncalls 60 format (/,' Total Wall Clock and CPU Time in Seconds for', & i6,' Evaluations :') write (iout,70) wall,cpu 70 format (/,' Computation Set-up :',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') c c set a large Hessian cutoff and turn off extra printing c hesscut = 1.0d0 verbose = .false. polprt = .false. c c run the potential energy only timing experiment c call settime do i = 1, ncalls value = energy () end do call gettime (wall,cpu) write (iout,80) wall,cpu 80 format (/,' Potential Energy : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') c c run the energy and gradient timing experiment c call settime do i = 1, ncalls call gradient (value,derivs) end do call gettime (wall,cpu) write (iout,90) wall,cpu 90 format (/,' Energy & Gradient : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') c c run the Hessian matrix only timing experiment c if (dohessian) then call settime do i = 1, ncalls call hessian (h,hinit,hstop,hindex,hdiag) end do call gettime (wall,cpu) write (iout,100) wall,cpu 100 format (/,' Hessian Matrix : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') end if c c repeat the potential energy only timing experiment c call settime do i = 1, ncalls value = energy () end do call gettime (wall,cpu) write (iout,110) wall,cpu 110 format (/,' Potential Energy : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') c c repeat the energy and gradient timing experiment c call settime do i = 1, ncalls call gradient (value,derivs) end do call gettime (wall,cpu) write (iout,120) wall,cpu 120 format (/,' Energy & Gradient : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') c c repeat the Hessian matrix only timing experiment c if (dohessian) then call settime do i = 1, ncalls call hessian (h,hinit,hstop,hindex,hdiag) end do call gettime (wall,cpu) write (iout,130) wall,cpu 130 format (/,' Hessian Matrix : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') end if c c perform deallocation of some local arrays c if (dohessian) then deallocate (hindex) deallocate (hinit) deallocate (hstop) deallocate (h) deallocate (hdiag) end if deallocate (derivs) 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 timerot -- timer for torsional energy terms ## c ## ## c ############################################################# c c c "timerot" measures the CPU time required for file reading c and parameter assignment, potential energy computation, c energy and gradient over torsions, and torsional angle c Hessian matrix evaluation c c program timerot use hescut use inform use iounit use limits use omega use polpot implicit none integer i,ncalls,next real*8 energy,value real*8 wall,cpu real*8, allocatable :: derivs(:) real*8, allocatable :: hrot(:,:) logical exist,query logical dohessian character*1 answer character*240 record character*240 string c c c read in the molecular system to be timed c call initial call getint c c get the timing for setup of the calculation c call settime call mechanic call initrot if (use_list) call nblist call gettime (wall,cpu) c c get the number of calculation cycles to perform c ncalls = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) ncalls query = .false. end if 10 continue if (query) then write (iout,20) 20 format (/,' Enter Desired Number of Repetitions [1] : ',$) read (input,30) ncalls 30 format (i10) end if if (ncalls .eq. 0) ncalls = 1 c c decide whether to include timing of Hessian evaluations c dohessian = .false. if (nomega .le. 1000) then call nextarg (answer,exist) if (.not. exist) then write (iout,40) 40 format (/,' Include Timing for Hessian Evaluations', & ' [N] : ',$) read (input,50) record 50 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'Y') dohessian = .true. end if c c print the time required for the computation setup c write (iout,60) ncalls 60 format (/,' Total Wall Clock and CPU Time in Seconds for', & i6,' Evaluations :') write (iout,70) wall,cpu 70 format (/,' Computation Set-up :',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') c c set a large Hessian cutoff and turn off extra printing c hesscut = 1.0d0 verbose = .false. polprt = .false. c c run the potential energy only timing experiment c call settime do i = 1, ncalls value = energy () end do call gettime (wall,cpu) write (iout,80) wall,cpu 80 format (/,' Potential Energy : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') c c perform dynamic allocation of some local arrays c allocate (derivs(nomega)) allocate (hrot(nomega,nomega)) c c run the energy and gradient timing experiment c call settime do i = 1, ncalls call gradrot (value,derivs) end do call gettime (wall,cpu) write (iout,90) wall,cpu 90 format (/,' Energy & Gradient : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') c c run the Hessian matrix only timing experiment c if (dohessian) then call settime do i = 1, ncalls call hessrot ('FULL',hrot) end do call gettime (wall,cpu) write (iout,100) wall,cpu 100 format (/,' Hessian Matrix : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') end if c c repeat the potential energy only timing experiment c call settime do i = 1, ncalls value = energy () end do call gettime (wall,cpu) write (iout,110) wall,cpu 110 format (/,' Potential Energy : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') c c repeat the energy and gradient timing experiment c call settime do i = 1, ncalls call gradrot (value,derivs) end do call gettime (wall,cpu) write (iout,120) wall,cpu 120 format (/,' Energy & Gradient : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') c c repeat the Hessian matrix only timing experiment c if (dohessian) then call settime do i = 1, ncalls call hessrot ('FULL',hrot) end do call gettime (wall,cpu) write (iout,130) wall,cpu 130 format (/,' Hessian Matrix : ',f15.3,' Sec (Wall)', & f15.3,' Sec (CPU)') end if c c perform deallocation of some local arrays c deallocate (derivs) deallocate (hrot) 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 titles -- title for current molecular system ## c ## ## c ############################################################# c c c ltitle length in characters of the nonblank title string c title title used to describe the current structure c c module titles implicit none integer ltitle character*240 title save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine tncg -- truncated Newton optimization method ## c ## ## c ################################################################# c c c "tncg" implements a truncated Newton optimization algorithm c in which a preconditioned linear conjugate gradient method is c used to approximately solve Newton's equations; special features c include use of an explicit sparse Hessian or finite-difference c gradient-Hessian products within the PCG iteration; the exact c Newton search directions can be used optionally; by default the c algorithm checks for negative curvature to prevent convergence c to a stationary point having negative eigenvalues; if a saddle c point is desired this test can be removed by disabling "negtest" c c literature references: c c J. W. Ponder and F. M Richards, "An Efficient Newton-like c Method for Molecular Mechanics Energy Minimization of c Large Molecules", Journal of Computational Chemistry, c 8, 1016-1024 (1987) c c R. S. Dembo and T. Steihaug, "Truncated-Newton Algorithms c for Large-Scale Unconstrained Optimization", Mathematical c Programming, 26, 190-212 (1983) c c variables and parameters: c c mode determines optimization method; choice of c Newton's method, truncated Newton, or c truncated Newton with finite differencing c method determines which type of preconditioning will c be used on the Newton equations; choice c of none, diagonal, 3x3 block diagonal, c SSOR or incomplete Cholesky preconditioning c nvar number of parameters in the objective function c minimum upon return contains the best value of the c function found during the optimization c f contains current best value of function c x0 contains starting point upon input, upon c return contains the best point found c g contains gradient of current best point c h contains the Hessian matrix values in an c indexed linear array c h_mode controls amount of Hessian matrix computed; c either the full matrix, diagonal or none c h_init points to the first Hessian matrix element c associated with each parameter c h_stop points to the last Hessian matrix element c associated with each parameter c h_index contains second parameter involved in each c element of the Hessian array c h_diag contains diagonal of the Hessian matrix c p search direction resulting from pcg iteration c f_move function decrease over last tncg iteration c f_old function value at end of last iteration c x_move rms movement per atom over last tn iteration c x_old parameters value at end of last tn iteration c g_norm Euclidian norm of the gradient vector c g_rms root mean square gradient value c fg_call cumulative number of function/gradient calls c grdmin termination criterion based on RMS gradient c iprint print iteration results every iprint iterations c iwrite call user-supplied output every iwrite iterations c newhess number of iterations between the computation c of new Hessian matrix values c negtest determines whether test for negative curvature c is performed during the PCG iterations c maxiter maximum number of tncg iterations to attempt c c parameters used in the line search: c c cappa accuarcy of line search control (0 < cappa < 1) c stpmin minimum allowed line search step size c stpmax maximum allowed line search step size c angmax maximum angle between search and -grad directions c intmax maximum number of interpolations in line search c c required external routines: c c fgvalue function to evaluate function and gradient values c hmatrix subroutine which evaluates Hessian diagonal c and large off-diagonal matrix elements c optsave subroutine to write out info about current status c c subroutine tncg (mode,method,nvar,x0,minimum,grdmin, & fgvalue,hmatrix,optsave) use atoms use hescut use inform use iounit use keys use linmin use math use minima use output use piorbs use potent implicit none integer i,fg_call integer nvar,nmax integer iter_tn,iter_cg integer next,newhess integer nerr,maxerr integer, allocatable :: h_init(:) integer, allocatable :: h_stop(:) integer, allocatable :: h_index(:) real*8 f,fgvalue,grdmin real*8 minimum,angle,rms real*8 x_move,f_move,f_old real*8 g_norm,g_rms real*8 x0(*) real*8, allocatable :: x_old(:) real*8, allocatable :: g(:) real*8, allocatable :: p(:) real*8, allocatable :: h_diag(:) real*8, allocatable :: h(:) logical done,negtest logical automode,automatic character*4 h_mode character*6 mode,method character*9 status character*9 info_solve character*9 info_search character*20 keyword character*240 record character*240 string save h_index,h external fgvalue external hmatrix external optsave c c c check number of variables and get type of optimization c rms = sqrt(dble(nvar)) if (coordtype .eq. 'CARTESIAN') then rms = rms / sqrt(3.0d0) else if (coordtype .eq. 'RIGIDBODY') then rms = rms / sqrt(6.0d0) end if c c set default parameters for the optimization c if (fctmin .eq. 0.0d0) fctmin = -100000000.0d0 if (iwrite .lt. 0) iwrite = 1 if (iprint .lt. 0) iprint = 1 if (maxiter .eq. 0) maxiter = 1000 if (nextiter .eq. 0) nextiter = 1 newhess = 1 maxerr = 3 done = .false. status = ' ' negtest = .true. automode = .false. automatic = .false. if (mode .eq. 'AUTO') automode = .true. if (method .eq. 'AUTO') automatic = .true. c c set default parameters for the line search c if (stpmax .eq. 0.0d0) stpmax = 5.0d0 stpmin = 1.0d-16 cappa = 0.1d0 slpmax = 10000.0d0 angmax = 180.0d0 intmax = 8 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) string = record(next:240) if (keyword(1:7) .eq. 'FCTMIN ') then read (string,*,err=10,end=10) fctmin else if (keyword(1:8) .eq. 'MAXITER ') then read (string,*,err=10,end=10) maxiter else if (keyword(1:9) .eq. 'NEXTITER ') then read (string,*,err=10,end=10) nextiter else if (keyword(1:8) .eq. 'NEWHESS ') then read (string,*,err=10,end=10) newhess else if (keyword(1:12) .eq. 'SADDLEPOINT ') then negtest = .false. else if (keyword(1:8) .eq. 'STEPMIN ') then read (string,*,err=10,end=10) stpmin else if (keyword(1:8) .eq. 'STEPMAX ') then read (string,*,err=10,end=10) stpmax else if (keyword(1:6) .eq. 'CAPPA ') then read (string,*,err=10,end=10) cappa else if (keyword(1:9) .eq. 'SLOPEMAX ') then read (string,*,err=10,end=10) slpmax else if (keyword(1:7) .eq. 'ANGMAX ') then read (string,*,err=10,end=10) angmax else if (keyword(1:7) .eq. 'INTMAX ') then read (string,*,err=10,end=10) intmax end if 10 continue end do c c initialize the function call and iteration counters c fg_call = 0 nerr = 0 iter_tn = nextiter - 1 maxiter = iter_tn + maxiter c c print header information about the method used c if (iprint .gt. 0) then if (mode .eq. 'NEWTON') then write (iout,20) 20 format (/,' Full-Newton Conjugate-Gradient', & ' Optimization :') else if (mode .eq. 'TNCG') then write (iout,30) 30 format (/,' Truncated-Newton Conjugate-Gradient', & ' Optimization :') else if (mode .eq. 'DTNCG') then write (iout,40) 40 format (/,' Finite-Difference Truncated-Newton', & ' Conjugate-Gradient Optimization :') else if (mode .eq. 'AUTO') then write (iout,50) 50 format (/,' Variable-Mode Truncated-Newton', & ' Conjugate-Gradient Optimization :') end if write (iout,60) mode,method,grdmin 60 format (/,' Algorithm : ',a6,5x,'Preconditioning : ',a6,5x, & ' RMS Grad :',d9.2) write (iout,70) 70 format (/,' TN Iter F Value G RMS F Move', & ' X Move CG Iter Solve FG Call') flush (iout) end if c c perform dynamic allocation of some local arrays c nmax = 3 * n allocate (h_init(nmax)) allocate (h_stop(nmax)) allocate (x_old(nmax)) allocate (g(nmax)) allocate (p(nmax)) allocate (h_diag(nmax)) allocate (h_index((nmax*(nmax-1))/2)) allocate (h((nmax*(nmax-1))/2)) c c evaluate the function and get the initial gradient c iter_cg = 0 fg_call = fg_call + 1 f = fgvalue (x0,g) f_old = f g_norm = 0.0d0 do i = 1, nvar x_old(i) = x0(i) g_norm = g_norm + g(i)**2 end do g_norm = sqrt(g_norm) f_move = 0.5d0 * stpmax * g_norm g_rms = g_norm / rms c c print initial information prior to first iteration c if (iprint .gt. 0) then if (f.lt.1.0d8 .and. f.gt.-1.0d7 .and. g_rms.lt.1.0d5) then write (iout,80) iter_tn,f,g_rms,fg_call 80 format (/,i6,f14.4,f11.4,41x,i7) else write (iout,90) iter_tn,f,g_rms,fg_call 90 format (/,i6,d14.4,d11.4,41x,i7) end if flush (iout) end if c c write initial intermediate prior to first iteration c if (iwrite .gt. 0) call optsave (iter_tn,f,x0) c c check for termination criteria met by initial point c if (g_rms .le. grdmin) then done = .true. minimum = f if (iprint .gt. 0) then write (iout,100) 100 format (/,' TNCG -- Normal Termination due to SmallGrad') end if else if (f .le. fctmin) then done = .true. minimum = f if (iprint .gt. 0) then write (iout,110) 110 format (/,' TNCG -- Normal Termination due to SmallFct') end if else if (iter_tn .ge. maxiter) then done = .true. minimum = f if (iprint .gt. 0) then write (iout,120) 120 format (/,' TNCG -- Incomplete Convergence', & ' due to IterLimit') end if end if c c beginning of the outer truncated Newton iteration c do while (.not. done) iter_tn = iter_tn + 1 c c if pisystem is present, update the molecular orbitals c if (use_orbit) then reorbit = 1 call picalc fg_call = fg_call + 1 f = fgvalue (x0,g) reorbit = 0 end if c c choose the optimization mode based on the gradient value c if (automode) then if (g_rms .ge. 3.0d0) then mode = 'TNCG' else mode = 'DTNCG' end if end if c c decide on an optimal preconditioning based on the gradient c if (automatic) then if (nvar .lt. 10) then method = 'DIAG' hesscut = 0.0d0 else if (g_rms .ge. 10.0d0) then method = 'DIAG' hesscut = 1.0d0 else if (g_rms .ge. 1.0d0) then method = 'ICCG' hesscut = 0.001d0 * nvar if (hesscut .gt. 1.0d0) hesscut = 1.0d0 else method = 'ICCG' hesscut = 0.001d0 * nvar if (hesscut .gt. 0.1d0) hesscut = 0.1d0 end if end if c c compute needed portions of the Hessian matrix c h_mode = 'FULL' if (mod(iter_tn-1,newhess) .ne. 0) h_mode = 'NONE' if (mode.eq.'DTNCG' .and. method.eq.'NONE') h_mode = 'NONE' if (mode.eq.'DTNCG' .and. method.eq.'DIAG') h_mode = 'DIAG' call hmatrix (h_mode,x0,h,h_init,h_stop,h_index,h_diag) c c find the next approximate Newton search direction c call tnsolve (mode,method,negtest,nvar,p,x0,g,h, & h_init,h_stop,h_index,h_diag,iter_tn, & iter_cg,fg_call,fgvalue,info_solve) c c perform a line search in the chosen direction c info_search = ' ' call search (nvar,f,g,x0,p,f_move,angle,fg_call, & fgvalue,info_search) if (info_search .ne. ' Success ') then info_solve = info_search end if c c update variables to reflect this iteration c f_move = f_old - f f_old = f x_move = 0.0d0 g_norm = 0.0d0 do i = 1, nvar x_move = x_move + (x0(i)-x_old(i))**2 x_old(i) = x0(i) g_norm = g_norm + g(i)**2 end do x_move = sqrt(x_move) x_move = x_move / rms if (coordtype .eq. 'INTERNAL') then x_move = x_move * radian end if g_norm = sqrt(g_norm) g_rms = g_norm / rms c c quit if the maximum number of iterations is exceeded c if (iter_tn .ge. maxiter) then done = .true. status = 'IterLimit' end if c c quit if the function value did not change c if (f_move .eq. 0.0d0) then done = .true. status = 'NoMotion ' end if c c quit if either of the normal termination tests are met c if (g_rms .le. grdmin) then done = .true. status = 'SmallGrad' else if (f .le. fctmin) then done = .true. status = 'SmallFct ' end if c c quit if the line search encounters successive problems c if (info_search.eq.'BadIntpln' .or. & info_search.eq.'IntplnErr') then nerr = nerr + 1 if (nerr .ge. maxerr) then done = .true. status = info_search end if else nerr = 0 end if c c print intermediate results for the current iteration c if (iprint .gt. 0) then if (done .or. mod(iter_tn,iprint).eq.0) then if (f.lt.1.0d8 .and. f.gt.-1.0d7 .and. & g_rms.lt.1.0d5 .and. f_move.lt.1.0d6 .and. & f_move.gt.-1.0d5) then write (iout,130) iter_tn,f,g_rms,f_move,x_move, & iter_cg,info_solve,fg_call 130 format (i6,f14.4,f11.4,f12.4,f9.4,i8,3x,a9,i7) else write (iout,140) iter_tn,f,g_rms,f_move,x_move, & iter_cg,info_solve,fg_call 140 format (i6,d14.4,d11.4,d12.4,f9.4,i8,3x,a9,i7) end if flush (iout) end if end if c c write intermediate results for the current iteration c if (iwrite .gt. 0) then if (done .or. mod(iter_tn,iwrite).eq.0) then call optsave (iter_tn,f,x0) end if end if c c print the reason for terminating the optimization c if (done) then minimum = f if (iprint .gt. 0) then if (g_rms.le.grdmin .or. f.le.fctmin) then write (iout,150) status 150 format (/,' TNCG -- Normal Termination due to ',a9) else write (iout,160) status 160 format (/,' TNCG -- Incomplete Convergence', & ' due to ',a9) end if flush (iout) end if end if end do c c perform deallocation of some local arrays c deallocate (h_init) deallocate (h_stop) deallocate (x_old) deallocate (g) deallocate (p) deallocate (h_diag) deallocate (h_index) deallocate (h) return end c c c ############################################################### c ## ## c ## subroutine tnsolve -- approx linear equation solution ## c ## ## c ############################################################### c c c "tnsolve" uses a linear conjugate gradient method to find c an approximate solution to the set of linear equations c represented in matrix form by Hp = -g (Newton's equations) c c status codes upon return: c c TruncNewt convergence to (truncated) Newton criterion c NegCurve termination upon detecting negative curvature c OverLimit maximum number of CG iterations exceeded c c subroutine tnsolve (mode,method,negtest,nvar,p,x0,g,h, & h_init,h_stop,h_index,h_diag,cycle, & iter_cg,fg_call,fgvalue,status) use output implicit none integer i,j,k,nvar,cycle integer iter,iter_cg integer fg_call,maxiter integer h_init(*) integer h_stop(*) integer h_index(*) real*8 alpha,beta,delta real*8 sigma,f_sigma real*8 fgvalue,eps real*8 g_norm,g_rms real*8 hj,gg,dq,rr,dd real*8 rs,rs_new,r_norm real*8 converge real*8 x0(*) real*8 g(*) real*8 p(*) real*8 h_diag(*) real*8 h(*) real*8, allocatable :: m(:) real*8, allocatable :: r(:) real*8, allocatable :: s(:) real*8, allocatable :: d(:) real*8, allocatable :: q(:) real*8, allocatable :: x_sigma(:) real*8, allocatable :: g_sigma(:) logical negtest character*6 mode,method character*9 status external fgvalue c c c perform dynamic allocation of some local arrays c allocate (m(nvar)) allocate (r(nvar)) allocate (s(nvar)) allocate (d(nvar)) allocate (q(nvar)) allocate (x_sigma(nvar)) allocate (g_sigma(nvar)) c c transformation using exact Hessian diagonal c if (mode.ne.'DTNCG' .and. method.ne.'NONE') then do i = 1, nvar m(i) = 1.0d0 / sqrt(abs(h_diag(i))) end do do i = 1, nvar g(i) = g(i) * m(i) h_diag(i) = h_diag(i) * m(i) * m(i) do j = h_init(i), h_stop(i) k = h_index(j) h(j) = h(j) * m(i) * m(k) end do end do end if c c setup prior to linear conjugate gradient iterations c iter = 0 gg = 0.0d0 do i = 1, nvar p(i) = 0.0d0 r(i) = -g(i) gg = gg + g(i)*g(i) end do g_norm = sqrt(gg) call precond (method,iter,nvar,s,r,h,h_init, & h_stop,h_index,h_diag) rs = 0.0d0 do i = 1, nvar d(i) = s(i) rs = rs + r(i)*s(i) end do if (mode .eq. 'NEWTON') then eps = 1.0d-10 maxiter = nvar else if (mode.eq.'TNCG' .or. mode.eq.'DTNCG') then delta = 1.0d0 eps = delta / dble(cycle) g_rms = g_norm / sqrt(dble(nvar)) eps = min(eps,g_rms) converge = 1.0d0 eps = eps**converge maxiter = nint(10.0d0*sqrt(dble(nvar))) end if iter = 1 c c evaluate or estimate the matrix-vector product c do while (.true.) if (mode.eq.'TNCG' .or. mode.eq.'NEWTON') then do i = 1, nvar q(i) = 0.0d0 end do do i = 1, nvar q(i) = q(i) + h_diag(i)*d(i) do j = h_init(i), h_stop(i) k = h_index(j) hj = h(j) q(i) = q(i) + hj*d(k) q(k) = q(k) + hj*d(i) end do end do else if (mode .eq. 'DTNCG') then dd = 0.0d0 do i = 1, nvar dd = dd + d(i)*d(i) end do sigma = 1.0d-7 / sqrt(dd) if (coordtype .eq. 'INTERNAL') then sigma = 1.0d-4 / sqrt(dd) end if do i = 1, nvar x_sigma(i) = x0(i) + sigma*d(i) end do fg_call = fg_call + 1 f_sigma = fgvalue (x_sigma,g_sigma) do i = 1, nvar q(i) = (g_sigma(i)-g(i)) / sigma end do end if c c check for a direction of negative curvature c dq = 0.0d0 do i = 1, nvar dq = dq + d(i)*q(i) end do if (negtest) then if (dq .le. 0.0d0) then if (iter .eq. 1) then do i = 1, nvar p(i) = d(i) end do end if status = ' NegCurve' goto 10 end if end if c c test the truncated Newton termination criterion c alpha = rs / dq rr = 0.0d0 do i = 1, nvar p(i) = p(i) + alpha*d(i) r(i) = r(i) - alpha*q(i) rr = rr + r(i)*r(i) end do r_norm = sqrt(rr) if (r_norm/g_norm .le. eps) then status = 'TruncNewt' goto 10 end if c c solve the preconditioning equations c call precond (method,iter,nvar,s,r,h,h_init, & h_stop,h_index,h_diag) c c update the truncated Newton direction c rs_new = 0.0d0 do i = 1, nvar rs_new = rs_new + r(i)*s(i) end do beta = rs_new / rs rs = rs_new do i = 1, nvar d(i) = s(i) + beta*d(i) end do c c check for overlimit, then begin next iteration c if (iter .ge. maxiter) then status = 'OverLimit' goto 10 end if iter = iter + 1 end do c c retransform and increment total iterations, then terminate c 10 continue if (mode.ne.'DTNCG' .and. method.ne.'NONE') then do i = 1, nvar p(i) = p(i) * m(i) g(i) = g(i) / m(i) end do end if iter_cg = iter_cg + iter c c perform deallocation of some local arrays c deallocate (m) deallocate (r) deallocate (s) deallocate (d) deallocate (q) deallocate (x_sigma) deallocate (g_sigma) return end c c c ############################################################# c ## ## c ## subroutine precond -- precondition linear CG method ## c ## ## c ############################################################# c c c "precond" solves a simplified version of the Newton equations c Ms = r, and uses the result to precondition linear conjugate c gradient iterations on the full Newton equations in "tnsolve" c c reference for incomplete Cholesky factorization : c c T. A. Manteuffel, "An Incomplete Factorization Technique c for Positive Definite Linear Systems", Mathematics of c Computation, 34, 473-497 (1980); the present method is c based upon the SICCG(0) method described in this paper c c types of preconditioning methods : c c none use no preconditioning at all c diag exact Hessian diagonal preconditioning c block 3x3 block diagonal preconditioning c ssor symmetric successive over-relaxation c iccg shifted incomplete Cholesky factorization c c subroutine precond (method,iter,nvar,s,r,h,h_init, & h_stop,h_index,h_diag) use inform use iounit implicit none integer i,j,k,ii,kk integer iii,kkk,iter integer nvar,nblock integer ix,iy,iz,icount integer h_init(*) integer h_stop(*) integer h_index(*) integer, allocatable :: c_init(:) integer, allocatable :: c_stop(:) integer, allocatable :: c_index(:) integer, allocatable :: c_value(:) real*8 f_i,f_k real*8 omega,factor real*8 maxalpha,alpha real*8 a(6),b(3) real*8 h_diag(*) real*8 h(*) real*8 s(*) real*8 r(*) real*8, allocatable :: diag(:) real*8, allocatable :: f_diag(:) real*8, allocatable :: f(:) logical stable character*6 method save f,f_diag,stable c c c perform dynamic allocation of some local arrays c if (method .eq. 'SSOR') allocate (diag(nvar)) if (method .eq. 'ICCG') then if (iter .eq. 0) then allocate (c_init(nvar)) allocate (c_stop(nvar)) allocate (c_index((nvar*(nvar-1))/2)) allocate (c_value((nvar*(nvar-1))/2)) end if if (.not. allocated(f_diag)) allocate (f_diag(nvar)) if (.not. allocated(f)) allocate (f((nvar*(nvar-1))/2)) end if c c use no preconditioning, using M = identity matrix c if (method .eq. 'NONE') then do i = 1, nvar s(i) = r(i) end do end if c c diagonal preconditioning, using M = abs(Hessian diagonal) c if (method .eq. 'DIAG') then do i = 1, nvar s(i) = r(i) / abs(h_diag(i)) end do end if c c block diagonal preconditioning with exact atom blocks c (using M = 3x3 blocks from diagonal of full Hessian) c if (method .eq. 'BLOCK') then nblock = 3 do i = 1, nvar/3 iz = 3 * i iy = iz - 1 ix = iz - 2 a(1) = h_diag(ix) if (h_index(h_init(ix)) .eq. iy) then a(2) = h(h_init(ix)) else a(2) = 0.0d0 end if if (h_index(h_init(ix)+1) .eq. iz) then a(3) = h(h_init(ix)+1) else a(3) = 0.0d0 end if a(4) = h_diag(iy) if (h_index(h_init(iy)) .eq. iz) then a(5) = h(h_init(iy)) else a(5) = 0.0d0 end if a(6) = h_diag(iz) b(1) = r(ix) b(2) = r(iy) b(3) = r(iz) call cholesky (nblock,a,b) s(ix) = b(1) s(iy) = b(2) s(iz) = b(3) end do end if c c symmetric successive over-relaxation (SSOR) preconditioning c (using M = (D/w+U)T * (D/w)-1 * (D/w+U) with 0 < w < 2) c if (method .eq. 'SSOR') then omega = 1.0d0 factor = 2.0d0 - omega do i = 1, nvar s(i) = r(i) * factor diag(i) = h_diag(i) / omega end do do i = 1, nvar s(i) = s(i) / diag(i) do j = h_init(i), h_stop(i) k = h_index(j) s(k) = s(k) - h(j)*s(i) end do end do do i = nvar, 1, -1 s(i) = s(i) * diag(i) do j = h_init(i), h_stop(i) k = h_index(j) s(i) = s(i) - h(j)*s(k) end do s(i) = s(i) / diag(i) end do end if c c factorization phase of incomplete cholesky preconditioning c if (method.eq.'ICCG' .and. iter.eq.0) then call column (nvar,h_init,h_stop,h_index, & c_init,c_stop,c_index,c_value) stable = .true. icount = 0 maxalpha = 2.1d0 alpha = -0.001d0 10 continue if (alpha .le. 0.0d0) then alpha = alpha + 0.001d0 else alpha = 2.0d0 * alpha end if if (alpha .gt. maxalpha) then stable = .false. if (verbose) then write (iout,20) 20 format (' PRECOND -- Incomplete Cholesky is', & ' Unstable, using Diagonal Method') end if else factor = 1.0d0 + alpha do i = 1, nvar f_diag(i) = factor * h_diag(i) do j = c_init(i), c_stop(i) k = c_index(j) f_i = f(c_value(j)) f_diag(i) = f_diag(i) - f_i*f_i*f_diag(k) icount = icount + 1 end do if (f_diag(i) .le. 0.0d0) goto 10 if (f_diag(i) .lt. 1.0d-7) f_diag(i) = 1.0d-7 f_diag(i) = 1.0d0 / f_diag(i) do j = h_init(i), h_stop(i) k = h_index(j) f(j) = h(j) ii = c_init(i) kk = c_init(k) do while (ii.le.c_stop(i) .and. kk.le.c_stop(k)) iii = c_index(ii) kkk = c_index(kk) if (iii .lt. kkk) then ii = ii + 1 else if (kkk .lt. iii) then kk = kk + 1 else f_i = f(c_value(ii)) f_k = f(c_value(kk)) f(j) = f(j) - f_i*f_k*f_diag(iii) ii = ii + 1 kk = kk + 1 icount = icount + 1 end if end do end do end do if (verbose) then write (iout,30) icount,alpha 30 format (' PRECOND -- Incomplete Cholesky',i12, & ' Operations',f8.3,' Alpha Value') end if end if end if c c solution phase of incomplete cholesky preconditioning c if (method .eq. 'ICCG') then if (stable) then do i = 1, nvar s(i) = r(i) end do do i = 1, nvar s(i) = s(i) * f_diag(i) do j = h_init(i), h_stop(i) k = h_index(j) s(k) = s(k) - f(j)*s(i) end do end do do i = nvar, 1, -1 s(i) = s(i) / f_diag(i) do j = h_init(i), h_stop(i) k = h_index(j) s(i) = s(i) - f(j)*s(k) end do s(i) = s(i) * f_diag(i) end do else do i = 1, nvar s(i) = r(i) / abs(h_diag(i)) end do end if end if c c perform deallocation of some local arrays c if (method .eq. 'SSOR') deallocate (diag) if (method .eq. 'ICCG') then if (iter .eq. 0) then deallocate (c_init) deallocate (c_stop) deallocate (c_index) deallocate (c_value) end if end if return end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine torphase -- torsional amplitude and phase ## c ## ## c ############################################################## c c c "torphase" sets the n-fold amplitude and phase values c for each torsion via sorting of the input parameters c c subroutine torphase (ft,vt,st) implicit none integer i,k integer ft(*) real*8 ampli(6) real*8 phase(6) real*8 vt(*),st(*) c c c copy the input fold, amplitude and phase angles c do i = 1, 6 ampli(i) = vt(i) phase(i) = st(i) vt(i) = 0.0d0 st(i) = 0.0d0 end do c c shift the phase angles into the standard range c do i = 1, 6 do while (phase(i) .lt. -180.0d0) phase(i) = phase(i) + 360.0d0 end do do while (phase(i) .gt. 180.0d0) phase(i) = phase(i) - 360.0d0 end do end do c c convert input torsional parameters to storage format c do i = 1, 6 k = ft(i) if (k.ge.1 .and. k.le.6) then vt(k) = ampli(i) st(k) = phase(i) end if 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 torpot -- torsional functional form details ## c ## ## c ############################################################ c c c idihunit convert improper dihedral energy to kcal/mole c itorunit convert improper torsion amplitudes to kcal/mole c torsunit convert torsional parameter amplitudes to kcal/mole c ptorunit convert pi-system torsion energy to kcal/mole c storunit convert stretch-torsion energy to kcal/mole c atorunit convert angle-torsion energy to kcal/mole c ttorunit convert torsion-torsion energy to kcal/mole c c module torpot implicit none real*8 idihunit real*8 itorunit real*8 torsunit real*8 ptorunit real*8 storunit real*8 atorunit real*8 ttorunit save end c c c ############################################################# c ## COPYRIGHT (C) 2007 by Pengyu Ren & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################# c c ################################################################## c ## ## c ## subroutine torque -- convert single site torque to force ## c ## ## c ################################################################## c c c "torque" takes the torque values on a single site defined by c a local coordinate frame and converts to Cartesian forces on c the original site and sites specifying the local frame, also c gives the x,y,z-force components needed for virial computation c c force distribution for the 3-fold local frame by Chao Lu, c Ponder Lab, Washington University, July 2016 c c literature reference: c c P. L. Popelier and A. J. Stone, "Formulae for the First and c Second Derivatives of Anisotropic Potentials with Respect to c Geometrical Parameters", Molecular Physics, 82, 411-425 (1994) c c C. Segui, L. G. Pedersen and T. A. Darden, "Towards an Accurate c Representation of Electrostatics in Classical Force Fields: c Efficient Implementation of Multipolar Interactions in c Biomolecular Simulations", Journal of Chemical Physics, 120, c 73-87 (2004) c c subroutine torque (i,trq,frcx,frcy,frcz,de) use atoms use deriv use mpole implicit none integer i,j integer ia,ib,ic,id real*8 du,dv,dw,dot real*8 usiz,vsiz,wsiz real*8 psiz,rsiz,ssiz real*8 t1siz,t2siz real*8 uvsiz,uwsiz,vwsiz real*8 ursiz,ussiz real*8 vssiz,wssiz real*8 delsiz,dphiddel real*8 uvcos,uwcos,urcos real*8 vwcos,vscos,wscos real*8 upcos,vpcos,wpcos real*8 rwcos,rucos,rvcos real*8 ut1cos,ut2cos real*8 uvsin,uwsin,ursin real*8 vwsin,vssin,wssin real*8 rwsin,rusin,rvsin real*8 ut1sin,ut2sin real*8 dphidu,dphidv,dphidw real*8 dphidr,dphids real*8 trq(3),frcx(3) real*8 frcy(3),frcz(3) real*8 u(3),v(3),w(3) real*8 p(3),r(3),s(3) real*8 t1(3),t2(3) real*8 uv(3),uw(3),vw(3) real*8 ur(3),us(3) real*8 vs(3),ws(3) real*8 del(3),eps(3) real*8 de(3,*) character*8 axetyp c c c zero out force components on local frame-defining atoms c do j = 1, 3 frcz(j) = 0.0d0 frcx(j) = 0.0d0 frcy(j) = 0.0d0 end do c c get the local frame type and the frame-defining atoms c axetyp = polaxe(i) if (axetyp .eq. 'None') return ia = zaxis(i) ib = i ic = xaxis(i) id = abs(yaxis(i)) c c construct the three rotation axes for the local frame c u(1) = x(ia) - x(ib) u(2) = y(ia) - y(ib) u(3) = z(ia) - z(ib) usiz = sqrt(u(1)*u(1) + u(2)*u(2) + u(3)*u(3)) if (axetyp .ne. 'Z-Only') then v(1) = x(ic) - x(ib) v(2) = y(ic) - y(ib) v(3) = z(ic) - z(ib) vsiz = sqrt(v(1)*v(1) + v(2)*v(2) + v(3)*v(3)) else v(1) = 1.0d0 v(2) = 0.0d0 v(3) = 0.0d0 vsiz = 1.0d0 dot = u(1) / usiz if (abs(dot) .gt. 0.866d0) then v(1) = 0.0d0 v(2) = 1.0d0 end if end if if (axetyp.eq.'Z-Bisect' .or. axetyp.eq.'3-Fold') then w(1) = x(id) - x(ib) w(2) = y(id) - y(ib) w(3) = z(id) - z(ib) else w(1) = u(2)*v(3) - u(3)*v(2) w(2) = u(3)*v(1) - u(1)*v(3) w(3) = u(1)*v(2) - u(2)*v(1) end if wsiz = sqrt(w(1)*w(1) + w(2)*w(2) + w(3)*w(3)) do j = 1, 3 u(j) = u(j) / usiz v(j) = v(j) / vsiz w(j) = w(j) / wsiz end do c c build some additional axes for the Z-Bisect local frame c if (axetyp .eq. 'Z-Bisect') then r(1) = v(1) + w(1) r(2) = v(2) + w(2) r(3) = v(3) + w(3) rsiz = sqrt(r(1)*r(1) + r(2)*r(2) + r(3)*r(3)) s(1) = u(2)*r(3) - u(3)*r(2) s(2) = u(3)*r(1) - u(1)*r(3) s(3) = u(1)*r(2) - u(2)*r(1) ssiz = sqrt(s(1)*s(1) + s(2)*s(2) + s(3)*s(3)) do j = 1, 3 r(j) = r(j) / rsiz s(j) = s(j) / ssiz end do end if c c negative of dot product of torque with unit vectors gives c result of infinitesimal rotation around these vectors c dphidu = -trq(1)*u(1) - trq(2)*u(2) - trq(3)*u(3) dphidv = -trq(1)*v(1) - trq(2)*v(2) - trq(3)*v(3) dphidw = -trq(1)*w(1) - trq(2)*w(2) - trq(3)*w(3) if (axetyp .eq. 'Z-Bisect') then dphidr = -trq(1)*r(1) - trq(2)*r(2) - trq(3)*r(3) dphids = -trq(1)*s(1) - trq(2)*s(2) - trq(3)*s(3) end if c c find the perpendicular and angle for each pair of axes c uv(1) = v(2)*u(3) - v(3)*u(2) uv(2) = v(3)*u(1) - v(1)*u(3) uv(3) = v(1)*u(2) - v(2)*u(1) uvsiz = sqrt(uv(1)*uv(1) + uv(2)*uv(2) + uv(3)*uv(3)) uw(1) = w(2)*u(3) - w(3)*u(2) uw(2) = w(3)*u(1) - w(1)*u(3) uw(3) = w(1)*u(2) - w(2)*u(1) uwsiz = sqrt(uw(1)*uw(1) + uw(2)*uw(2) + uw(3)*uw(3)) vw(1) = w(2)*v(3) - w(3)*v(2) vw(2) = w(3)*v(1) - w(1)*v(3) vw(3) = w(1)*v(2) - w(2)*v(1) vwsiz = sqrt(vw(1)*vw(1) + vw(2)*vw(2) + vw(3)*vw(3)) do j = 1, 3 uv(j) = uv(j) / uvsiz uw(j) = uw(j) / uwsiz vw(j) = vw(j) / vwsiz end do if (axetyp .eq. 'Z-Bisect') then ur(1) = r(2)*u(3) - r(3)*u(2) ur(2) = r(3)*u(1) - r(1)*u(3) ur(3) = r(1)*u(2) - r(2)*u(1) ursiz = sqrt(ur(1)*ur(1) + ur(2)*ur(2) + ur(3)*ur(3)) us(1) = s(2)*u(3) - s(3)*u(2) us(2) = s(3)*u(1) - s(1)*u(3) us(3) = s(1)*u(2) - s(2)*u(1) ussiz = sqrt(us(1)*us(1) + us(2)*us(2) + us(3)*us(3)) vs(1) = s(2)*v(3) - s(3)*v(2) vs(2) = s(3)*v(1) - s(1)*v(3) vs(3) = s(1)*v(2) - s(2)*v(1) vssiz = sqrt(vs(1)*vs(1) + vs(2)*vs(2) + vs(3)*vs(3)) ws(1) = s(2)*w(3) - s(3)*w(2) ws(2) = s(3)*w(1) - s(1)*w(3) ws(3) = s(1)*w(2) - s(2)*w(1) wssiz = sqrt(ws(1)*ws(1) + ws(2)*ws(2) + ws(3)*ws(3)) do j = 1, 3 ur(j) = ur(j) / ursiz us(j) = us(j) / ussiz vs(j) = vs(j) / vssiz ws(j) = ws(j) / wssiz end do end if c c find sine and cosine of angles between the rotation axes c uvcos = u(1)*v(1) + u(2)*v(2) + u(3)*v(3) uvsin = sqrt(1.0d0 - uvcos*uvcos) uwcos = u(1)*w(1) + u(2)*w(2) + u(3)*w(3) uwsin = sqrt(1.0d0 - uwcos*uwcos) vwcos = v(1)*w(1) + v(2)*w(2) + v(3)*w(3) vwsin = sqrt(1.0d0 - vwcos*vwcos) if (axetyp .eq. 'Z-Bisect') then urcos = u(1)*r(1) + u(2)*r(2) + u(3)*r(3) ursin = sqrt(1.0d0 - urcos*urcos) vscos = v(1)*s(1) + v(2)*s(2) + v(3)*s(3) vssin = sqrt(1.0d0 - vscos*vscos) wscos = w(1)*s(1) + w(2)*s(2) + w(3)*s(3) wssin = sqrt(1.0d0 - wscos*wscos) end if c c get projection of v and w onto the ru-plane for Z-Bisect c if (axetyp .eq. 'Z-Bisect') then do j = 1, 3 t1(j) = v(j) - s(j)*vscos t2(j) = w(j) - s(j)*wscos end do t1siz = sqrt(t1(1)*t1(1)+t1(2)*t1(2)+t1(3)*t1(3)) t2siz = sqrt(t2(1)*t2(1)+t2(2)*t2(2)+t2(3)*t2(3)) do j = 1, 3 t1(j) = t1(j) / t1siz t2(j) = t2(j) / t2siz end do ut1cos = u(1)*t1(1) + u(2)*t1(2) + u(3)*t1(3) ut1sin = sqrt(1.0d0 - ut1cos*ut1cos) ut2cos = u(1)*t2(1) + u(2)*t2(2) + u(3)*t2(3) ut2sin = sqrt(1.0d0 - ut2cos*ut2cos) end if c c force distribution for Z-Only local coordinate frame c if (axetyp .eq. 'Z-Only') then do j = 1, 3 du = uv(j)*dphidv/(usiz*uvsin) + uw(j)*dphidw/usiz de(j,ia) = de(j,ia) + du de(j,ib) = de(j,ib) - du frcz(j) = frcz(j) + du end do c c force distribution for Z-then-X local coordinate frame c else if (axetyp .eq. 'Z-then-X') then do j = 1, 3 du = uv(j)*dphidv/(usiz*uvsin) + uw(j)*dphidw/usiz dv = -uv(j)*dphidu/(vsiz*uvsin) de(j,ia) = de(j,ia) + du de(j,ic) = de(j,ic) + dv de(j,ib) = de(j,ib) - du - dv frcz(j) = frcz(j) + du frcx(j) = frcx(j) + dv end do c c force distribution for Bisector local coordinate frame c else if (axetyp .eq. 'Bisector') then do j = 1, 3 du = uv(j)*dphidv/(usiz*uvsin) + 0.5d0*uw(j)*dphidw/usiz dv = -uv(j)*dphidu/(vsiz*uvsin) + 0.5d0*vw(j)*dphidw/vsiz de(j,ia) = de(j,ia) + du de(j,ic) = de(j,ic) + dv de(j,ib) = de(j,ib) - du - dv frcz(j) = frcz(j) + du frcx(j) = frcx(j) + dv end do c c force distribution for Z-Bisect local coordinate frame c else if (axetyp .eq. 'Z-Bisect') then do j = 1, 3 du = ur(j)*dphidr/(usiz*ursin) + us(j)*dphids/usiz dv = (vssin*s(j)-vscos*t1(j))*dphidu & / (vsiz*(ut1sin+ut2sin)) dw = (wssin*s(j)-wscos*t2(j))*dphidu & / (wsiz*(ut1sin+ut2sin)) de(j,ia) = de(j,ia) + du de(j,ic) = de(j,ic) + dv de(j,id) = de(j,id) + dw de(j,ib) = de(j,ib) - du - dv - dw frcz(j) = frcz(j) + du frcx(j) = frcx(j) + dv frcy(j) = frcy(j) + dw end do c c force distribution for 3-Fold local coordinate frame c else if (axetyp .eq. '3-Fold') then p(1) = u(1) + v(1) + w(1) p(2) = u(2) + v(2) + w(2) p(3) = u(3) + v(3) + w(3) psiz = sqrt(p(1)*p(1)+p(2)*p(2)+p(3)*p(3)) do j = 1, 3 p(j) = p(j) / psiz end do wpcos = w(1)*p(1) + w(2)*p(2) + w(3)*p(3) upcos = u(1)*p(1) + u(2)*p(2) + u(3)*p(3) vpcos = v(1)*p(1) + v(2)*p(2) + v(3)*p(3) r(1) = u(1) + v(1) r(2) = u(2) + v(2) r(3) = u(3) + v(3) rsiz = sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3)) do j = 1, 3 r(j) = r(j) / rsiz end do rwcos = r(1)*w(1) + r(2)*w(2) + r(3)*w(3) rwsin = sqrt(1.0d0 - rwcos*rwcos) dphidr = -trq(1)*r(1) - trq(2)*r(2) - trq(3)*r(3) del(1) = r(2)*w(3) - r(3)*w(2) del(2) = r(3)*w(1) - r(1)*w(3) del(3) = r(1)*w(2) - r(2)*w(1) delsiz = sqrt(del(1)*del(1)+del(2)*del(2)+del(3)*del(3)) do j = 1, 3 del(j) = del(j) / delsiz end do dphiddel = -trq(1)*del(1) - trq(2)*del(2) - trq(3)*del(3) eps(1) = del(2)*w(3) - del(3)*w(2) eps(2) = del(3)*w(1) - del(1)*w(3) eps(3) = del(1)*w(2) - del(2)*w(1) do j = 1, 3 dw = del(j)*dphidr/(wsiz*rwsin) & + eps(j)*dphiddel*wpcos/(wsiz*psiz) de(j,id) = de(j,id) + dw de(j,ib) = de(j,ib) - dw frcy(j) = frcy(j) + dw end do r(1) = v(1) + w(1) r(2) = v(2) + w(2) r(3) = v(3) + w(3) rsiz = sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3)) do j = 1, 3 r(j) = r(j) / rsiz end do rucos = r(1)*u(1) + r(2)*u(2) + r(3)*u(3) rusin = sqrt(1.0d0 - rucos*rucos) dphidr = -trq(1)*r(1) - trq(2)*r(2) - trq(3)*r(3) del(1) = r(2)*u(3) - r(3)*u(2) del(2) = r(3)*u(1) - r(1)*u(3) del(3) = r(1)*u(2) - r(2)*u(1) delsiz = sqrt(del(1)*del(1)+del(2)*del(2)+del(3)*del(3)) do j = 1, 3 del(j) = del(j) / delsiz end do dphiddel = -trq(1)*del(1) - trq(2)*del(2) - trq(3)*del(3) eps(1) = del(2)*u(3) - del(3)*u(2) eps(2) = del(3)*u(1) - del(1)*u(3) eps(3) = del(1)*u(2) - del(2)*u(1) do j = 1, 3 du = del(j)*dphidr/(usiz*rusin) & + eps(j)*dphiddel*upcos/(usiz*psiz) de(j,ia) = de(j,ia) + du de(j,ib) = de(j,ib) - du frcz(j) = frcz(j) + du end do r(1) = u(1) + w(1) r(2) = u(2) + w(2) r(3) = u(3) + w(3) rsiz = sqrt(r(1)*r(1)+r(2)*r(2)+r(3)*r(3)) do j = 1, 3 r(j) = r(j) / rsiz end do rvcos = r(1)*v(1) + r(2)*v(2) + r(3)*v(3) rvsin = sqrt(1.0d0 - rvcos*rvcos) dphidr = -trq(1)*r(1) - trq(2)*r(2) - trq(3)*r(3) del(1) = r(2)*v(3) - r(3)*v(2) del(2) = r(3)*v(1) - r(1)*v(3) del(3) = r(1)*v(2) - r(2)*v(1) delsiz = sqrt(del(1)*del(1)+del(2)*del(2)+del(3)*del(3)) do j = 1, 3 del(j) = del(j) / delsiz end do dphiddel = -trq(1)*del(1) - trq(2)*del(2) - trq(3)*del(3) eps(1) = del(2)*v(3) - del(3)*v(2) eps(2) = del(3)*v(1) - del(1)*v(3) eps(3) = del(1)*v(2) - del(2)*v(1) do j = 1, 3 dv = del(j)*dphidr/(vsiz*rvsin) & + eps(j)*dphiddel*vpcos/(vsiz*psiz) de(j,ic) = de(j,ic) + dv de(j,ib) = de(j,ib) - dv frcx(j) = frcx(j) + dv 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 tors -- torsional angles in current structure ## c ## ## c ############################################################## c c c ntors total number of torsional angles in the system c itors numbers of the atoms in each torsional angle c tors1 1-fold amplitude and phase for each torsional angle c tors2 2-fold amplitude and phase for each torsional angle c tors3 3-fold amplitude and phase for each torsional angle c tors4 4-fold amplitude and phase for each torsional angle c tors5 5-fold amplitude and phase for each torsional angle c tors6 6-fold amplitude and phase for each torsional angle c c module tors implicit none integer ntors integer, allocatable :: itors(:,:) real*8, allocatable :: tors1(:,:) real*8, allocatable :: tors2(:,:) real*8, allocatable :: tors3(:,:) real*8, allocatable :: tors4(:,:) real*8, allocatable :: tors5(:,:) real*8, allocatable :: tors6(:,:) save end c c c ############################################################## c ## COPYRIGHT (C) 2010 by Chuanjie Wu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ################################################################# c ## ## c ## program torsfit -- fit torsional force field parameters ## c ## ## c ################################################################# c c c "torsfit" refines torsional force field parameters based on c a quantum mechanical potential surface and analytical gradient c c program torsfit use files use inform use iounit use keys implicit none integer i,length integer torbnd(10) logical exist,query character*240 record character*240 string character*240 xyzfile c c c get the Cartesian coordinates and connectivity info c call initial call getxyz xyzfile = filename length = leng c c find keyword options and setup force field parameters c call getkey call mechanic c c choose the first torsion based on the center bond atoms c do i = 1, 10 torbnd(i) = 0 end do query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) torbnd(1),torbnd(2) query = .false. end if 10 continue if (query) then do while (torbnd(1).eq.0 .or. torbnd(2).eq.0) write (iout,20) 20 format (/,' Enter Central Atoms of First Torsion : ',$) read (input,*,err=30,end=30) torbnd(1),torbnd(2) 30 continue end do end if c c choose the second torsion based on the center bond atoms c query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=40,end=40) torbnd(3),torbnd(4) query = .false. end if 40 continue if (query) then write(iout,50) 50 format (/,' Enter Central Atoms for 2nd Torsion', & ' [Optional, =None] : ',$) read (input,60,err=70,end=70) record 60 format (a240) read (record,*,err=70,end=70) torbnd(3),torbnd(4) 70 continue end if c c fit the torsional parameters based on potential surface c call fittors (torbnd) c c perform any final tasks before program exit c call final end c c c ############################################################## c ## ## c ## subroutine fittors -- torsional parameter refinement ## c ## ## c ############################################################## c c c "fittors" refines torsion parameters based on a quantum c mechanical optimized energy surface c c subroutine fittors (torbnd) use atoms use atomid use files use inform use iounit use keys use ktorsn use math use output use potent use qmstuf use restrn use scales use tors use usage implicit none integer maxfit,maxconf parameter (maxfit=12) parameter (maxconf=500) integer i,j,k,ii,jj,kk integer ia,ib,ic,id integer ita,itb,itc,itd integer itmpa,itmpb,otfix integer ntorfit,ntorcrs integer nconf,size integer oldleng,oldnkey integer istep,maxstep integer nvxx,ivxx integer ikey,nvar integer freeunit integer trimtext integer torbnd(*) integer ctorid(maxfit) integer ftorid(maxfit) integer tflg(maxfit) integer torcrs(4,maxfit) integer cflg(9*maxfit) integer refconf(maxconf) real*8 tmpa,tmpb,tv,vcon real*8 eqmmin,emmmin real*8 rms,zrms,avedl real*8 minimum,grdmin real*8 energy,torfit1 real*8 geometry real*8 vxx(6*maxfit) real*8 vxxl(6*maxfit) real*8 eqm(maxconf) real*8 emm(maxconf) real*8 erqm(maxconf) real*8 ermm(maxconf) real*8 delte(maxconf) real*8 fwt(maxconf) real*8 torf(maxconf) real*8, allocatable :: xx(:) real*8 tord(6*maxfit,6*maxfit) real*8 mata(6*maxfit,6*maxfit) real*8 ftv(maxconf,maxfit) real*8 rftv(maxconf,maxfit) real*8 coeff(maxconf,6*maxfit) real*8 ctv(maxconf,9*maxfit) logical done logical vflg(6,maxfit) logical confvisited(maxconf) character*4 pa,pb,pc,pd character*16 kft(maxfit) character*16 kct(9*maxfit) character*240 record character*240 keyfile character*240 oldfilename character*240, allocatable :: oldkeyline(:) external torfit1 external optsave c c c set initial values c ntorfit = 0 ntorcrs = 0 otfix = ntfix istep = 0 tv = 0.0d0 vcon = 0.5d0 do i = 1, maxfit ftorid(i) = 0 tflg(i) = 0 do j = 1, 6 vflg(j,i) = .false. end do end do do i = 1, 6*maxfit vxx(i) = 0.0d0 vxxl(i) = 0.1d0 avedl = 0.0d0 do j = 1, 6*maxfit tord(i,j) = 0.0d0 end do end do do i = 1, 9*maxfit cflg(i) = 0 end do do i = 1, maxconf fwt(i) = 1.0d0 torf(i) = 0.0d0 confvisited(i) = .false. end do do i = 1, maxconf do j = 1, 6*maxfit coeff(i,j) = 0.0d0 end do refconf = 0 end do grdmin = 0.01 if (torbnd(1) .gt. torbnd(2)) then itmpa = torbnd(1) torbnd(1) = torbnd(2) torbnd(2) = itmpa end if c c perform dynamic allocation of some local arrays c allocate (oldkeyline(nkey)) c c store the information from the keyfile c oldfilename = filename oldleng = leng oldnkey = nkey do i = 1, nkey oldkeyline(i) = keyline(i) end do c c check all the torsions cross the two center bond atoms c write (iout,10) 10 format (/,' Torsions Crossing the Central Bond :',/) do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) itmpa = ib itmpb = ic if (itmpa .gt. itmpb) then j = itmpa itmpa = itmpb itmpb = j end if if ((torbnd(1).eq.itmpa .and. torbnd(2).eq.itmpb) .or. & (torbnd(3).eq.itmpa .and. torbnd(4).eq.itmpb)) then ntorcrs = ntorcrs + 1 torcrs(1,ntorcrs) = ia torcrs(2,ntorcrs) = ib torcrs(3,ntorcrs) = ic torcrs(4,ntorcrs) = id ctorid(ntorcrs) = i write (iout,20) ntorcrs,ia,name(ia),ib,name(ib), & ic,name(ic),id,name(id) 20 format (' Torsion',i5,' :',3x,4(i6,'-',a3)) end if end do c c choose the specific torsions for fitting c write (iout,30) 30 format (/,' Choose Torsions for Fitting from Above List : ',$) read (input,40,err=50,end=50) record 40 format (a240) 50 continue read (record,*,err=60,end=60) (ftorid(i),i=1,ntorcrs) 60 continue c c count the torsions to be fitted c do i = 1, ntorcrs if (ftorid(i) .gt. 0) ntorfit = ntorfit + 1 end do c c get the number of conformations for fitting c write (iout,70) 70 format (/,' Enter Total Number of Conformations : ',$) read (input,*,err=80,end=80) nconf 80 continue c c read the QM coordinates and conformations energies c do i = 1, nconf call readgau write (iout,90) i 90 format (/ ,' Finished Reading Conformation',i4) do j = 1, n x(j) = gx(j) y(j) = gy(j) z(j) = gz(j) end do call makeref (i) eqm(i) = egau end do c c calculate the relative QM conformational energies c eqmmin = eqm(1) do i = 2, nconf if (eqm(i) .lt. eqmmin) eqmmin = eqm(i) end do write (iout,100) 100 format () do i = 1, nconf erqm(i) = eqm(i) - eqmmin write (iout,110) i,erqm(i) 110 format (' Relative Conformational Energy (QM)',i8,f12.4, & ' Kcal/mole') end do c c get fitting torsion type (atom classes) c do i = 1, ntorfit j = ftorid(i) k = ctorid(j) ia = itors(1,k) ib = itors(2,k) ic = itors(3,k) id = itors(4,k) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .le. itc) then kft(i) = pa//pb//pc//pd else kft(i) = pd//pc//pb//pa end if end do c c get all the cross torsion types c do i = 1, ntorcrs k = ctorid(i) ia = itors(1,k) ib = itors(2,k) ic = itors(3,k) id = itors(4,k) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .le. itc) then kct(i) = pa//pb//pc//pd else kct(i) = pd//pc//pb//pa end if end do c c initialize the torsion and geometry restrain parameters c write (iout,120) 120 format (/,' Initial Torsional Parameters:',/) nvxx = 0 do i = 1, ntorfit j = ftorid(i) k = ctorid(j) done = .false. tflg(i) = 0 ia = itors(1,k) ib = itors(2,k) ic = itors(3,k) id = itors(4,k) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) write (iout,130) ita,itb,itc,itd,tors1(1,k),tors2(1,k), & tors3(1,k),tors4(1,k),tors5(1,k),tors6(1,k) 130 format (' torsion ',4i4,6f8.3) do ii = 1, i-1 jj = ftorid(ii) kk = ctorid(jj) if (kft(i) .eq. kft(ii)) then done = .true. tflg(i) = ii goto 150 end if end do do ii = 1, ntorcrs if (kct(ii).eq.kft(i) .and. ii.ne.j) cflg(ii) = j end do if (abs(tors1(1,k)) .gt. 0.0d0) then nvxx = nvxx +1 vxx(nvxx) = tors1(1,k) vflg(1,i) = .true. end if tors1(1,k) = 0.0d0 tors1(2,k) = 0.0d0 if (abs(tors2(1,k)) .gt. 0.0d0) then nvxx = nvxx +1 vxx(nvxx) = tors2(1,k) vflg(2,i) = .true. end if tors2(1,k) = 0.0d0 tors2(2,k) = 180.0d0 if (abs(tors3(1,k)) .gt. 0.0d0) then nvxx = nvxx +1 vxx(nvxx) = tors3(1,k) vflg(3,i) = .true. end if tors3(1,k) = 0.0d0 tors3(2,k) = 0.0d0 if (abs(tors4(1,k)) .gt. 0.0d0) then nvxx = nvxx +1 vxx(nvxx) = tors4(1,k) vflg(4,i) = .true. end if tors4(1,k) = 0.0d0 tors4(2,k) = 180.0d0 if (abs(tors5(1,k)) .gt. 0.0d0) then nvxx = nvxx +1 vxx(nvxx) = tors5(1,k) vflg(5,i) = .true. end if tors5(1,k) = 0.0d0 tors5(2,k) = 0.0d0 if (abs(tors6(1,k)) .gt. 0.0d0) then nvxx = nvxx +1 vxx(nvxx) = tors6(1,k) vflg(6,i) = .true. end if tors6(1,k) = 0.0d0 tors6(2,k) = 180.0d0 ntfix = ntfix+1 itfix(1,ntfix) = ia itfix(2,ntfix) = ib itfix(3,ntfix) = ic itfix(4,ntfix) = id tfix(1,ntfix) = 5.0d0 write (iout,140) ia,ib,ic,id 140 format (' Fixed Torsion',3x,4i6) 150 continue end do c c print torsion flags (check duplicated torsion types) c do i = 1, ntorfit write (iout,160) i,tflg(i) 160 format (/,' Fitting Torsion Number',i5,5x,'Flag',i5) do j = 1, 6 write (iout,170) i,j,vflg(j,i) 170 format (' Variable',2i4,5x,'Variable Flag',l5) end do end do c c print torsion flags for all the torsions across the bond c write (iout,180) 180 format (/,' All the Torsions Across the Bond :') do i = 1, ntorcrs k = ctorid(i) if (cflg(i) .gt. 0) then tors1(1,k) = 0.0d0 tors2(1,k) = 0.0d0 tors3(1,k) = 0.0d0 tors4(1,k) = 0.0d0 tors5(1,k) = 0.0d0 tors6(1,k) = 0.0d0 end if write (iout,190) i,cflg(i) 190 format (' Fitting Torsion Number',i5,5x,'Flag',i5) end do c c add one constant variable c nvxx = nvxx + 1 vxx(nvxx) = vcon c c perform dynamic allocation of some global arrays c if (.not. allocated(scale)) allocate (scale(3*n)) c c get initial energy difference c do i = 1, nconf call getref (i) kk = 0 do j = 1, ntorfit k = ftorid(j) ia = torcrs(1,k) ib = torcrs(2,k) ic = torcrs(3,k) id = torcrs(4,k) ftv(i,j) = geometry (ia,ib,ic,id) write (iout,200) i,j,ftv(i,j) 200 format (' Fitting Torsion Value',2i5,f12.4) if (tflg(j) .eq. 0) then kk = kk+1 tfix(2,otfix+kk) = ftv(i,j) tfix(3,otfix+kk) = tfix(2,otfix+kk) end if end do do k = 1, ntorcrs ia = torcrs(1,k) ib = torcrs(2,k) ic = torcrs(3,k) id = torcrs(4,k) ctv(i,k) = geometry (ia,ib,ic,id) end do c c perform dynamic allocation of some local arrays c allocate (xx(3*nuse)) c c scale the coordinates of each active atom c nvar = 0 do j = 1, n if (use(j)) then nvar = nvar + 1 scale(nvar) = 12.0d0 xx(nvar) = x(j) * scale(nvar) nvar = nvar + 1 scale(nvar) = 12.0d0 xx(nvar) = y(j) * scale(nvar) nvar = nvar + 1 scale(nvar) = 12.0d0 xx(nvar) = z(j) * scale(nvar) end if end do c c make the call to the optimization routine c write (iout,210) i 210 format (/,' Minimizing Structure',i6) coordtype = 'CARTESIAN' use_geom = .true. grdmin = 0.01d0 iwrite = 0 iprint = 0 call lbfgs (nvar,xx,minimum,grdmin,torfit1,optsave) c c unscale the final coordinates for active atoms c nvar = 0 do j = 1, n if (use(j)) then nvar = nvar + 1 x(j) = xx(nvar) / scale(nvar) nvar = nvar + 1 y(j) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(j) = xx(nvar) / scale(nvar) end if end do c c perform deallocation of some local arrays c deallocate (xx) c c set the energy value for the current minimum c emm(i) = energy () end do c c calculate relative value for each torsional angle c do i = 1, nconf do j = 1, ntorfit rftv(i,j) = ftv(i,j) - ftv(i,1) end do end do c c calculate the relative MM energies c emmmin = emm(1) do i = 2, nconf if (emm(i) .lt. emmmin) emmmin = emm(i) end do c c calculate the energy difference and RMS c rms = 0.0d0 zrms = 0.0d0 write (iout,220) 220 format () do i = 1, nconf ermm (i) = emm(i) - emmmin delte (i) = erqm (i) - ermm(i) rms = rms + delte(i)*delte(i) write (iout,230) i,ermm(i) 230 format (' Relative Conformational Energy (MM)',i8,f12.4, & ' Kcal/mole') end do rms = sqrt(rms/dble(nconf)) zrms = rms write (iout,240) rms 240 format (/,' Energy RMS Difference :',8x,f12.4) c c calculate the weights c c do i = 1, nconf c do j = 1, nconf c if (.not. confvisited(j)) then c tmpa = ftv(j,1) c itmpa = j c confvisited(j) = .true. c goto 241 c end if c end do c 241 continue c do j = 1, nconf c if (ftv(j,1).lt.tmpa .and. .not.confvisited(j)) then c confvisited(itmpa) = .false. c itmpa = j c tmpa = ftv(j,1) c end if c end do c refconf(itmpa) = i c confvisited(itmpa) = .true. c write (iout,242) itmpa,refconf(itmpa) c 242 format (i8,' <===> ',i8) c end do if (nconf .gt. 1 .and. torbnd(3) .eq. 0) then if ((ftv(nconf,1)+180.0d0) .lt. 1.0d0 & .and. ftv(nconf-1,1) .gt. 0.0d0) & ftv(nconf,1) = 180.0d0 tmpa = erqm(2) - erqm(1) tmpb = (ftv(2,1)-ftv(1,1)) / radian fwt(1) = 1.0d0 / sqrt(1.0d0+(tmpa/tmpb)**2) if (nconf .gt. 2) then do i = 2, nconf-1 tmpa = erqm(i+1) - erqm(i-1) tmpb = (ftv(i+1,1) - ftv(i-1,1))/radian fwt(i) = 1.0d0 / sqrt(1.0d0+(tmpa/tmpb)**2) end do end if tmpa = erqm(nconf) - erqm(nconf-1) tmpb = (ftv(nconf,1) - ftv(nconf-1,1))/radian fwt(nconf) = 1.0d0 / sqrt(1.0d0+(tmpa/tmpb)**2) end if write (iout,250) 250 format () do i = 1, nconf write (iout,260) i,fwt(i) 260 format (' Conformation',i5,5x,'Weight',f8.4) end do c c set initial values for torsions to be fitted c ivxx = 0 do i = 1, ntorfit j = ftorid(i) k = ctorid(j) do ii = 1, 6 if (vflg(ii,i) .and. tflg(i).eq.0) then ivxx = ivxx + 1 if (ii .eq. 1) then tors1(1,k) = vxx(ivxx) else if (ii .eq. 2) then tors2(1,k) = vxx(ivxx) else if (ii .eq. 3) then tors3(1,k) = vxx(ivxx) else if (ii .eq. 4) then tors4(1,k) = vxx(ivxx) else if (ii .eq. 5) then tors5(1,k) = vxx(ivxx) else if (ii .eq. 6) then tors6(1,k) = vxx(ivxx) end if do jj = 1, ntorfit kk = ctorid(ftorid(jj)) if (tflg(jj) .eq. i) then if (ii .eq. 1) then tors1(1,kk) = vxx(ivxx) else if (ii .eq. 2) then tors2(1,kk) = vxx(ivxx) else if (ii .eq. 3) then tors3(1,kk) = vxx(ivxx) else if (ii .eq. 4) then tors4(1,kk) = vxx(ivxx) else if (ii .eq. 5) then tors5(1,kk) = vxx(ivxx) else if (ii .eq. 6) then tors6(1,kk) = vxx(ivxx) end if end if end do end if end do ivxx = ivxx + 1 vcon = vxx(ivxx) end do c c fitting the torsion parameters c write (iout,270) 270 format () maxstep = 1 avedl = 0.5d0 do while (avedl.gt.0.1d0 .and. istep.lt.maxstep) do i = 1, nconf ivxx = 0 torf(i) = 0.0d0 do j = 1, ntorfit jj = ftorid(j) kk = ctorid(jj) ia = itors(1,kk) ib = itors(2,kk) ic = itors(3,kk) id = itors(4,kk) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) tv = ftv(i,j) / radian tmpa = tors1(1,kk)*(1+cos(tv)) & + tors2(1,kk)*(1-cos(2*tv)) & + tors3(1,kk)*(1+cos(3*tv)) & + tors4(1,kk)*(1-cos(4*tv)) & + tors5(1,kk)*(1+cos(5*tv)) & + tors6(1,kk)*(1-cos(6*tv)) torf(i) = torf(i) + 0.5*tmpa do ii = 1, 6 if (vflg(ii,j) .and. tflg(j).eq.0) then ivxx = ivxx +1 coeff(i,ivxx) = 0.5*(1+(-1)**(ii+1) & *cos(dble(ii)*tv)) do k = 1, ntorcrs if (cflg(k).gt.0 .and. cflg(k).eq.jj) then coeff(i,ivxx) = coeff(i,ivxx) & +0.5*(1+(-1)**(ii+1) & *cos(dble(ii)*ctv(i,k)/radian)) end if end do write (iout,280) i,ivxx,coeff(i,ivxx) 280 format (' Derivative :',5x,2i4,f8.4) end if end do end do torf(i) = torf(i) + vcon - delte(i) ivxx = ivxx + 1 coeff(i,ivxx) = 1.0d0 write (iout,290) i,torf(i) 290 format (' Energy Difference :',i8,f12.4) end do c c set matrix elements for matrix A c do i = 1, nvxx do j = 1, nvxx tord(i,j) = 0.0d0 do k = 1, nconf tord(i,j) = tord(i,j) + coeff(k,i)*coeff(k,j)*fwt(k) end do end do end do c c print the matrix A elements c write (iout,300) nvxx 300 format (/,' Total Variable Number ',i8) write (iout,310) 310 format (/,' Matrix A Elements :') do i = 1, nvxx do j = 1, nvxx mata(i,j) = tord(i,j) end do write (iout,320) (mata(i,j),j=1,nvxx) 320 format (1x,5f12.4) end do c c multiply vector: Yi * Coeff * Weight c do i = 1, nvxx torf(i) = 0.0d0 do j = 1, nconf torf(i) = torf(i) + delte(j)*fwt(j)*coeff(j,i) end do end do do i = 1, nvxx mata(i,nvxx+1) = torf(i) end do c c solve the linear equations via Gauss-Jordan elimination c call gaussjordan (nvxx,mata) c c get new torsion force constants c do i = 1, nvxx vxx(i) = mata(i,nvxx+1) end do ivxx = 0 do i = 1, ntorfit j = ftorid(i) k = ctorid(j) do ii = 1, 6 if (vflg(ii,i) .and. tflg(i).eq.0) then ivxx = ivxx + 1 if (ii .eq. 1) then tors1(1,k) = vxx(ivxx) else if (ii .eq. 2) then tors2(1,k) = vxx(ivxx) else if (ii .eq. 3) then tors3(1,k) = vxx(ivxx) else if (ii .eq. 4) then tors4(1,k) = vxx(ivxx) else if (ii .eq. 5) then tors5(1,k) = vxx(ivxx) else if (ii .eq. 6) then tors6(1,k) = vxx(ivxx) end if do jj = 1, ntorcrs kk = ctorid(jj) if (cflg(j).gt.0 .and. cflg(jj).eq.j) then if (ii .eq. 1) then tors1(1,kk) = vxx(ivxx) else if (ii .eq. 2) then tors2(1,kk) = vxx(ivxx) else if (ii .eq. 3) then tors3(1,kk) = vxx(ivxx) else if (ii .eq. 4) then tors4(1,kk) = vxx(ivxx) else if (ii .eq. 5) then tors5(1,kk) = vxx(ivxx) else if (ii .eq. 6) then tors6(1,kk) = vxx(ivxx) end if end if end do end if end do ivxx = ivxx + 1 vcon = vxx(ivxx) end do istep = istep + 1 end do c c validate the fitted results c write (iout,330) 330 format () do i = 1, nconf call getref (i) kk = 0 do j = 1, ntorfit k = ftorid(j) ia = torcrs(1,k) ib = torcrs(2,k) ic = torcrs(3,k) id = torcrs(4,k) ftv(i,j) = geometry (ia,ib,ic,id) if (tflg(j) .eq. 0) then kk = kk + 1 tfix(2,otfix+kk) = ftv(i,j) tfix(3,otfix+kk) = tfix(2,otfix+kk) end if end do c c perform dynamic allocation of some local arrays c allocate (xx(3*nuse)) c c scale the coordinates of each active atom c nvar = 0 do j = 1, n if (use(j)) then nvar = nvar + 1 xx(nvar) = x(j) * scale(nvar) nvar = nvar + 1 xx(nvar) = y(j) * scale(nvar) nvar = nvar + 1 xx(nvar) = z(j) * scale(nvar) end if end do c c make the call to the optimization routine c write (iout,340) i 340 format (' Minimizing Structure',i5,2x,'with New Parameters') coordtype = 'CARTESIAN' call lbfgs (nvar,xx,minimum,grdmin,torfit1,optsave) c c unscale the final coordinates for active atoms c nvar = 0 do j = 1, n if (use(j)) then nvar = nvar + 1 x(j) = xx(nvar) / scale(nvar) nvar = nvar + 1 y(j) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(j) = xx(nvar) / scale(nvar) end if end do c c perform deallocation of some local arrays c deallocate (xx) c c set the energy value for the current minimum c emm(i) = energy () end do c c calculate the relative MM energies c emmmin = emm(1) do i = 2, nconf if (emm(i) .lt. emmmin) emmmin = emm(i) end do c c calculate the energy difference and RMS c rms = 0.0d0 write (iout,350) 350 format () do i = 1, nconf ermm (i) = emm(i) - emmmin delte (i) = erqm (i) - ermm(i) rms = rms + delte(i)*delte(i) write (iout,360) i,ermm(i) 360 format (' Relative Conformational Energy (MM)',i8,f12.4, & ' Kcal/mole') end do rms = sqrt(rms/dble(nconf)) write (iout,370) rms 370 format (/,' Energy RMS With Fitting Parmeters :',8x,f12.4) if (rms .gt. zrms ) then write (iout,380) zrms 380 format (/,' Annihilating the Torsions is Preferable', & /,' Final RMS :',f12.6,' Kcal/mole',/) end if c c output keyfile information with the fitted parameters c filename = oldfilename leng = oldleng nkey = oldnkey do i = 1, nkey keyline(i) = oldkeyline(i) end do c c perform deallocation of some local arrays c deallocate (oldkeyline) c c output some definitions and parameters to a keyfile c ikey = freeunit () keyfile = filename(1:leng)//'.key' call version (keyfile,'new') open (unit=ikey,file=keyfile,status='new') c c copy the contents of any previously existing keyfile c do i = 1, nkey record = keyline(i) size = trimtext (record) write (ikey,390) record(1:size) 390 format (a) end do c c list the valence parameters c write (ikey,400) 400 format (/,'#',/,'# Results of Valence Parameter Fitting', & /,'#',/) write (iout,410) 410 format (/,' Optimized Torsional Parameters:',/) do i = 1, ntorfit if (tflg(i) .eq. 0) then j = ftorid(i) k = ctorid(j) ia = itors(1,k) ib = itors(2,k) ic = itors(3,k) id = itors(4,k) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) if (rms .gt. zrms) then tors1(1,k) = 0.0d0 tors2(1,k) = 0.0d0 tors3(1,k) = 0.0d0 end if write (iout,420) ita,itb,itc,itd,tors1(1,k), & tors2(1,k),tors3(1,k) 420 format (' torsion ',4i4,f8.3,' 0.0 1 ',f8.3, & ' 180.0 2 ',f8.3,' 0.0 3') write (ikey,430) ita,itb,itc,itd,tors1(1,k), & tors2(1,k),tors3(1,k) 430 format (' torsion ',4i4,f8.3,' 0.0 1 ',f8.3, & ' 180.0 2 ',f8.3,' 0.0 3') end if end do close (unit=ikey) return end c c c ############################################################ c ## ## c ## subroutine gaussjordan -- Gauss-Jordan elimination ## c ## ## c ############################################################ c c c "gaussjordan" solves a system of linear equations by using c the method of Gaussian elimination with partial pivoting c c subroutine gaussjordan (n,a) use iounit implicit none integer maxfit parameter (maxfit=12) integer i,j,k,l,n real*8 t,av real*8 a(6*maxfit,*) c c c perform the Gauss-Jordan elimination procedure c do k = 1, n-1 av = 0.0d0 do i = k, n if (abs(a(i,k)) .gt. abs(av)) then av = a(i,k) l = i end if end do if (abs(av) .lt. 1.0d-8) then write (iout,10) 10 format (/,' GAUSSJORDAN -- Singular Coefficient Matrix') call fatal end if if (l .ne. k) then do j = k, n+1 t = a(k,j) a(k,j) = a(l,j) a(l,j) = t end do end if av = 1.0d0 / av do j = k+1, n+1 a(k,j) = a(k,j) * av do i = k+1, n a(i,j) = a(i,j) - a(i,k)*a(k,j) end do end do end do a(n,n+1) = a(n,n+1) / a(n,n) do k = 1, n-1 i = n - k av = 0.0d0 do j = i+1, n av = av + a(i,j)*a(j,n+1) end do a(i,n+1) = a(i,n+1) - av end do return end c c c ############################################################## c ## ## c ## function torfit1 -- energy and gradient for minimize ## c ## ## c ############################################################## c c c "torfit1" is a service routine that computes the energy and c gradient for a low storage BFGS optimization in Cartesian c coordinate space c c function torfit1 (xx,g) use atoms use scales use usage implicit none integer i,nvar real*8 torfit1,e real*8 energy,eps real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) logical analytic external energy c c c use either analytical or numerical gradients c analytic = .true. eps = 0.00001d0 c c convert optimization parameters to atomic coordinates c nvar = 0 do i = 1, n if (use(i)) then nvar = nvar + 1 x(i) = xx(nvar) / scale(nvar) nvar = nvar + 1 y(i) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(i) = xx(nvar) / scale(nvar) end if end do c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute and store the energy and gradient c if (analytic) then call gradient (e,derivs) else e = energy () call numgrad (energy,derivs,eps) end if torfit1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, n if (use(i)) then nvar = nvar + 1 g(nvar) = derivs(1,i) / scale(nvar) nvar = nvar + 1 g(nvar) = derivs(2,i) / scale(nvar) nvar = nvar + 1 g(nvar) = derivs(3,i) / scale(nvar) end if end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ########################################################## c ## ## c ## subroutine torsions -- locate and store torsions ## c ## ## c ########################################################## c c c "torsions" finds the total number of torsional angles and c the numbers of the four atoms defining each torsional angle c c subroutine torsions use atoms use bndstr use couple use iounit use tors implicit none integer i,j,k integer ia,ib,ic,id integer maxtors c c c perform dynamic allocation of some global arrays c maxtors = 18 * n if (allocated(itors)) deallocate (itors) allocate (itors(4,maxtors)) c c loop over all bonds, storing the atoms in each torsion c ntors = 0 do i = 1, nbond ib = ibnd(1,i) ic = ibnd(2,i) do j = 1, n12(ib) ia = i12(j,ib) if (ia .ne. ic) then do k = 1, n12(ic) id = i12(k,ic) if (id.ne.ib .and. id.ne.ia) then ntors = ntors + 1 if (ntors .gt. maxtors) then write (iout,10) 10 format (/,' TORSIONS -- Too many Torsional', & ' Angles; Increase MAXTORS') call fatal end if itors(1,ntors) = ia itors(2,ntors) = ib itors(3,ntors) = ic itors(4,ntors) = id end if end do end if 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 tortor -- torsion-torsions in current structure ## c ## ## c ################################################################ c c c ntortor total number of torsion-torsion interactions c itt atoms and parameter indices for torsion-torsion c c module tortor implicit none integer ntortor integer, allocatable :: itt(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1998 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module tree -- potential smoothing search tree levels ## c ## ## c ############################################################### c c c maxpss maximum number of potential smoothing levels c c nlevel number of levels of potential smoothing used c etree energy reference value at the top of the tree c ilevel smoothing deformation value at each tree level c c module tree implicit none integer maxpss parameter (maxpss=500) integer nlevel real*8 etree real*8 ilevel(0:maxpss) save end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################ c ## ## c ## function trimtext -- find last non-blank character ## c ## ## c ############################################################ c c c "trimtext" finds and returns the location of the last c non-blank character before the first null character in c an input text string; the function returns zero if no c such character is found c c function trimtext (string) implicit none integer i,size,last integer len,trimtext character*1 char character*1 null character*(*) string c c c move forward through the string, one character c at a time, looking for first null character c trimtext = 0 size = len(string) null = char(0) last = size do i = 1, size if (string(i:i) .eq. null) then last = i - 1 goto 10 end if end do 10 continue c c move backward through the string, one character c at a time, looking for first non-blank character c do i = last, 1, -1 if (string(i:i) .gt. ' ') then trimtext = i goto 20 end if end do 20 continue return end c c c ################################################################ c ## ## c ## subroutine trimhead -- remove spaces before first text ## c ## ## c ################################################################ c c c "trimhead" removes blank spaces before the first non-blank c character in a text string by shifting the string to the left c c subroutine trimhead (string) implicit none integer i,j,k character*240 string character*240 temp c c c loop over characters, removing blank beginning spaces c do i = 1, 240 temp(i:i) = ' ' end do j = 0 k = 0 do i = 1, 240 if (string(i:i) .ne. ' ') j = 1 if (j .eq. 1) then k = k + 1 temp(k:k) = string(i:i) end if end do do i = 1, 240 string(i:i) = temp(i:i) end do return end c c c ################################################################# c ## ## c ## subroutine justify -- convert string to right justified ## c ## ## c ################################################################# c c c "justify" converts a text string to right justified format c with leading blank spaces c c subroutine justify (string) implicit none integer i,k,len integer size,last character*1 char character*1 null character*1 letter character*(*) string c c c move backward through the string, one character c at a time, looking for first non-blank character c size = len(string) null = char(0) last = 0 do i = size, 1, -1 letter = string(i:i) if (letter.ne.' ' .and. letter.ne.null) then last = i goto 10 end if end do 10 continue c c move string to the right and pad with leading blanks c do i = last, 1, -1 k = i + size - last string(k:k) = string(i:i) end do do i = 1, size-last string(i:i) = ' ' end do return end c c c ############################################################### c ## ## c ## subroutine upcase -- convert string to all upper case ## c ## ## c ############################################################### c c c "upcase" converts a text string to all upper case letters c c subroutine upcase (string) implicit none integer i,size,len integer code,ichar character*1 char character*1 letter character*(*) string c c c convert lower case to upper case one letter at a time c size = len(string) do i = 1, size letter = string(i:i) code = ichar(letter) if (letter.ge.'a' .and. letter.le.'z') & string(i:i) = char(code-32) end do return end c c c ################################################################ c ## ## c ## subroutine lowcase -- convert string to all lower case ## c ## ## c ################################################################ c c c "lowcase" converts a text string to all lower case letters c c subroutine lowcase (string) implicit none integer i,size integer code,ichar character*1 char character*1 letter character*(*) string c c c convert upper case to lower case one letter at a time c size = len(string) do i = 1, size letter = string(i:i) code = ichar(letter) if (letter.ge.'A' .and. letter.le.'Z') & string(i:i) = char(code+32) end do return end c c c ############################################################### c ## COPYRIGHT (C) 2002-2009 by Patrice Koehl ## c ## COPYRIGHT (C) 2023 by Moses K. J. Chung & Jay W. Ponder ## c ## All Rights Reserved ## c ############################################################### c c ############################################################### c ## ## c ## subroutine unionball -- alpha shapes surface & volume ## c ## ## c ############################################################### c c c "unionball" computes the surface area and volume of a union of c spheres via the analytical inclusion-exclusion method of Herbert c Edelsbrunner based on alpha shapes, also finds derivatives of c surface area and volume with respect to Cartesian coordinates c c original UnionBall code developed and provided by Patrice Koehl, c Computer Science, University of California, Davis c c modified to facilitate calling of UnionBall from Tinker by c Moses K. J. Chung and Jay W. Ponder, Washington University, c October 2023 to May 2024 c c literature references: c c P. Mach and P. Koehl, "Geometric Measures of Large Biomolecules: c Surface, Volume, and Pockets", Journal of Computational Chemistry, c 32, 3023-3038 (2011) c c P. Koehl, A. Akopyan and H. Edelsbrunner, "Computing the Volume, c Surface Area, Mean, and Gaussian Curvatures of Molecules and Their c Derivatives", Journal of Chemical Information and Modeling, 63, c 973-985 (2023) c c variables and parameters: c c n total number of spheres in the current system c x current x-coordinate for each sphere in the system c y current y-coordinate for each sphere in the system c z current z-coordinate for each sphere in the system c rad radius value in Angstroms for each sphere c weight weight value for each sphere in the system c probe radius value in Angstroms of the probe sphere c doderiv logical flag to find derivatives over coordinates c dovol logical flag to compute the excluded volume c surf weighted surface area of union of spheres c vol weighted volume of the union of spheres c asurf weighted contribution of each sphere to the area c avol weighted contribution of each ball to the volume c dsurf derivatives of weighted surface area over coordinates c dvol derivatives of weighted volume over coordinates c usurf unweighted surface area of union of spheres c uvol unweighted volume of the union of spheres c c subroutine unionball (n,x,y,z,rad,weight,probe,doderiv,dovol, & surf,vol,asurf,avol,dsurf,dvol) use iounit implicit none integer i,n,nsphere integer nsize,nfudge integer nredundant integer, allocatable :: redlist(:) real*8 surf,usurf real*8 vol,uvol real*8 probe,alpha,eps real*8 x(*) real*8 y(*) real*8 z(*) real*8 rad(*) real*8 weight(*) real*8 asurf(*) real*8 avol(*) real*8 dsurf(3,*) real*8 dvol(3,*) real*8, allocatable :: radii(:) real*8, allocatable :: asurfx(:) real*8, allocatable :: avolx(:) real*8, allocatable :: coords(:,:) real*8, allocatable :: dsurfx(:,:) real*8, allocatable :: dvolx(:,:) logical doderiv,dovol logical dowiggle character*6 symmtyp c c c perform dynamic allocation of some local arrays c nfudge = 10 nsize = n + nfudge allocate (radii(nsize)) allocate (asurfx(nsize)) allocate (avolx(nsize)) allocate (coords(3,nsize)) allocate (dsurfx(3,nsize)) allocate (dvolx(3,nsize)) allocate (redlist(nsize)) c c increment the sphere radii by the radius of the probe c nsphere = n do i = 1, n coords(1,i) = x(i) coords(2,i) = y(i) coords(3,i) = z(i) radii(i) = 0.0d0 if (rad(i) .ne. 0.0d0) radii(i) = rad(i) + probe end do c c check coordinates for linearity, planarity and symmetry c symmtyp = 'NONE' call chksymm (symmtyp) dowiggle = .false. if (n.gt.2 .and. symmtyp.eq.'LINEAR') dowiggle = .true. if (n.gt.3 .and. symmtyp.eq.'PLANAR') dowiggle = .true. if (symmtyp .eq. 'CENTER') dowiggle = .true. c c random coordinate perturbation to avoid numerical issues c if (dowiggle) then write (iout,10) symmtyp 10 format (/,' UNIONBALL -- Warning, ',a6,' Symmetry;' & ' Wiggling Coordinates') eps = 0.001d0 call wiggle (n,coords,eps) else if (symmtyp .ne. 'NONE') then write (iout,20) symmtyp 20 format (/,' UNIONBALL -- Warning, ',a6,' Symmetry' & ' Detected for the System') end if c c transfer coordinates, complete to minimum of four spheres c if needed, set Delaunay and alpha complex arrays c call setunion (nsphere,coords,radii) c c compute the weighted Delaunay triangulation c call regular3 (nredundant,redlist) c c compute the alpha complex for fixed value of alpha c alpha = 0.0d0 call alfcx (alpha,nredundant,redlist) c c if fewer than four balls, set artificial spheres as redundant c call readjust_sphere (nsphere,nredundant,redlist) c c get surface area and volume, then copy to Tinker arrays c if (doderiv) then if (dovol) then call ball_dvol (weight,surf,vol,usurf,uvol,asurfx,avolx, & dsurfx,dvolx) do i = 1, n asurf(i) = asurfx(i) avol(i) = avolx(i) dsurf(1,i) = dsurfx(1,i) dsurf(2,i) = dsurfx(2,i) dsurf(3,i) = dsurfx(3,i) dvol(1,i) = dvolx(1,i) dvol(2,i) = dvolx(2,i) dvol(3,i) = dvolx(3,i) end do else call ball_dsurf (weight,surf,usurf,asurfx,dsurfx) do i = 1, n asurf(i) = asurfx(i) dsurf(1,i) = dsurfx(1,i) dsurf(2,i) = dsurfx(2,i) dsurf(3,i) = dsurfx(3,i) end do end if else if (dovol) then call ball_vol (weight,surf,vol,usurf,uvol,asurfx,avolx) do i = 1, n asurf(i) = asurfx(i) avol(i) = avolx(i) end do else call ball_surf (weight,surf,usurf,asurfx) do i = 1, n asurf(i) = asurfx(i) end do end if end if c c perform deallocation of some local arrays c deallocate (radii) deallocate (asurfx) deallocate (avolx) deallocate (coords) deallocate (dsurfx) deallocate (dvolx) deallocate (redlist) return end c c c ################################################################## c ## ## c ## subroutine setunion -- get UnionBall coordinates & radii ## c ## ## c ################################################################## c c c "setunion" gets the coordinates and radii of the balls, and c stores these into data structures used in UnionBall c c variables and parameters: c c nsphere number of points (spheres) to be triangulated c coords Cartesian coordinates of all spheres c radii radius of each sphere, used to set weights for c regular triangulation related to radius squared c c subroutine setunion (nsphere,coords,radii) use shapes implicit none integer ndigit integer nsize,nfudge integer nsphere integer new_points integer i,j,k,ip,jp integer, allocatable :: ranlist(:) real*8 crdmax,epsd real*8 x,xval,sum real*8 y,z,w,xi,yi,zi,wi,r real*8 brad(3),bcoord(9) real*8 coords(*) real*8 radii(*) real*8, allocatable :: ranval(:) save c c c define array sizes used for memory allocation c nfudge = 10 nsize = nsphere + nfudge maxtetra = 10 * nsize c c set number of digits for truncation of real numbers c ndigit = 8 c c perform dynamic allocation of some global arrays c if (allocated(vinfo)) then if (size(vinfo) .lt. nsize) then deallocate (vinfo) deallocate (crdball) deallocate (radball) deallocate (wghtball) end if end if if (allocated(tinfo)) then if (size(tinfo) .lt. ntetra) then deallocate (tetra) deallocate (tneighbor) deallocate (tinfo) deallocate (tnindex) end if end if if (.not. allocated(vinfo)) allocate (vinfo(nsize)) if (.not. allocated(crdball)) allocate (crdball(3*nsize)) if (.not. allocated(radball)) allocate (radball(nsize)) if (.not. allocated(wghtball)) allocate (wghtball(nsize)) if (.not. allocated(tetra)) allocate (tetra(4,maxtetra)) if (.not. allocated(tneighbor)) allocate (tneighbor(4,maxtetra)) if (.not. allocated(tinfo)) allocate (tinfo(maxtetra)) if (.not. allocated(tnindex)) allocate (tnindex(maxtetra)) c c perform dynamic allocation of some local arrays c allocate (ranlist(nsize)) allocate (ranval(3*nsize)) c c truncate input coordinates to desired precision c npoint = nsphere crdmax = 0.0d0 do i = 1, npoint vinfo(i) = 0 vinfo(i) = ibset(vinfo(i),0) x = radii(i) call truncate_real (x,xval,ndigit) radball(i) = xval do j = 1, 3 k = 3*(i-1) + j x = coords(k) call truncate_real (x,xval,ndigit) crdball(k) = xval if (abs(crdball(k)) .gt. crdmax) crdmax = abs(crdball(k)) end do end do crdmax = max(100.0d0,crdmax) c c machine precision is smallest value different from zero; c note "epsd" may become zero if compiled with optimization c sum = 10.0d0 epsd = 1.0d0 do while (sum .gt. 1.0d0) epsd = epsd / 2.0d0 sum = 1.0d0 + epsd end do epsd = 2.0d0 * epsd c c use typical value from compilation without optimization c epsd = 0.222045d-15 c c set tolerance values based upon the machine precision c epsln2 = epsd * crdmax * crdmax epsln3 = epsln2 * crdmax epsln4 = epsln3 * crdmax epsln5 = epsln4 * crdmax epsln2 = 1.0d-1 epsln3 = 1.0d-1 epsln4 = 1.0d-1 epsln5 = 1.0d-1 c c precompute the weight value for each of the points c do i = 1, npoint x = crdball(3*(i-1)+1) y = crdball(3*(i-1)+2) z = crdball(3*(i-1)+3) r = radball(i) call build_weight (x,y,z,r,w) wghtball(i) = w end do c c check for trivial redundancy with same point twice c do i = 1, 3*npoint ranval(i) = crdball(i) end do call hpsort_three (ranval,ranlist,npoint) jp = ranlist(1) x = crdball(3*jp-2) y = crdball(3*jp-1) z = crdball(3*jp) w = radball(jp) do i = 2, npoint ip = ranlist(i) xi = crdball(3*ip-2) yi = crdball(3*ip-1) zi = crdball(3*ip) wi = radball(ip) if ((xi-x)**2+(yi-y)**2+(zi-z)**2 .le. 100.0d0*epsd) then if (wi .le. w) then vinfo(ip) = ibclr(vinfo(ip),0) else vinfo(jp) = ibclr(vinfo(jp),0) jp = ip w = wi end if else x = xi y = yi z = zi w = wi jp = ip end if end do if (npoint .lt. 4) then new_points = 4 - npoint; call addbogus (bcoord, brad) do i = 1, new_points npoint = npoint + 1 x = bcoord(3*(i-1)+1); y = bcoord(3*(i-1)+2); z = bcoord(3*(i-1)+3); r = brad(i); call build_weight (x,y,z,r,w) crdball(3*(npoint-1)+1) = x crdball(3*(npoint-1)+2) = y crdball(3*(npoint-1)+3) = z radball(npoint) = r wghtball(npoint) = w vinfo(npoint) = 0 vinfo(npoint) = ibset(vinfo(npoint),0) end do end if c c initialization for the four added infinite points c do i = 3*npoint, 1, -1 crdball(i+12) = crdball(i) end do do i = npoint, 1, -1 radball(i+4) = radball(i) wghtball(i+4) = wghtball(i) vinfo(i+4) = vinfo(i) end do nvertex = npoint + 4 do i = 1, 12 crdball(i) = 0.0d0 end do do i = 1, 4 radball(i) = 0.0d0 wghtball(i) = 0.0d0 vinfo(i) = 0 vinfo(i) = ibset(vinfo(i),0) end do c c initialize tetrahedra for Delaunay calculation c ntetra = 1 tetra(1,ntetra) = 1 tetra(2,ntetra) = 2 tetra(3,ntetra) = 3 tetra(4,ntetra) = 4 tneighbor(1,ntetra) = 0 tneighbor(2,ntetra) = 0 tneighbor(3,ntetra) = 0 tneighbor(4,ntetra) = 0 tinfo(ntetra) = 0 tinfo(ntetra) = ibset(tinfo(ntetra),1) c c orientation is right most bit, bit=0 means -1, bit=1 means 1; c the orientation of the first tetrahedron is -1 c tinfo(ntetra) = ibclr(tinfo(ntetra),0) c c perform deallocation of some local arrays c deallocate (ranlist) deallocate (ranval) return end c c c ################################################################# c ## ## c ## subroutine regular3 -- triangulation of a set of points ## c ## ## c ################################################################# c c c "regular3" computes the regular triangulation of a set of N c weighted points in 3D using the incremental flipping algorithm c of Herbert Edelsbrunner c c literature reference: c c H. Edelsbrunner and N. R. Shah, "Incremental Topological c Flipping Works for Regular Triangulations", Algorithmica, c 15, 223-241 (1996) c c algorithm summary: c c (1) initialize the procedure with a big tetrahedron, all four c vertices of this tetrahedron are set at "infinite", (2) all N c points are added one by one, (3) for each point localize the c tetrahedron in the current regular triangulation that contains c this point, (4) test if the point is redundant, and is so then c remove it, (5) if the point is not redundant, insert it in the c tetrahedron via a "1-4" flip, (6) collect all "link facets", c (i.e., all triangles in tetrahedron containing the new point, c that face this new point) that are not regular, (7) for each c non-regular link facet, check if it is "flippable", (8) if yes, c perform a "2-3", "3-2" or "1-4" flip, add new link facets in c the list if needed, (9) when link facet list is empty, move to c next point, (10) remove "infinite" tetrahedra, which are those c with one vertex at "infinite", and (11) collect the remaining c tetrahedra, and define convex hull c c subroutine regular3 (nredundant,redlist) use shapes implicit none integer i,ival integer iredundant integer iflag,iseed integer tetra_loc integer tetra_last integer nredundant integer maxfree,maxkill integer maxlink,maxnew integer npeel_try integer redlist(*) save c c c perform dynamic allocation of some global arrays c maxnew = 20000 maxfree = 20000 maxkill = 20000 maxlink = 20000 allocate (newlist(maxnew)) allocate (freespace(maxfree)) allocate (killspace(maxkill)) allocate (linkfacet(2,maxlink)) allocate (linkindex(2,maxlink)) c c initialize the size of "free" space to zero c nfree = 0 nnew = 0 c c build regular triangulation, now loop over all points c tetra_last = -1 iseed = -1 do i = 1, npoint ival = i + 4 nnew = 0 if (btest(vinfo(ival),0)) then tetra_loc = tetra_last call locate_jw (iseed,ival,tetra_loc,iredundant) if (iredundant .eq. 1) then vinfo(ival) = ibclr(vinfo(ival),0) goto 10 end if call flipjw_1_4 (ival,tetra_loc,tetra_last) call flipjw (tetra_last) if (ntetra .gt. (9*maxtetra)/10) call resize_tet 10 continue end if end do c c reorder tetrahedra, so vertices are in increasing order c iflag = 1 call reorder_tetra (iflag,nnew,newlist) c c regular triangulation complete; remove the simplices c including infinite points, and define the convex hull c call remove_inf c c peel off flat tetrahedra at the boundary of the DT c npeel_try = 1 do while (npeel_try .gt. 0) call peel (npeel_try) end do c c define the list of redundant points c nredundant = 0 do i = 1, npoint if (.not. btest(vinfo(i+4),0)) then nredundant = nredundant + 1 redlist(nredundant) = i end if end do c c perform deallocation of some global arrays c deallocate (newlist) deallocate (freespace) deallocate (killspace) deallocate (linkfacet) deallocate (linkindex) return end c c c ############################################################### c ## ## c ## subroutine alfcx -- construction of the alpha complex ## c ## ## c ############################################################### c c c "alfcx" builds the alpha complex based on the weighted c Delaunay triangulation used by UnionBall c c subroutine alfcx (alpha,nred,redlist) use shapes implicit none integer i,j,k,l,m integer ia,ib,i1,i2 integer ntrig,icheck integer ntet_del,ntet_alp integer idx,iflag,nred integer irad,iattach,ival integer itrig,jtrig,iedge integer trig1,trig2,trig_in integer trig_out,triga,trigb integer jtetra,itetra,ktetra integer npass,ipair,i_out integer other3(3,4) integer face_info(2,6) integer face_pos(2,6) integer pair(2,6) integer redlist(*) integer, allocatable :: chklist(:) integer, allocatable :: tmask(:) real*8 ra,rb,rc,rd,re real*8 alpha real*8 a(4),b(4),c(4) real*8 d(4),e(4),cg(3) logical testa,testb,test_edge data other3 / 2, 3, 4, 1, 3, 4, 1, 2, 4, 1, 2, 3 / data face_info / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 / data face_pos / 2, 1, 3, 1, 4, 1, 3, 2, 4, 2, 4, 3 / data pair / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 / save c c c perform dynamic allocation of some local arrays c allocate (chklist(40000)) allocate (tmask(ntetra)) c c perform dynamic allocation of some global arrays c if (allocated(tedge)) then if (size(tedge) .lt. ntetra) deallocate (tedge) end if if (.not. allocated(tedge)) allocate (tedge(ntetra)) c c initialization and setup of masking variables c ival = 0 do i = 1, ntetra tmask(i) = 0 call mvbits (ival,0,5,tinfo(i),3) end do c c loop over all tetrahedra, any "dead" tetrahedra are ignored c ntet_del = 0 ntet_alp = 0 do idx = 1, ntetra if (btest(tinfo(idx),1)) then ntet_del = ntet_del + 1 i = tetra(1,idx) j = tetra(2,idx) k = tetra(3,idx) l = tetra(4,idx) call get_coord4 (i,j,k,l,a,b,c,d,ra,rb,rc,rd,cg) call alf_tetra (a,b,c,d,ra,rb,rc,rd,iflag,alpha) if (iflag .eq. 1) then tinfo(idx) = ibset(tinfo(idx),7) ntet_alp = ntet_alp + 1 end if end if end do c c loop over all triangles; each triangle is defined implicitly c as the interface between two tetrahedra i and j with i < j c ntrig = 0 do idx = 1, ntetra if (btest(tinfo(idx),1)) then do itrig = 1, 4 jtetra = tneighbor(itrig,idx) ival = ibits(tnindex(idx),2*(itrig-1),2) jtrig = ival + 1 if (jtetra.eq.0 .or. jtetra.gt.idx) then c c checking the triangle defined by itetra and jtetra, c if one of them belongs to the alpha complex, then c the triangle belongs to the alpha complex c if (btest(tinfo(idx),7)) then tinfo(idx) = ibset(tinfo(idx),2+itrig) ntrig = ntrig + 1 if (jtetra .ne. 0) then tinfo(jtetra) = ibset(tinfo(jtetra),2+jtrig) end if goto 10 end if if (jtetra .ne. 0) then if (btest(tinfo(jtetra),7)) then tinfo(idx) = ibset(tinfo(idx),2+itrig) tinfo(jtetra) = ibset(tinfo(jtetra),2+jtrig) ntrig = ntrig + 1 goto 10 end if end if c c the two attached tetrahedra do not belong to the alpha complex, c so need to check the triangle itself; define the three vertices c of the triangle, as well as the two remaining vertices of the c two tetrahedra attached to triangle c i = tetra(other3(1,itrig),idx) j = tetra(other3(2,itrig),idx) k = tetra(other3(3,itrig),idx) l = tetra(itrig,idx) if (jtetra .ne. 0) then m = tetra(jtrig,jtetra) call get_coord5 (i,j,k,l,m,a,b,c,d,e, & ra,rb,rc,rd,re,cg) else m = 0 call get_coord4 (i,j,k,l,a,b,c,d,ra,rb,rc,rd,cg) end if call alf_trig (a,b,c,d,e,ra,rb,rc,rd,re, & m,irad,iattach,alpha) if (iattach.eq.0 .and. irad.eq.1) then l = 1 tinfo(idx) = ibset(tinfo(idx),2+itrig) ntrig = ntrig + 1 if (jtetra .ne. 0) then tinfo(jtetra) = ibset(tinfo(jtetra),2+jtrig) end if end if end if 10 continue end do end if end do c c loop over all edges; each edge is defined implicitly c by the tetrahedra to which it belongs c do idx = 1, ntetra tmask(idx) = 0 tedge(idx) = 0 end do maxedge = 0 do itetra = 1, ntetra if (btest(tinfo(itetra),1)) then do iedge = 1, 6 if (btest(tmask(itetra),iedge-1)) goto 50 test_edge = .false. c c for each edge, check triangles attached to the edge c if at least one of these triangles is in alpha complex, c then the edge is in the alpha complex; c put the two vertices directly in the alpha complex; c otherwise, build list of triangles to check c c itetra is one tetrahedron (a,b,c,d) containing the edge c c iedge is the edge number in the tetrahedron itetra, with: c iedge=1 (c,d), iedge=2 (b,d), iedge=3 (b,c), c iedge=4 (a,d), iedge=5 (a,c), iedge=6 (a,b) c c define indices of the edge c i = tetra(pair(1,iedge),itetra) j = tetra(pair(2,iedge),itetra) c c trig1 and trig2 are the two faces of itetra sharing iedge, i1 c and i2 are positions of the third vertices of trig1 and trig2 c trig1 = face_info(1,iedge) i1 = face_pos(1,iedge) trig2 = face_info(2,iedge) i2 = face_pos(2,iedge) ia = tetra(i1,itetra) ib = tetra(i2,itetra) icheck = 0 if (btest(tinfo(itetra),2+trig1)) then test_edge = .true. else icheck = icheck + 1 chklist(icheck) = ia end if if (btest(tinfo(itetra),2+trig2)) then test_edge = .true. else icheck = icheck + 1 chklist(icheck) = ib end if c c now we look at the star of the edge c ktetra = itetra npass = 1 trig_out = trig1 jtetra = tneighbor(trig_out,ktetra) 20 continue c c leave this side of the star if we hit the convex hull c if (jtetra .eq. 0) goto 30 c c leave the loop completely if we have described the full cycle c if (jtetra .eq. itetra) goto 40 c c identify the position of iedge in tetrahedron jtetra c if (i .eq. tetra(1,jtetra)) then if (j .eq. tetra(2,jtetra)) then ipair = 6 else if (j .eq. tetra(3,jtetra)) then ipair = 5 else ipair = 4 end if else if (i .eq. tetra(2,jtetra)) then if (j .eq. tetra(3,jtetra)) then ipair = 3 else ipair = 2 end if else ipair = 1 end if tmask(jtetra) = ibset(tmask(jtetra),ipair-1) c c determine the face we "went in" c ival = ibits(tnindex(ktetra),2*(trig_out-1),2) trig_in = ival + 1 c c we know the two faces of jtetra that share iedge c triga = face_info(1,ipair) i1 = face_pos(1,ipair) trigb = face_info(2,ipair) i2 = face_pos(2,ipair) trig_out = triga i_out = i1 if (trig_in .eq. triga) then i_out = i2 trig_out = trigb end if c c check if trig_out is already in the alpha complex; if it c is then iedge is in, otherwise, will need an attach test c if (btest(tinfo(jtetra),2+trig_out)) then test_edge = .true. end if ktetra = jtetra jtetra = tneighbor(trig_out,ktetra) if (jtetra .eq. itetra) goto 40 icheck = icheck + 1 chklist(icheck) = tetra(i_out,ktetra) goto 20 30 continue if (npass .eq. 2) goto 40 npass = npass + 1 ktetra = itetra trig_out = trig2 jtetra = tneighbor(trig_out,ktetra) goto 20 40 continue if (test_edge) then tedge(itetra) = ibset(tedge(itetra),iedge-1) maxedge = maxedge + 1 vinfo(i) = ibset(vinfo(i),7) vinfo(j) = ibset(vinfo(j),7) goto 50 end if c c if here, it means that none of the triangles in the star c of the edge belongs to the alpha complex, so a singular edge c c check if the edge is attached, and if alpha is smaller than c the radius of the sphere orthogonal to the two balls c corresponding to the edge c call get_coord2 (i,j,a,b,ra,rb,cg) call alf_edge (a,b,ra,rb,cg,icheck,chklist, & irad,iattach,alpha) if (iattach.eq.0 .and. irad.eq.1) then tedge(itetra) = ibset(tedge(itetra),iedge-1) maxedge = maxedge + 1 vinfo(i) = ibset(vinfo(i),7) vinfo(j) = ibset(vinfo(j),7) goto 50 end if c c edge is not in alpha complex: now check if the two vertices c could be attached to each other: c call vertex_attach (a,b,ra,rb,testa,testb) if (testa) vinfo(i) = ibset(vinfo(i),6) if (testb) vinfo(j) = ibset(vinfo(j),6) 50 continue end do end if end do c c safeguard minimum edge count to handle small system dimensions c maxedge = max(maxedge,nvertex+10) c c loop over each of the vertices; nothing to do if vertex c was already set in alpha complex; vertex is in alpha complex, c unless it is attached c nred = 0 do i = 1, nvertex if (btest(vinfo(i),0)) then if (.not. btest(vinfo(i),7)) then if (.not. btest(vinfo(i),6)) then vinfo(i) = ibset(vinfo(i),7) else nred = nred + 1 redlist(nred) = i end if end if end if end do c c perform deallocation of some local arrays c deallocate (chklist) deallocate (tmask) return end c c c ################################################################# c ## ## c ## subroutine readjust_sphere -- remove artificial spheres ## c ## ## c ################################################################# c c c "readjust_sphere" removes artificial spheres for UnionBall c systems containing fewer than four spheres c c subroutine readjust_sphere (nsphere,nredundant,redlist) use shapes implicit none integer i,j integer nsphere integer nredundant integer redlist(*) save c c c if fewer than four balls, set artificial spheres as redundant c if (nsphere .lt. 4) then do i = nsphere+5, 8 vinfo(i) = 1 end do npoint = nsphere nvertex = npoint + 4 j = 0 do i = 1, nredundant if (redlist(i) .le. nsphere) then j = j + 1 redlist(j) = redlist(i) end if end do end if return end c c c ############################################################### c ## ## c ## subroutine ball_surf -- find area of union of spheres ## c ## ## c ############################################################### c c c "ball_surf" computes the weighted accessible surface area of c a union of spheres c c variables and parameters: c c coef sphere weights for the weighted surface c wsurf weighted surface area c surf unweighted surface area c ballwsurf weighted contribution of each ball c c subroutine ball_surf (coef,wsurf,surf,ballwsurf) use math use shapes implicit none integer i,j integer ia,ib,ic,id integer i1,nedge integer idx,ilast integer itrig,iedge integer ival,it1,it2 integer jtetra integer face_info(2,6) integer face_pos(2,6) integer pair(2,6) integer, allocatable :: sparse_row (:) integer, allocatable :: edges (:,:) real*8 ra,rb,rc,rd real*8 ra2,rb2,rc2,rd2 real*8 rab,rac,rad real*8 rbc,rbd,rcd real*8 rab2,rac2,rad2 real*8 rbc2,rbd2,rcd2 real*8 coefval real*8 surfa,surfb,surfc,surfd real*8 a(3),b(3),c(3),d(3) real*8 angle(6),cosine(6),sine(6) real*8 wsurf,surf real*8 coef(*),ballwsurf(*) real*8, allocatable :: coef_edge(:) real*8, allocatable :: coef_vertex(:) data face_info / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 / data face_pos / 2, 1, 3, 1, 4, 1, 3, 2, 4, 2, 4, 3 / data pair / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 / save c c c perform dynamic allocation of some local arrays c allocate (sparse_row(nvertex+10)) allocate (edges(2,maxedge)) allocate (coef_edge(maxedge)) allocate (coef_vertex(nvertex)) c c initialize result values c wsurf = 0.0d0 surf = 0.0d0 do i = 1, nvertex ballwsurf(i) = 0.0d0 end do c c find list of all edges in the alpha complex c nedge = 0 call find_edges (nedge,edges) c c define sparse structure for edges c ilast = 0 do i = 1, nedge ia = edges(1,i) ib = edges(2,i) if (ia .ne. ilast) then do j = ilast+1, ia sparse_row(j) = i end do ilast = ia end if coef_edge(i) = 1.0d0 end do do i = ia+1, nvertex sparse_row(i) = nedge + 1 end do c c build list of fully buried vertices; these vertices are part c of the alpha complex, and all edges that start or end at these c vertices are buried c do i = 1, nvertex coef_vertex(i) = 1.0d0 end do c c contribution of four spheres; use the weighted inclusion-exclusion c formula; each tetrahedron in the Alpha Complex only contributes c to the weight of each its edges and each of its vertices c do idx = 1, ntetra if (btest(tinfo(idx),7)) then ia = tetra(1,idx) ib = tetra(2,idx) ic = tetra(3,idx) id = tetra(4,idx) do i = 1, 3 a(i) = crdball(3*(ia-1)+i) b(i) = crdball(3*(ib-1)+i) c(i) = crdball(3*(ic-1)+i) d(i) = crdball(3*(id-1)+i) end do ra = radball(ia) rb = radball(ib) rc = radball(ic) rd = radball(id) ra2 = ra * ra rb2 = rb * rb rc2 = rc * rc rd2 = rd * rd call distance2 (crdball,ia,ib,rab2) call distance2 (crdball,ia,ic,rac2) call distance2 (crdball,ia,id,rad2) call distance2 (crdball,ib,ic,rbc2) call distance2 (crdball,ib,id,rbd2) call distance2 (crdball,ic,id,rcd2) rab = sqrt(rab2) rac = sqrt(rac2) rad = sqrt(rad2) rbc = sqrt(rbc2) rbd = sqrt(rbd2) rcd = sqrt(rcd2) call tetra_dihed (rab2,rac2,rad2,rbc2,rbd2, & rcd2,angle,cosine,sine) c c weights on each vertex; fraction of solid angle c coef_vertex(ia) = coef_vertex(ia) + 0.25d0 & - (angle(1)+angle(2)+angle(3))/2.0d0 coef_vertex(ib) = coef_vertex(ib) + 0.25d0 & - (angle(1)+angle(4)+angle(5))/2.0d0 coef_vertex(ic) = coef_vertex(ic) + 0.25d0 & - (angle(2)+angle(4)+angle(6))/2.0d0 coef_vertex(id) = coef_vertex(id) + 0.25d0 & - (angle(3)+angle(5)+angle(6))/2.0d0 c c weights on each edge; fraction of dihedral angle c c iedge is the edge number in the tetrahedron idx with: c iedge = 1 (c,d), iedge = 2 (b,d), iedge = 3 (b,c), c iedge = 4 (a,d), iedge = 5 (a,c), iedge = 6 (a,b) c c define indices of the edge c do iedge = 1, 6 i = tetra(pair(1,iedge),idx) j = tetra(pair(2,iedge),idx) c c find which edge this corresponds to c do i1 = sparse_row(i), sparse_row(i+1)-1 if (edges(2,i1) .eq. j) goto 10 end do goto 20 10 continue if (coef_edge(i1) .ne. 0.0d0) then coef_edge(i1) = coef_edge(i1) - angle(7-iedge) end if 20 continue end do c c all the edge lengths have been precomputed, check triangles c c check the four faces of the tetrahedron; any exposed face c (on the convex hull, or facing a tetrahedron from the Delaunay c that is not part of the alpha complex), contributes c do itrig = 1, 4 jtetra = tneighbor(itrig,idx) if (jtetra.eq.0 .or. jtetra.gt.idx) then if (btest(tinfo(idx),2+itrig)) then if (jtetra .ne. 0) then call mvbits (tinfo(jtetra),7,1,it2,0) else it2 = 0 end if ival = 1 - it2 if (ival .eq. 0) goto 30 coefval = 0.5d0 * dble(ival) if (itrig .eq. 1) then surfa = 0.0d0 call threesphere_surf (rb,rc,rd,rb2,rc2,rd2, & rbc,rbd,rcd,rbc2,rbd2, & rcd2,surfb,surfc,surfd) else if (itrig .eq. 2) then surfb = 0.0d0 call threesphere_surf (ra,rc,rd,ra2,rc2,rd2, & rac,rad,rcd,rac2,rad2, & rcd2,surfa,surfc,surfd) else if (itrig .eq. 3) then surfc = 0.0d0 call threesphere_surf (ra,rb,rd,ra2,rb2,rd2, & rab,rad,rbd,rab2,rad2, & rbd2,surfa,surfb,surfd) else if (itrig .eq. 4) then surfd = 0.0d0 call threesphere_surf (ra,rb,rc,ra2,rb2,rc2, & rab,rac,rbc,rab2,rac2, & rbc2,surfa,surfb,surfc) end if ballwsurf(ia) = ballwsurf(ia) + coefval*surfa ballwsurf(ib) = ballwsurf(ib) + coefval*surfb ballwsurf(ic) = ballwsurf(ic) + coefval*surfc ballwsurf(id) = ballwsurf(id) + coefval*surfd end if end if 30 continue end do end if end do c c contribution of three balls (triangles of the alpha complex); c already checked the triangles from tetrahedra that belongs c to the alpha complex; now we check any singular triangles c (face of a tetrahedron in the Delaunay complex, but not in c the alpha shape) c c loop over all tetrahedra, and check its four faces; any face c that is exposed (on the convex hull, or facing a tetrahedron c from the Delaunay that is not in the alpha complex), contributes c do idx = 1, ntetra if (btest(tinfo(idx),1)) then if (.not. btest(tinfo(idx),7)) then ia = tetra(1,idx) ib = tetra(2,idx) ic = tetra(3,idx) id = tetra(4,idx) do i = 1, 3 a(i) = crdball(3*(ia-1)+i) b(i) = crdball(3*(ib-1)+i) c(i) = crdball(3*(ic-1)+i) d(i) = crdball(3*(id-1)+i) end do ra = radball(ia) rb = radball(ib) rc = radball(ic) rd = radball(id) ra2 = ra * ra rb2 = rb * rb rc2 = rc * rc rd2 = rd * rd rab = 0.0d0 rac = 0.0d0 rad = 0.0d0 rbc = 0.0d0 rbd = 0.0d0 rcd = 0.0d0 c c check triangles c do itrig = 1, 4 jtetra = tneighbor(itrig,idx) if (jtetra.eq.0 .or. jtetra.gt.idx) then if (btest(tinfo(idx),2+itrig)) then call mvbits (tinfo(idx),7,1,it1,0) if (jtetra .ne. 0) then call mvbits (tinfo(jtetra),7,1,it2,0) else it2 = 0 end if ival = 2 - it1 - it2 if (ival .eq. 0) goto 40 coefval = 0.5d0 * dble(ival) surfa = 0.0d0 surfb = 0.0d0 surfc = 0.0d0 surfd = 0.0d0 if (itrig .eq. 1) then call triangle_surf (b,c,d,rbc,rbd,rcd, & rbc2,rbd2,rcd2,rb, & rc,rd,rb2,rc2,rd2, & surfb,surfc,surfd) else if (itrig .eq. 2) then call triangle_surf (a,c,d,rac,rad,rcd, & rac2,rad2,rcd2,ra, & rc,rd,ra2,rc2,rd2, & surfa,surfc,surfd) else if (itrig .eq. 3) then call triangle_surf (a,b,d,rab,rad,rbd, & rab2,rad2,rbd2,ra, & rb,rd,ra2,rb2,rd2, & surfa,surfb,surfd) else if (itrig .eq. 4) then call triangle_surf (a,b,c,rab,rac,rbc, & rab2,rac2,rbc2,ra, & rb,rc,ra2,rb2,rc2, & surfa,surfb,surfc) end if ballwsurf(ia) = ballwsurf(ia) + coefval*surfa ballwsurf(ib) = ballwsurf(ib) + coefval*surfb ballwsurf(ic) = ballwsurf(ic) + coefval*surfc ballwsurf(id) = ballwsurf(id) + coefval*surfd end if end if 40 continue end do end if end if end do c c now add the contribution of two sphere c do iedge = 1, nedge if (coef_edge(iedge) .ne. 0.0d0) then ia = edges(1,iedge) ib = edges(2,iedge) do i = 1, 3 a(i) = crdball(3*(ia-1)+i) b(i) = crdball(3*(ib-1)+i) end do ra = radball(ia) rb = radball(ib) ra2 = ra * ra rb2 = rb * rb call distance2 (crdball,ia,ib,rab2) rab = sqrt(rab2) call twosphere_surf (ra,ra2,rb,rb2,rab,rab2,surfa,surfb) ballwsurf(ia) = ballwsurf(ia) - coef_edge(iedge)*surfa ballwsurf(ib) = ballwsurf(ib) - coef_edge(iedge)*surfb end if end do c c next loop over all of the vertices c do i = 1, nvertex if (.not. btest(vinfo(i),0)) goto 50 c c if vertex is not in alpha-complex, then nothing to do c if (.not. btest(vinfo(i),7)) goto 50 c c vertex is in alpha complex; if its weight is 0 such c that it is buried, then nothing to do c if (coef_vertex(i) .eq. 0.0d0) goto 50 ra = radball(i) ballwsurf(i) = ballwsurf(i) + coef_vertex(i)*4.0d0*pi*ra*ra 50 continue end do c c compute total surface (weighted, and unweighted) c do i = 5, nvertex if (btest(vinfo(i),0)) then surf = surf + ballwsurf(i) ballwsurf(i-4) = ballwsurf(i) * coef(i-4) wsurf = wsurf + ballwsurf(i-4) end if end do c c perform deallocation of some local arrays c deallocate (sparse_row) deallocate (edges) deallocate (coef_edge) deallocate (coef_vertex) return end c c c ################################################################ c ## ## c ## subroutine ball_vol -- find volume of union of spheres ## c ## ## c ################################################################ c c c "ball_vol" computes the weighted surface area of a union of c spheres and the corresponding weighted excluded volume c c variables and parameters: c c coef weight of each sphere for the weighted surface c wsurf weighted surface area c wvol weighted volume c surf unweighted surface area c vol unweighted volume c ballwsurf weighted contribution of each ball to wsurf c ballwvol weighted contribution of each ball to wvol c c subroutine ball_vol (coef,wsurf,wvol,surf, & vol,ballwsurf,ballwvol) use math use shapes implicit none integer i,j,i1 integer ia,ib,ic,id integer nedge,ntrig integer idx,ilast integer itrig,iedge,nred integer ival,it1,it2 integer jtetra integer face_info(2,6) integer face_pos(2,6) integer pair(2,6) integer flag(6) integer, allocatable :: sparse_row (:) integer, allocatable :: edges (:,:) real*8 ra,rb,rc,rd real*8 ra2,rb2,rc2,rd2 real*8 rab,rac,rad real*8 rbc,rbd,rcd real*8 rab2,rac2,rad2 real*8 rbc2,rbd2,rcd2 real*8 coefval real*8 surfa,surfb,surfc,surfd real*8 vola,volb,volc,vold real*8 a(3),b(3),c(3),d(3) real*8 angle(6),cosine(6),sine(6) real*8 coef(*) real*8 wsurf,surf real*8 wvol,vol real*8 ballwsurf(*) real*8 ballwvol(*) real*8, allocatable :: coef_edge(:) real*8, allocatable :: coef_vertex(:) data face_info / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 / data face_pos / 2, 1, 3, 1, 4, 1, 3, 2, 4, 2, 4, 3 / data pair / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 / save c c c perform dynamic allocation of some local arrays c allocate (sparse_row(nvertex+10)) allocate (edges(2,maxedge)) allocate (coef_edge(maxedge)) allocate (coef_vertex(nvertex)) c c initialize results arrays c wsurf = 0.0d0 wvol = 0.0d0 surf = 0.0d0 vol = 0.0d0 do i = 1, nvertex ballwsurf(i) = 0.0d0 ballwvol(i) = 0.0d0 end do c c find list of all edges in the alpha complex c nedge = 0 call find_edges (nedge,edges) c c sort list of all edges in increasing order c ilast = 0 do i = 1, nedge ia = edges(1,i) ib = edges(2,i) if (ia .ne. ilast) then do j = ilast+1, ia sparse_row(j) = i end do ilast = ia end if coef_edge(i) = 1 end do do i = ia+1, nvertex sparse_row(i) = nedge + 1 end do c c set the weight of each vertex to one c do i = 1, nvertex coef_vertex(i) = 1.0d0 end do c c contribution of four spheres using the weighted c inclusion-exclusion formula; each tetrahedron in the c alpha complex only contributes to the weight of each c its edges and each of its vertices c ntrig = 0 do idx = 1, ntetra if (btest(tinfo(idx),7)) then ia = tetra(1,idx) ib = tetra(2,idx) ic = tetra(3,idx) id = tetra(4,idx) do i = 1, 3 a(i) = crdball(3*(ia-1)+i) b(i) = crdball(3*(ib-1)+i) c(i) = crdball(3*(ic-1)+i) d(i) = crdball(3*(id-1)+i) end do ra = radball(ia) rb = radball(ib) rc = radball(ic) rd = radball(id) ra2 = ra * ra rb2 = rb * rb rc2 = rc * rc rd2 = rd * rd call distance2 (crdball,ia,ib,rab2) call distance2 (crdball,ia,ic,rac2) call distance2 (crdball,ia,id,rad2) call distance2 (crdball,ib,ic,rbc2) call distance2 (crdball,ib,id,rbd2) call distance2 (crdball,ic,id,rcd2) rab = sqrt(rab2) rac = sqrt(rac2) rad = sqrt(rad2) rbc = sqrt(rbc2) rbd = sqrt(rbd2) rcd = sqrt(rcd2) call tetra_dihed (rab2,rac2,rad2,rbc2,rbd2, & rcd2,angle,cosine,sine) c c if each ball has the same weight, add volume of the tetrahedron c call tetra_voronoi (ra2,rb2,rc2,rd2,rab,rac,rad,rbc,rbd, & rcd,rab2,rac2,rad2,rbc2,rbd2,rcd2, & cosine,sine,vola,volb,volc,vold) ballwvol(ia) = ballwvol(ia) + vola ballwvol(ib) = ballwvol(ib) + volb ballwvol(ic) = ballwvol(ic) + volc ballwvol(id) = ballwvol(id) + vold c c weights on each vertex: fraction of solid angle c coef_vertex(ia) = coef_vertex(ia) + 0.25d0 & - (angle(1)+angle(2)+angle(3))/2.0d0 coef_vertex(ib) = coef_vertex(ib) + 0.25d0 & - (angle(1)+angle(4)+angle(5))/2.0d0 coef_vertex(ic) = coef_vertex(ic) + 0.25d0 & - (angle(2)+angle(4)+angle(6))/2.0d0 coef_vertex(id) = coef_vertex(id) + 0.25d0 & - (angle(3)+angle(5)+angle(6))/2.0d0 c c weights on each edge: fraction of dihedral angle c c iedge is the edge number in the tetrahedron idx, with c iedge = 1 (c,d), iedge = 2 (b,d), iedge = 3 (b,c), c iedge = 4 (a,d), iedge = 5 (a,c), iedge = 6 (a,b) c c define indices of the edge c do iedge = 1, 6 i = tetra(pair(1,iedge),idx) j = tetra(pair(2,iedge),idx) c c find which edge this corresponds to c do i1 = sparse_row(i), sparse_row(i+1)-1 if (edges(2,i1) .eq. j) goto 10 end do goto 20 10 continue if (coef_edge(i1) .ne. 0) then coef_edge(i1) = coef_edge(i1) - angle(7-iedge) end if 20 continue end do c c since we have precomputed all the edge lengths, check triangles c c we check the four faces of the tetrahedron; any face that c is exposed (on the convex hull, or facing a tetrahedron from c the Delaunay that is not part of the alpha complex), contributes c do itrig = 1, 4 jtetra = tneighbor(itrig,idx) if (jtetra.eq.0 .or. jtetra.gt.idx) then if (btest(tinfo(idx),2+itrig)) then if (jtetra .ne. 0) then call mvbits (tinfo(jtetra),7,1,it2,0) else it2 = 0 end if ival = 1 - it2 if (ival .eq. 0) goto 30 coefval = 0.5d0 * dble(ival) ntrig = ntrig + 1 if (itrig .eq. 1) then surfa = 0.0d0 vola = 0.0d0 call threesphere_vol (rb,rc,rd,rb2,rc2,rd2, & rbc,rbd,rcd,rbc2,rbd2, & rcd2,surfb,surfc,surfd, & volb,volc,vold) else if (itrig.eq.2) then surfb = 0.0d0 volb = 0.0d0 call threesphere_vol (ra,rc,rd,ra2,rc2,rd2, & rac,rad,rcd,rac2,rad2, & rcd2,surfa,surfc,surfd, & vola,volc,vold) else if (itrig .eq. 3) then surfc = 0.0d0 volc = 0.0d0 call threesphere_vol (ra,rb,rd,ra2,rb2,rd2, & rab,rad,rbd,rab2,rad2, & rbd2,surfa,surfb,surfd, & vola,volb,vold) else if (itrig .eq. 4) then surfd = 0.0d0 vold = 0.0d0 call threesphere_vol (ra,rb,rc,ra2,rb2,rc2, & rab,rac,rbc,rab2,rac2, & rbc2,surfa,surfb,surfc, & vola,volb,volc) end if ballwsurf(ia) = ballwsurf(ia) + coefval*surfa ballwsurf(ib) = ballwsurf(ib) + coefval*surfb ballwsurf(ic) = ballwsurf(ic) + coefval*surfc ballwsurf(id) = ballwsurf(id) + coefval*surfd ballwvol(ia) = ballwvol(ia) + coefval*vola ballwvol(ib) = ballwvol(ib) + coefval*volb ballwvol(ic) = ballwvol(ic) + coefval*volc ballwvol(id) = ballwvol(id) + coefval*vold end if end if 30 continue end do end if end do c c contribution of 3-balls (i.e. triangles of the alpha complex); c already checked the triangles from tetrahedra that belongs to the c alpha complex; now we check any singular triangles (a face of a c tetrahedron in the Delaunay complex, but not in the alpha shape); c we loop over all tetrahedra, and check its four faces; any face c that is exposed (on the convex hull, or facing a tetrahedron from c the Delaunay that is not part of the alpha complex), contributes c do idx = 1, ntetra if (btest(tinfo(idx),1)) then if (.not. btest(tinfo(idx),7)) then ia = tetra(1,idx) ib = tetra(2,idx) ic = tetra(3,idx) id = tetra(4,idx) do i = 1, 6 flag(i) = 0 end do do i = 1, 3 a(i) = crdball(3*(ia-1)+i) b(i) = crdball(3*(ib-1)+i) c(i) = crdball(3*(ic-1)+i) d(i) = crdball(3*(id-1)+i) end do ra = radball(ia) rb = radball(ib) rc = radball(ic) rd = radball(id) ra2 = ra * ra rb2 = rb * rb rc2 = rc * rc rd2 = rd * rd rab = 0.0d0 rac = 0.0d0 rad = 0.0d0 rbc = 0.0d0 rbd = 0.0d0 rcd = 0.0d0 c c check triangles c do itrig = 1, 4 jtetra = tneighbor(itrig,idx) if (jtetra.eq.0 .or. jtetra.gt.idx) then if (btest(tinfo(idx),2+itrig)) then call mvbits (tinfo(idx),7,1,it1,0) if (jtetra .ne. 0) then call mvbits (tinfo(jtetra),7,1,it2,0) else it2 = 0 end if ival = 2 - it1 - it2 if (ival .eq. 0) goto 40 coefval = 0.5d0 * dble(ival) ntrig = ntrig + 1 surfa = 0.0d0 surfb = 0.0d0 surfc = 0.0d0 surfd = 0.0d0 vola = 0.0d0 volb = 0.0d0 volc = 0.0d0 vold = 0.0d0 if (itrig .eq. 1) then call triangle_vol (b,c,d,rbc,rbd,rcd,rbc2, & rbd2,rcd2,rb,rc,rd,rb2, & rc2,rd2,surfb,surfc, & surfd,volb,volc,vold) else if (itrig .eq. 2) then call triangle_vol (a,c,d,rac,rad,rcd,rac2, & rad2,rcd2,ra,rc,rd,ra2, & rc2,rd2,surfa,surfc, & surfd,vola,volc,vold) else if (itrig .eq. 3) then call triangle_vol (a,b,d,rab,rad,rbd,rab2, & rad2,rbd2,ra,rb,rd,ra2, & rb2,rd2,surfa,surfb, & surfd,vola,volb,vold) else if (itrig .eq. 4) then call triangle_vol (a,b,c,rab,rac,rbc,rab2, & rac2,rbc2,ra,rb,rc,ra2, & rb2,rc2,surfa,surfb, & surfc,vola,volb,volc) end if ballwsurf(ia) = ballwsurf(ia) + coefval*surfa ballwsurf(ib) = ballwsurf(ib) + coefval*surfb ballwsurf(ic) = ballwsurf(ic) + coefval*surfc ballwsurf(id) = ballwsurf(id) + coefval*surfd ballwvol(ia) = ballwvol(ia) + coefval*vola ballwvol(ib) = ballwvol(ib) + coefval*volb ballwvol(ic) = ballwvol(ic) + coefval*volc ballwvol(id) = ballwvol(id) + coefval*vold end if end if 40 continue end do end if end if end do c c now add contribution of two sphere c do iedge = 1, nedge if (coef_edge(iedge) .ne. 0.0d0) then ia = edges(1,iedge) ib = edges(2,iedge) do i = 1, 3 a(i) = crdball(3*(ia-1)+i) b(i) = crdball(3*(ib-1)+i) end do ra = radball(ia) rb = radball(ib) ra2 = ra * ra rb2 = rb * rb call distance2 (crdball,ia,ib,rab2) rab = sqrt(rab2) call twosphere_vol (ra,ra2,rb,rb2,rab,rab2, & surfa,surfb,vola,volb) ballwsurf(ia) = ballwsurf(ia) - coef_edge(iedge)*surfa ballwsurf(ib) = ballwsurf(ib) - coef_edge(iedge)*surfb ballwvol(ia) = ballwvol(ia) - coef_edge(iedge)*vola ballwvol(ib) = ballwvol(ib) - coef_edge(iedge)*volb end if end do c c next loop over all of the vertices c nred = 0 do i = 1, nvertex if (.not. btest(vinfo(i),0)) goto 50 c c if vertex is not in alpha complex, nothing to do c if (.not. btest(vinfo(i),7)) goto 50 c c vertex is in alpha complex if its weight is 0 (buried) c in that case there is nothing to do c if (coef_vertex(i) .eq. 0.0d0) goto 50 ra = radball(i) surfa = 4.0d0 * pi * ra * ra vola = ra * surfa / 3.0d0 ballwsurf(i) = ballwsurf(i) + coef_vertex(i)*surfa ballwvol(i) = ballwvol(i) + coef_vertex(i)*vola 50 continue end do c c compute total surface, both weighted and unweighted c do i = 1, nvertex if (btest(vinfo(i),0)) then surf = surf + ballwsurf(i) ballwsurf(i-4) = coef(i-4) * ballwsurf(i) wsurf = wsurf + ballwsurf(i-4) vol = vol + ballwvol(i) ballwvol(i-4) = coef(i-4) * ballwvol(i) wvol = wvol + ballwvol(i-4) end if end do c c perform deallocation of some local arrays c deallocate (sparse_row) deallocate (edges) deallocate (coef_edge) deallocate (coef_vertex) return end c c c ################################################################ c ## ## c ## subroutine ball_dsurf -- find area & derivs of spheres ## c ## ## c ################################################################ c c c "ball_dsurf" computes the weighted surface area of a union c of spheres as well as its derivatives with respect to the c coordinates of the spheres c c variables and parameters: c c coef weight of each sphere for weighted surface c option flag to compute or not compute derivatives c wsurf weighted surface area c surf unweighted surface area c ballwsurf weighted contribution of each ball c dsurf_dist derivatives of surface area over distances c dsurf_coord derivatives of surface area over coordinates c c subroutine ball_dsurf (coef,wsurf,surf,ballwsurf,dsurf_coord) use math use shapes implicit none integer i,j,i1 integer ia,ib,ic,id integer nedge integer idx,ilast integer itrig,iedge integer ival,it1,it2 integer jtetra,option integer pair(2,6) integer edge_list(6) integer, allocatable :: sparse_row(:) integer, allocatable :: edges(:,:) real*8 ra,rb,rc,rd real*8 ra2,rb2,rc2,rd2 real*8 rab,rac,rad real*8 rbc,rbd,rcd real*8 rab2,rac2,rad2 real*8 rbc2,rbd2,rcd2 real*8 val,val1,val2,val3 real*8 val4,vala,valb real*8 r1,r2,r1_2,r2_2,r12 real*8 coefval real*8 surfa,surfb real*8 surfc,surfd real*8 u(3),dist(6) real*8 deriv(6,6) real*8 dsurfa3(3),dsurfb3(3) real*8 dsurfc3(3),dsurfd3(3) real*8 dsurfa2,dsurfb2 real*8 angle(6),cosine(6),sine(6) real*8 wsurf,surf real*8 coef(*),ballwsurf(*) real*8 dsurf_coord(3,*) real*8, allocatable :: coef_edge(:) real*8, allocatable :: edge_dist(:) real*8, allocatable :: coef_vertex(:) real*8, allocatable :: dsurf_dist(:) data pair / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 / save c c c perform dynamic allocation of some local arrays c allocate (sparse_row(10*maxedge)) allocate (edges(2,maxedge)) allocate (coef_edge(maxedge)) allocate (coef_vertex(nvertex)) allocate (edge_dist(maxedge)) allocate (dsurf_dist(10*maxedge)) c c initialize some input and result values c option = 1 wsurf = 0.0d0 surf = 0.0d0 do i = 1, nvertex ballwsurf(i) = 0.0d0 end do c c find list of all edges in the alpha complex c nedge = 0 call find_all_edges (nedge,edges) c c define sparse structure for edges c ilast = 0 do i = 1, nedge ia = edges(1,i) ib = edges(2,i) if (ia .ne. ilast) then do j = ilast+1, ia sparse_row(j) = i end do ilast = ia end if coef_edge(i) = 1 ra = radball(ia) ra2 = ra * ra rb = radball(ib) rb2 = rb * rb call distance2 (crdball,ia,ib,rab2) rab = sqrt(rab2) edge_dist(i) = rab dsurf_dist(i) = 0.0d0 end do do i = ia+1, nvertex sparse_row(i) = nedge + 1 end do c c build list of fully buried vertices; these vertices are part c of the alpha complex, and all edges that start or end at these c vertices are buried c do i = 1, nvertex coef_vertex(i) = 1.0d0 end do c c contribution of four spheres; use weighted inclusion-exclusion c formula; each tetrahedron in the Alpha Complex only contributes c to the weight of each its edges and each of its vertices c do idx = 1, ntetra if (btest(tinfo(idx),7)) then ia = tetra(1,idx) ib = tetra(2,idx) ic = tetra(3,idx) id = tetra(4,idx) ra = radball(ia) rb = radball(ib) rc = radball(ic) rd = radball(id) ra2 = ra * ra rb2 = rb * rb rc2 = rc * rc rd2 = rd * rd c c weights on each edge; fraction of dihedral angle c c iedge is the edge number in the tetrahedron idx with: c iedge = 1 (c,d), iedge = 2 (b,d), iedge = 3 (b,c), c iedge = 4 (a,d), iedge = 5 (a,c), iedge = 6 (a,b) c c define indices of the edge c do iedge = 1, 6 i = tetra(pair(1,iedge),idx) j = tetra(pair(2,iedge),idx) c c find which edge this corresponds to c do i1 = sparse_row(i), sparse_row(i+1)-1 if (edges(2,i1) .eq. j) goto 10 end do goto 20 10 continue edge_list(7-iedge) = i1 20 continue end do rab = edge_dist(edge_list(1)) rac = edge_dist(edge_list(2)) rad = edge_dist(edge_list(3)) rbc = edge_dist(edge_list(4)) rbd = edge_dist(edge_list(5)) rcd = edge_dist(edge_list(6)) rab2 = rab * rab rac2 = rac * rac rad2 = rad * rad rbc2 = rbc * rbc rbd2 = rbd * rbd rcd2 = rcd * rcd dist(1) = rab dist(2) = rac dist(3) = rad dist(4) = rbc dist(5) = rbd dist(6) = rcd c c weights on each vertex, fraction of solid angle c if (option .eq. 0) then call tetra_dihed (rab2,rac2,rad2,rbc2,rbd2, & rcd2,angle,cosine,sine) else call tetra_dihed_der (rab2,rac2,rad2,rbc2,rbd2, & rcd2,angle,cosine,sine,deriv) end if c c weights on each vertex, fraction of solid angle c coef_vertex(ia) = coef_vertex(ia) + 0.25d0 & - (angle(1)+angle(2)+angle(3))/2.0d0 coef_vertex(ib) = coef_vertex(ib) + 0.25d0 & - (angle(1)+angle(4)+angle(5))/2.0d0 coef_vertex(ic) = coef_vertex(ic) + 0.25d0 & - (angle(2)+angle(4)+angle(6))/2.0d0 coef_vertex(id) = coef_vertex(id) + 0.25d0 & - (angle(3)+angle(5)+angle(6))/2.0d0 c c weights on each edge, fraction of dihedral angle c do iedge = 1, 6 i1 = edge_list(iedge) if (coef_edge(i1) .ne. 0.0d0) then coef_edge(i1) = coef_edge(i1) - angle(iedge) end if end do c c take into account the der ivatives of the edge weight c in weighted inclusion-exclusion formula c if (option .eq. 1) then do iedge = 1, 6 i1 = edge_list(iedge) ia = edges(1,i1) ib = edges(2,i1) r1 = radball(ia) r1_2 = r1 * r1 r2 = radball(ib) r2_2 = r2 * r2 r12 = edge_dist(i1) val1 = (r1_2-r2_2) / r12 vala = r1 * (2.0d0*r1-r12-val1) valb = r2 * (2.0d0*r2-r12+val1) val = coef(ia-4)*vala + coef(ib-4)*valb do i = 1, 6 j = edge_list(i) dsurf_dist(j) = dsurf_dist(j) & + dist(i)*deriv(iedge,i)*val end do end do c c take into account the derivatives of the vertex weight c in weightedinclusion-exclusion formula c val1 = ra2 * coef(ia-4) val2 = rb2 * coef(ib-4) val3 = rc2 * coef(ic-4) val4 = rd2 * coef(id-4) do i = 1, 6 j = edge_list(i) val = val1*(deriv(1,i)+deriv(2,i)+deriv(3,i)) & + val2*(deriv(1,i)+deriv(4,i)+deriv(5,i)) & + val3*(deriv(2,i)+deriv(4,i)+deriv(6,i)) & + val4*(deriv(3,i)+deriv(5,i)+deriv(6,i)) dsurf_dist(j) = dsurf_dist(j) - 2.0d0*dist(i)*val end do end if end if end do c c contribution of three balls (triangles of the alpha complex) c c we loop over all tetrahedra, and check its four faces; c any face that is exposed (on the convex hull, or facing c a tetrahedron from the Delaunay that is not part of the c alpha complex), contributes c do idx = 1, ntetra if (btest(tinfo(idx),1)) then ia = tetra(1,idx) ib = tetra(2,idx) ic = tetra(3,idx) id = tetra(4,idx) ra = radball(ia) rb = radball(ib) rc = radball(ic) rd = radball(id) ra2 = ra * ra rb2 = rb * rb rc2 = rc * rc rd2 = rd * rd c c define indices of the edge c do iedge = 1, 6 i = tetra(pair(1,iedge),idx) j = tetra(pair(2,iedge),idx) c c find which edge this corresponds to c do i1 = sparse_row(i), sparse_row(i+1)-1 if (edges(2,i1) .eq. j) goto 30 end do goto 40 30 continue edge_list(7-iedge) = i1 40 continue end do c c check triangles c do itrig = 1, 4 jtetra = tneighbor(itrig,idx) if (jtetra.eq.0 .or. jtetra.gt.idx) then if (btest(tinfo(idx),2+itrig)) then call mvbits (tinfo(idx),7,1,it1,0) if (jtetra .ne. 0) then call mvbits (tinfo(jtetra),7,1,it2,0) else it2 = 0 end if ival = 2 - it1 - it2 if (ival .eq. 0) goto 50 coefval = 0.5d0 * dble(ival) surfa = 0.0d0 surfb = 0.0d0 surfc = 0.0d0 surfd = 0.0d0 if (itrig .eq. 1) then rbc = edge_dist(edge_list(4)) rbd = edge_dist(edge_list(5)) rcd = edge_dist(edge_list(6)) rbc2 = rbc * rbc rbd2 = rbd * rbd rcd2 = rcd * rcd call threesphere_dsurf (rb,rc,rd,rb2,rc2,rd2, & rbc,rbd,rcd,rbc2,rbd2, & rcd2,surfb,surfc,surfd, & dsurfb3,dsurfc3, & dsurfd3,option) if (option .eq. 1) then call update_deriv (dsurf_dist,dsurfb3, & dsurfc3,dsurfd3, & coef(ib-4),coef(ic-4), & coef(id-4),coefval, & edge_list(4), & edge_list(5), & edge_list(6)) end if else if (itrig .eq. 2) then rac = edge_dist(edge_list(2)) rad = edge_dist(edge_list(3)) rcd = edge_dist(edge_list(6)) rac2 = rac * rac rad2 = rad * rad rcd2 = rcd * rcd call threesphere_dsurf (ra,rc,rd,ra2,rc2,rd2, & rac,rad,rcd,rac2,rad2, & rcd2,surfa,surfc,surfd, & dsurfa3,dsurfc3, & dsurfd3,option) if (option .eq. 1) then call update_deriv (dsurf_dist,dsurfa3, & dsurfc3,dsurfd3, & coef(ia-4),coef(ic-4), & coef(id-4),coefval, & edge_list(2), & edge_list(3), & edge_list(6)) end if else if (itrig .eq. 3) then rab = edge_dist(edge_list(1)) rad = edge_dist(edge_list(3)) rbd = edge_dist(edge_list(5)) rab2 = rab * rab rad2 = rad * rad rbd2 = rbd * rbd call threesphere_dsurf (ra,rb,rd,ra2,rb2,rd2, & rab,rad,rbd,rab2,rad2, & rbd2,surfa,surfb,surfd, & dsurfa3,dsurfb3, & dsurfd3,option) if (option .eq. 1) then call update_deriv (dsurf_dist,dsurfa3, & dsurfb3,dsurfd3, & coef(ia-4),coef(ib-4), & coef(id-4),coefval, & edge_list(1), & edge_list(3), & edge_list(5)) end if else if (itrig .eq. 4) then rab = edge_dist(edge_list(1)) rac = edge_dist(edge_list(2)) rbc = edge_dist(edge_list(4)) rab2 = rab * rab rac2 = rac * rac rbc2 = rbc * rbc call threesphere_dsurf (ra,rb,rc,ra2,rb2,rc2, & rab,rac,rbc,rab2,rac2, & rbc2,surfa,surfb,surfc, & dsurfa3,dsurfb3, & dsurfc3,option) if (option .eq. 1) then call update_deriv (dsurf_dist,dsurfa3, & dsurfb3,dsurfc3, & coef(ia-4),coef(ib-4), & coef(ic-4),coefval, & edge_list(1), & edge_list(2), & edge_list(4)) end if end if ballwsurf(ia) = ballwsurf(ia) + coefval*surfa ballwsurf(ib) = ballwsurf(ib) + coefval*surfb ballwsurf(ic) = ballwsurf(ic) + coefval*surfc ballwsurf(id) = ballwsurf(id) + coefval*surfd end if end if 50 continue end do end if end do c c now add contribution of two sphere c do iedge = 1, nedge if (coef_edge(iedge) .ne. 0.0d0) then ia = edges(1,iedge) ib = edges(2,iedge) ra = radball(ia) rb = radball(ib) ra2 = ra * ra rb2 = rb * rb rab = edge_dist(iedge) rab2 = rab * rab call twosphere_dsurf (ra,ra2,rb,rb2,rab,rab2,surfa, & surfb,dsurfa2,dsurfb2,option) ballwsurf(ia) = ballwsurf(ia) - coef_edge(iedge)*surfa ballwsurf(ib) = ballwsurf(ib) - coef_edge(iedge)*surfb if (option .eq. 1) then dsurf_dist(iedge) = dsurf_dist(iedge) & - coef_edge(iedge) & *(coef(ia-4)*dsurfa2+coef(ib-4)*dsurfb2) end if end if end do c c now loop over vertices c do i = 1, nvertex if (.not. btest(vinfo(i),0)) goto 60 c c if vertex is not in alpha complex, then nothing to do c if (.not. btest(vinfo(i),7)) goto 60 c c vertex is in alpha complex; if its weight is 0 (i.e., buried) c nothing to do c if (coef_vertex(i) .eq. 0) goto 60 ra = radball(i) ballwsurf(i) = ballwsurf(i) + 4.0d0*pi*ra*ra*coef_vertex(i) 60 continue end do c c compute total surface area, weighted and unweighted c do i = 1, nvertex if (btest(vinfo(i),0)) then surf = surf + ballwsurf(i) ballwsurf(i-4) = ballwsurf(i) * coef(i-4) wsurf = wsurf + ballwsurf(i-4) end if end do if (option .ne. 1) return c c convert distance derivatives to coordinate derivatives c do i = 1, nvertex do j = 1, 3 dsurf_coord(j,i) = 0.0d0 end do end do do iedge = 1, nedge if (dsurf_dist(iedge) .ne. 0.0d0) then ia = edges(1,iedge) ib = edges(2,iedge) do i = 1, 3 u(i) = crdball(3*(ia-1)+i) - crdball(3*(ib-1)+i) end do rab = edge_dist(iedge) val = dsurf_dist(iedge) / rab do j = 1, 3 dsurf_coord(j,ia-4) = dsurf_coord(j,ia-4) + u(j)*val dsurf_coord(j,ib-4) = dsurf_coord(j,ib-4) - u(j)*val end do end if end do c c perform deallocation of some local arrays c deallocate (sparse_row) deallocate (edges) deallocate (coef_edge) deallocate (coef_vertex) deallocate (edge_dist) deallocate (dsurf_dist) return end c c c ################################################################# c ## ## c ## subroutine ball_dvol -- find volume & derivs of spheres ## c ## ## c ################################################################# c c c "ball_dvol" computes the weighted surface area of a union of c spheres as well as the corresponding weighted excluded volume, c also finds their derivatives with respect sphere coordinates c c variables and parameters: c c coef weight of each sphere for the weighted surface c option computes derivatives or not c wsurf weighted accessible surface area c wvol weighted excluded volume c surf unweighted accessible surface area c vol unweighted excluded volume c ballwsurf weighted contribution of each sphere to the area c ballwvol weighted contribution of each ball to the volume c dsurf_dist derivatives of surface area over distances c dsurf_coord derivatives of surface area over coordinates c dvol_dist derivatives of volume over distances c dvol_coord derivatives of volume over coordinates c c subroutine ball_dvol (coef,wsurf,wvol,surf,vol,ballwsurf, & ballwvol,dsurf_coord,dvol_coord) use math use shapes implicit none integer i,j,i1 integer ia,ib,ic,id integer nedge integer idx,ilast integer itrig,iedge integer ival,it1,it2 integer jtetra,option integer pair(2,6) integer edge_list(6) integer, allocatable :: sparse_row(:) integer, allocatable :: edges(:,:) real*8 ra,rb,rc,rd real*8 ra2,rb2,rc2,rd2 real*8 rab,rac,rad real*8 rbc,rbd,rcd real*8 rab2,rac2,rad2 real*8 rbc2,rbd2,rcd2 real*8 val,val1,val2,val3,val4 real*8 vala,valb,valc,vald real*8 coefval real*8 surfa,surfb,surfc,surfd real*8 dsurfa2,dsurfb2 real*8 dvola2,dvolb2 real*8 vola,volb,volc,vold real*8 wsurf,surf,wvol,vol real*8 u(3),dist(6) real*8 dsurfa3(3),dsurfb3(3) real*8 dsurfc3(3),dsurfd3(3) real*8 dvola3(3),dvolb3(3) real*8 dvolc3(3),dvold3(3) real*8 dvola(6),dvolb(6) real*8 dvolc(6),dvold(6) real*8 angle(6),cosine(6),sine(6) real*8 deriv(6,6) real*8 coef(*) real*8 ballwsurf(*),ballwvol(*) real*8 dsurf_coord(3,*) real*8 dvol_coord(3,*) real*8, allocatable :: coef_edge(:) real*8, allocatable :: coef_vertex(:) real*8, allocatable :: edge_dist(:) real*8, allocatable :: edge_surf(:) real*8, allocatable :: edge_vol(:) real*8, allocatable :: dsurf_dist(:) real*8, allocatable :: dvol_dist(:) data pair / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 / save c c c perform dynamic allocation of some local arrays c allocate (sparse_row(10*maxedge)) allocate (edges(2,maxedge)) allocate (coef_edge(maxedge)) allocate (coef_vertex(nvertex)) allocate (edge_surf(maxedge)) allocate (edge_vol(maxedge)) allocate (edge_dist(maxedge)) allocate (dsurf_dist(10*maxedge)) allocate (dvol_dist(10*maxedge)) c c initialize some input and result values c option = 1 wsurf = 0.0d0 surf = 0.0d0 wvol = 0.0d0 vol = 0.0d0 do i = 1, nvertex ballwsurf(i) = 0.0d0 ballwvol(i) = 0.0d0 end do c c find list of all edges in the alpha complex c nedge = 0 call find_all_edges (nedge,edges) c c define sparse structure for edges c ilast = 0 do i = 1, nedge ia = edges(1,i) ib = edges(2,i) if (ia .ne. ilast) then do j = ilast+1, ia sparse_row(j) = i end do ilast = ia end if coef_edge(i) = 1 ra = radball(ia) ra2 = ra * ra rb = radball(ib) rb2 = rb * rb call distance2 (crdball,ia,ib,rab2) rab = sqrt(rab2) call twosphere_vol (ra,ra2,rb,rb2,rab,rab2, & surfa,surfb,vola,volb) edge_dist(i) = rab edge_surf(i) = (coef(ia-4)*surfa+coef(ib-4)*surfb) / twopi edge_vol(i) = (coef(ia-4)*vola+coef(ib-4)*volb) / twopi dsurf_dist(i) = 0.0d0 dvol_dist(i) = 0.0d0 end do do i = ia+1, nvertex sparse_row(i) = nedge + 1 end do c c build list of fully buried vertices; these vertices are part c of the alpha complex, and all edges that start or end at these c vertices are buried c do i = 1, nvertex coef_vertex(i) = 1.0d0 end do c c contribution of four spheres; use the weighted inclusion-exclusion c formula; each tetrahedron in the Alpha Complex only contributes c to the weight of each its edges and each of its vertices c do idx = 1, ntetra if (btest(tinfo(idx),7)) then ia = tetra(1,idx) ib = tetra(2,idx) ic = tetra(3,idx) id = tetra(4,idx) ra = radball(ia) rb = radball(ib) rc = radball(ic) rd = radball(id) ra2 = ra * ra rb2 = rb * rb rc2 = rc * rc rd2 = rd * rd c c weights on each edge; fraction of dihedral angle c c iedge is the edge number in the tetrahedron idx with: c iedge = 1 (c,d), iedge = 2 (b,d), iedge = 3 (b,c), c iedge = 4 (a,d), iedge = 5 (a,c), iedge = 6 (a,b) c c define indices of the edge c do iedge = 1, 6 i = tetra(pair(1,iedge),idx) j = tetra(pair(2,iedge),idx) c c find which edge this corresponds to c do i1 = sparse_row(i), sparse_row(i+1)-1 if (edges(2,i1) .eq. j) goto 10 end do goto 20 10 continue edge_list(7-iedge) = i1 20 continue end do rab = edge_dist(edge_list(1)) rac = edge_dist(edge_list(2)) rad = edge_dist(edge_list(3)) rbc = edge_dist(edge_list(4)) rbd = edge_dist(edge_list(5)) rcd = edge_dist(edge_list(6)) rab2 = rab * rab rac2 = rac * rac rad2 = rad * rad rbc2 = rbc * rbc rbd2 = rbd * rbd rcd2 = rcd * rcd dist(1) = rab dist(2) = rac dist(3) = rad dist(4) = rbc dist(5) = rbd dist(6) = rcd c c characterize the tetrahedron based on A, B, C and D c if (option .eq. 0) then call tetra_dihed (rab2,rac2,rad2,rbc2,rbd2, & rcd2,angle,cosine,sine) else call tetra_dihed_der (rab2,rac2,rad2,rbc2,rbd2, & rcd2,angle,cosine,sine,deriv) end if c c add fraction of tetrahedron that belongs to each ball c call tetra_voronoi_der (ra2,rb2,rc2,rd2,rab,rac,rad,rbc, & rbd,rcd,rab2,rac2,rad2,rbc2,rbd2, & rcd2,cosine,sine,deriv,vola,volb, & volc,vold,dvola,dvolb,dvolc, & dvold,option) ballwvol(ia) = ballwvol(ia) + vola ballwvol(ib) = ballwvol(ib) + volb ballwvol(ic) = ballwvol(ic) + volc ballwvol(id) = ballwvol(id) + vold if (option .eq. 1) then do iedge = 1, 6 i1 = edge_list(iedge) dvol_dist(i1) = dvol_dist(i1) & + coef(ia-4)*dvola(iedge) & + coef(ib-4)*dvolb(iedge) & + coef(ic-4)*dvolc(iedge) & + coef(id-4)*dvold(iedge) end do end if c c weights on each vertex, fraction of solid angle c coef_vertex(ia) = coef_vertex(ia) + 0.25d0 & - (angle(1)+angle(2)+angle(3))/2.0d0 coef_vertex(ib) = coef_vertex(ib) + 0.25d0 & - (angle(1)+angle(4)+angle(5))/2.0d0 coef_vertex(ic) = coef_vertex(ic) + 0.25d0 & - (angle(2)+angle(4)+angle(6))/2.0d0 coef_vertex(id) = coef_vertex(id) + 0.25d0 & - (angle(3)+angle(5)+angle(6))/2.0d0 c c weights on each edge, fraction of dihedral angle c do iedge = 1, 6 i1 = edge_list(iedge) if (coef_edge(i1) .ne. 0.0d0) then coef_edge(i1) = coef_edge(i1) - angle(iedge) end if end do c c take into account the derivatives of the edge weight c in weighted inclusion-exclusion formula c if (option .eq. 1) then do iedge = 1, 6 i1 = edge_list(iedge) val1 = 2.0d0 * edge_surf(i1) val2 = 2.0d0 * edge_vol(i1) do i = 1, 6 j = edge_list(i) dsurf_dist(j) = dsurf_dist(j) & + dist(i)*deriv(iedge,i)*val1 dvol_dist(j) = dvol_dist(j) & + dist(i)*deriv(iedge,i)*val2 end do end do c c take into account the derivatives of the vertex weight c in weighted inclusion-exclusion formula c val1 = ra2 * coef(ia-4) val2 = rb2 * coef(ib-4) val3 = rc2 * coef(ic-4) val4 = rd2 * coef(id-4) vala = val1 * ra/3.0d0 valb = val2 * rb/3.0d0 valc = val3 * rc/3.0d0 vald = val4 * rd/3.0d0 do i = 1, 6 j = edge_list(i) val = val1*(deriv(1,i)+deriv(2,i)+deriv(3,i)) & + val2*(deriv(1,i)+deriv(4,i)+deriv(5,i)) & + val3*(deriv(2,i)+deriv(4,i)+deriv(6,i)) & + val4*(deriv(3,i)+deriv(5,i)+deriv(6,i)) dsurf_dist(j) = dsurf_dist(j) - 2.0d0*dist(i)*val val = vala*(deriv(1,i)+deriv(2,i)+deriv(3,i)) & + valb*(deriv(1,i)+deriv(4,i)+deriv(5,i)) & + valc*(deriv(2,i)+deriv(4,i)+deriv(6,i)) & + vald*(deriv(3,i)+deriv(5,i)+deriv(6,i)) dvol_dist(j) = dvol_dist(j) - 2.0d0*dist(i)*val end do end if end if end do c c contribution of three balls (triangles of the alpha complex) c c we loop over all tetrahedra, and check its four faces; c any face that is exposed (on the convex hull, or facing c a tetrahedron from the Delaunay that is not part of the c alpha complex), contributes c do idx = 1, ntetra if (btest(tinfo(idx),1)) then ia = tetra(1,idx) ib = tetra(2,idx) ic = tetra(3,idx) id = tetra(4,idx) ra = radball(ia) rb = radball(ib) rc = radball(ic) rd = radball(id) ra2 = ra * ra rb2 = rb * rb rc2 = rc * rc rd2 = rd * rd do iedge = 1, 6 c c define indices of the edge c i = tetra(pair(1,iedge),idx) j = tetra(pair(2,iedge),idx) c c find which edge this corresponds to: c do i1 = sparse_row(i), sparse_row(i+1)-1 if (edges(2,i1) .eq. j) goto 30 end do goto 40 30 continue edge_list(7-iedge) = i1 40 continue end do c c check triangles c do itrig = 1, 4 jtetra = tneighbor(itrig,idx) if (jtetra.eq.0 .or. jtetra.gt.idx) then if (btest(tinfo(idx),2+itrig)) then call mvbits (tinfo(idx),7,1,it1,0) if (jtetra .ne. 0) then call mvbits (tinfo(jtetra),7,1,it2,0) else it2 = 0 end if ival = 2 - it1 - it2 if (ival .eq. 0) goto 50 coefval = 0.5d0 * dble(ival) surfa = 0.0d0 surfb = 0.0d0 surfc = 0.0d0 surfd = 0.0d0 vola = 0.0d0 volb = 0.0d0 volc = 0.0d0 vold = 0.0d0 if (itrig .eq. 1) then rbc = edge_dist(edge_list(4)) rbd = edge_dist(edge_list(5)) rcd = edge_dist(edge_list(6)) rbc2 = rbc * rbc rbd2 = rbd * rbd rcd2 = rcd * rcd call threesphere_dvol (rb,rc,rd,rb2,rc2,rd2, & rbc,rbd,rcd,rbc2,rbd2, & rcd2,surfb,surfc,surfd, & volb,volc,vold,dsurfb3, & dsurfc3,dsurfd3,dvolb3, & dvolc3,dvold3,option) if (option .eq. 1) then call update_deriv (dsurf_dist,dsurfb3, & dsurfc3,dsurfd3, & coef(ib-4),coef(ic-4), & coef(id-4),coefval, & edge_list(4), & edge_list(5), & edge_list(6)) call update_deriv (dvol_dist,dvolb3, & dvolc3,dvold3, & coef(ib-4),coef(ic-4), & coef(id-4),coefval, & edge_list(4), & edge_list(5), & edge_list(6)) end if else if (itrig .eq. 2) then rac = edge_dist(edge_list(2)) rad = edge_dist(edge_list(3)) rcd = edge_dist(edge_list(6)) rac2 = rac * rac rad2 = rad * rad rcd2 = rcd * rcd call threesphere_dvol (ra,rc,rd,ra2,rc2,rd2, & rac,rad,rcd,rac2,rad2, & rcd2,surfa,surfc,surfd, & vola,volc,vold,dsurfa3, & dsurfc3,dsurfd3,dvola3, & dvolc3,dvold3,option) if (option .eq. 1) then call update_deriv (dsurf_dist,dsurfa3, & dsurfc3,dsurfd3, & coef(ia-4),coef(ic-4), & coef(id-4),coefval, & edge_list(2), & edge_list(3), & edge_list(6)) call update_deriv (dvol_dist,dvola3, & dvolc3,dvold3, & coef(ia-4),coef(ic-4), & coef(id-4),coefval, & edge_list(2), & edge_list(3), & edge_list(6)) end if else if (itrig .eq. 3) then rab = edge_dist(edge_list(1)) rad = edge_dist(edge_list(3)) rbd = edge_dist(edge_list(5)) rab2 = rab * rab rad2 = rad * rad rbd2 = rbd * rbd call threesphere_dvol (ra,rb,rd,ra2,rb2,rd2, & rab,rad,rbd,rab2,rad2, & rbd2,surfa,surfb,surfd, & vola,volb,vold,dsurfa3, & dsurfb3,dsurfd3,dvola3, & dvolb3,dvold3,option) if (option .eq. 1) then call update_deriv (dsurf_dist,dsurfa3, & dsurfb3,dsurfd3, & coef(ia-4),coef(ib-4), & coef(id-4),coefval, & edge_list(1), & edge_list(3), & edge_list(5)) call update_deriv (dvol_dist,dvola3, & dvolb3,dvold3, & coef(ia-4),coef(ib-4), & coef(id-4),coefval, & edge_list(1), & edge_list(3), & edge_list(5)) end if else if (itrig .eq. 4) then rab = edge_dist(edge_list(1)) rac = edge_dist(edge_list(2)) rbc = edge_dist(edge_list(4)) rab2 = rab * rab rac2 = rac * rac rbc2 = rbc * rbc call threesphere_dvol (ra,rb,rc,ra2,rb2,rc2, & rab,rac,rbc,rab2,rac2, & rbc2,surfa,surfb,surfc, & vola,volb,volc,dsurfa3, & dsurfb3,dsurfc3,dvola3, & dvolb3,dvolc3,option) if (option .eq. 1) then call update_deriv (dsurf_dist,dsurfa3, & dsurfb3,dsurfc3, & coef(ia-4),coef(ib-4), & coef(ic-4),coefval, & edge_list(1), & edge_list(2), & edge_list(4)) call update_deriv (dvol_dist,dvola3, & dvolb3,dvolc3, & coef(ia-4),coef(ib-4), & coef(ic-4),coefval, & edge_list(1), & edge_list(2), & edge_list(4)) end if end if ballwsurf(ia) = ballwsurf(ia) + coefval*surfa ballwsurf(ib) = ballwsurf(ib) + coefval*surfb ballwsurf(ic) = ballwsurf(ic) + coefval*surfc ballwsurf(id) = ballwsurf(id) + coefval*surfd ballwvol(ia) = ballwvol(ia) + coefval*vola ballwvol(ib) = ballwvol(ib) + coefval*volb ballwvol(ic) = ballwvol(ic) + coefval*volc ballwvol(id) = ballwvol(id) + coefval*vold end if end if 50 continue end do end if end do c c now add contribution of two sphere c do iedge = 1, nedge if (coef_edge(iedge) .ne. 0.0d0) then ia = edges(1,iedge) ib = edges(2,iedge) ra = radball(ia) rb = radball(ib) ra2 = ra * ra rb2 = rb * rb rab = edge_dist(iedge) rab2 = rab * rab call twosphere_dvol (ra,ra2,rb,rb2,rab,rab2,surfa,surfb, & vola,volb,dsurfa2,dsurfb2,dvola2, & dvolb2,option) ballwsurf(ia) = ballwsurf(ia) - coef_edge(iedge)*surfa ballwsurf(ib) = ballwsurf(ib) - coef_edge(iedge)*surfb ballwvol(ia) = ballwvol(ia) - coef_edge(iedge)*vola ballwvol(ib) = ballwvol(ib) - coef_edge(iedge)*volb if (option .eq. 1) then dsurf_dist(iedge) = dsurf_dist(iedge) - coef_edge(iedge) & * (coef(ia-4)*dsurfa2+coef(ib-4)*dsurfb2) dvol_dist(iedge) = dvol_dist(iedge) - coef_edge(iedge) & * (coef(ia-4)*dvola2 + coef(ib-4)*dvolb2) end if end if end do c c now loop over vertices c do i = 1, nvertex if (.not. btest(vinfo(i),0)) goto 60 c c if vertex is not in alpha complex, then nothing to do c if (.not. btest(vinfo(i),7)) goto 60 c c vertex is in alpha complex if its weight is 0 (buried), c then nothing to do c if (coef_vertex(i) .eq. 0.0d0) goto 60 ra = radball(i) surfa = 4.0d0 * pi * ra * ra vola = surfa * ra / 3.0d0 ballwsurf(i) = ballwsurf(i) + coef_vertex(i)*surfa ballwvol(i) = ballwvol(i) + coef_vertex(i)*vola 60 continue end do c c compute total surface (weighted, and unweighted): c do i = 1, nvertex if (btest(vinfo(i),0)) then surf = surf + ballwsurf(i) ballwsurf(i-4) = ballwsurf(i) * coef(i-4) wsurf = wsurf + ballwsurf(i-4) vol = vol + ballwvol(i) ballwvol(i-4) = ballwvol(i) * coef(i-4) wvol = wvol + ballwvol(i-4) end if end do if (option .ne. 1) return c c convert distance derivatives to coordinate derivatives c do i = 1, nvertex do j = 1, 3 dsurf_coord(j,i) = 0.0d0 dvol_coord(j,i) = 0.0d0 end do end do do iedge = 1,nedge ia = edges(1,iedge) ib = edges(2,iedge) do i = 1, 3 u(i) = crdball(3*(ia-1)+i) - crdball(3*(ib-1)+i) end do rab = edge_dist(iedge) val = dsurf_dist(iedge) / rab val2 = dvol_dist(iedge) / rab do j = 1, 3 dsurf_coord(j,ia-4) = dsurf_coord(j,ia-4) + u(j)*val dsurf_coord(j,ib-4) = dsurf_coord(j,ib-4) - u(j)*val dvol_coord(j,ia-4) = dvol_coord(j,ia-4) + u(j)*val2 dvol_coord(j,ib-4) = dvol_coord(j,ib-4) - u(j)*val2 end do end do c c perform deallocation of some local arrays c deallocate (sparse_row) deallocate (edges) deallocate (coef_edge) deallocate (coef_vertex) deallocate (edge_surf) deallocate (edge_vol) deallocate (edge_dist) deallocate (dsurf_dist) deallocate (dvol_dist) return end c c c ################################################################## c ## ## c ## subroutine alf_tetra -- sphere radius orthogonal to four ## c ## ## c ################################################################## c c c "alf_tetra" computes the radius of the sphere orthogonal c to the four spheres that define a tetrahedron c c need to know how the radius compares to alpha, so the output c is the result of the comparison, not the radius itself c c variables and parameters: c c a,b,c,d coordinates of four points defining tetrahedron c ra,rb,rc,rd radii of the four points c alpha value of alpha for the alpha shape (usually 0) c iflag set to 1 if tetrahedron belongs to alpha complex, c set to 0 otherwise c c subroutine alf_tetra (a,b,c,d,ra,rb,rc,rd,iflag,alpha) use shapes implicit none integer i,j,k integer iflag real*8 dabc,dabd,dacd,dbcd real*8 d1,d2,d3,d4,det real*8 num,den,alpha real*8 test,val real*8 ra,rb,rc,rd real*8 a(4),b(4),c(4),d(4) real*8 sab(3),sac(3),sad(3) real*8 sbc(3),sbd(3),scd(3) real*8 sa(3),sb(3),sc(3),sd(3) real*8 sam1(3),sbm1(3) real*8 scm1(3),sdm1(3) real*8 deter(3) save c c iflag = 0 val = a(4)+b(4) - 2.0d0*(a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+ra*rb) if (val .gt. 0) return val = a(4)+c(4) - 2.0d0*(a(1)*c(1)+a(2)*c(2)+a(3)*c(3)+ra*rc) if (val .gt. 0) return val = a(4)+d(4) - 2.0d0*(a(1)*d(1)+a(2)*d(2)+a(3)*d(3)+ra*rd) if (val .gt. 0) return val = b(4)+c(4) - 2.0d0*(b(1)*c(1)+b(2)*c(2)+b(3)*c(3)+rb*rc) if (val .gt. 0) return val = b(4)+d(4) - 2.0d0*(b(1)*d(1)+b(2)*d(2)+b(3)*d(3)+rb*rd) if (val .gt. 0) return val = c(4)+d(4) - 2.0d0*(c(1)*d(1)+c(2)*d(2)+c(3)*d(3)+rc*rd) if (val .gt. 0) return c c compute all minors of the form: c c Smn(i+j-2) = M(m,n,i,j) = Det | m(i) m(j) | c | n(i) n(j) | c c for all i in [1,2] and all j in [i+1,3] c do i = 1, 2 do j = i+1, 3 k = i + j - 2 sab(k) = a(i)*b(j) - a(j)*b(i) sac(k) = a(i)*c(j) - a(j)*c(i) sad(k) = a(i)*d(j) - a(j)*d(i) sbc(k) = b(i)*c(j) - b(j)*c(i) sbd(k) = b(i)*d(j) - b(j)*d(i) scd(k) = c(i)*d(j) - c(j)*d(i) end do end do c c compute all Minors of the form: c c sq(i+j-2) = M(m,n,p,i,j,0) = Det | m(i) m(j) 1 | c | n(i) n(j) 1 | c | p(i) p(j) 1 | c c and all Minors of the form: c c det(i+j-2) = M(m,n,p,q,i,j,4,0) = Det | m(i) m(j) m(4) 1 | c | n(i) n(j) n(4) 1 | c | p(i) p(j) p(4) 1 | c | q(i) q(j) q(4) 1 | c c m,n,p,q are the four vertices of the tetrahedron, i and j c correspond to two of the coordinates of the vertices, and c m(4) refers to the "weight" of vertices m c do i = 1, 3 sa(i) = scd(i) - sbd(i) + sbc(i) sb(i) = scd(i) - sad(i) + sac(i) sc(i) = sbd(i) - sad(i) + sab(i) sd(i) = sbc(i) - sac(i) + sab(i) sam1(i) = -sa(i) sbm1(i) = -sb(i) scm1(i) = -sc(i) sdm1(i) = -sd(i) end do do i = 1, 3 deter(i) = a(4)*sa(i) - b(4)*sb(i) + c(4)*sc(i) - d(4)*sd(i) end do c c find the determinant needed to compute the radius of the c sphere orthogonal to the four balls defining the tetrahedron c c d1 = Minor(a,b,c,d,4,2,3,0) c d2 = Minor(a,b,c,d,1,3,4,0) c d3 = Minor(a,b,c,d,1,2,4,0) c d4 = Minor(a,b,c,d,1,2,3,0) c d1 = deter(3) d2 = deter(2) d3 = deter(1) d4 = a(1)*sa(3) - b(1)*sb(3) + c(1)*sc(3) - d(1)*sd(3) c c compute all minors of the form: c c Dmnp = Minor(m,n,p,1,2,3) = Det | m(1) m(2) m(3) | c | n(1) n(2) n(3) | c | p(1) p(2) p(3) | c dabc = a(1)*sbc(3) - b(1)*sac(3) + c(1)*sab(3) dabd = a(1)*sbd(3) - b(1)*sad(3) + d(1)*sab(3) dacd = a(1)*scd(3) - c(1)*sad(3) + d(1)*sac(3) dbcd = b(1)*scd(3) - c(1)*sbd(3) + d(1)*sbc(3) c c also need to determine: c c det = Det | m(1) m(2) m(3) m(4) | c | n(1) n(2) n(3) n(4) | c | p(1) p(2) p(3) p(4) | c | q(1) q(2) q(3) q(4) | c det = -a(4)*dbcd + b(4)*dacd - c(4)*dabd + d(4)*dabc c c get radius of the circumsphere of the weighted tetrahedron c num = d1*d1 + d2*d2 + d3*d3 + 4*d4*det den = 4.0d0 * d4 * d4 c c if radius is too close to the value of alpha c test = alpha*den - num c c spectrum for a tetrahedron is [R_t Infinity]. If alpha is in c that interval, the tetrahedron is part of the alpha shape, c otherwise it is discarded c c if tetrahedron is part of the alpha shape, then its triangles, c the edges and the vertices are also part of the alpha complex c iflag = 0 if (test .gt. 0) iflag = 1 return end c c c ################################################################# c ## ## c ## subroutine alf_trig -- checks triangle in alpha complex ## c ## ## c ################################################################# c c c "alf_trig" checks if whether a triangle belongs to the alpha c complex; computes the radius of the sphere orthogonal to the c three balls defining the triangle; if this radius is smaller c than alpha the triangle belongs to the alpha complex c c also check if the triangle is "attached", i.e., if the fourth c vertex of any of the tetrahedra attached to the triangle is c "hidden" by the triangle (there are up to two such vertices, c D and E, depending if the triangle is on convex hull or not) c c variables and parameters: c c a,b,c,d,e coordinates of the points A, B, C, D and E c defining the triangle and the two vertices c "attached" to it (from the two tetrahedra c sharing A, B and C) c ra,rb,rc,rd,re radii of the five points c ie flag: 0 is e does not exist, not 0 otherwise c alpha value of alpha for the alpha shape c (usually 0 for measures of molecule) c irad integer flag set to 1 if radius(trig) < alpha c iattach integer flag set to 1 if triangle is attached c c subroutine alf_trig (a,b,c,d,e,ra,rb,rc,rd,re, & ie,irad,iattach,alpha) use shapes implicit none integer i,j,ie integer irad,iattach real*8 ra,rb,rc,rd,re,val real*8 alpha,dabc real*8 a(4),b(4),c(4),d(4),e(4) real*8 sab(3,4),sac(3,4),sbc(3,4) real*8 s(3,4),t(2,3) logical attach,testr save c c irad = 0 val = a(4) + b(4) - 2.0d0*(a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+ra*rb) if (val .gt. 0) return val = a(4) + c(4) - 2.0d0*(a(1)*c(1)+a(2)*c(2)+a(3)*c(3)+ra*rc) if (val .gt. 0) return val = b(4) + c(4) - 2.0d0*(b(1)*c(1)+b(2)*c(2)+b(3)*c(3)+rb*rc) if (val .gt. 0) return iattach = 0 irad = 0 c c compute all Minors of the form c c smn(i,j) = M(m,n,i,j) = Det | m(i) m(j) | c | n(i) n(j) | c c m,n are two vertices of the triangle, i and j correspond c to two of the coordinates of the vertices c c for all i in [1,3] and all j in [i+1,4] c do i = 1, 3 do j = i+1, 4 sab(i,j) = a(i)*b(j) - a(j)*b(i) sac(i,j) = a(i)*c(j) - a(j)*c(i) sbc(i,j) = b(i)*c(j) - b(j)*c(i) end do end do c c next compute all Minors of the form c c s(i,j) = M(a,b,c,i,j,0) = Det | a(i) a(j) 1 | c | b(i) b(j) 1 | c | c(i) c(j) 1 | c c A, B and C are the vertices of the triangle, i and j c correspond to two of the coordinates of the vertices c c for all i in [1,3] and all j in [i+1,4] c do i = 1, 3 do j = i+1, 4 s(i,j) = sbc(i,j) - sac(i,j) + sab(i,j) end do end do c c now compute all Minors of the form c c t(i,j) = M(a,b,c,i,j,4) = Det | a(i) a(j) a(4) | c | b(i) b(j) b(4) | c | c(i) c(j) c(4) | c c for all i in [1,2] and all j in [i+1,3] c do i = 1, 2 do j = i+1, 3 t(i,j) = a(4)*sbc(i,j) - b(4)*sac(i,j) + c(4)*sab(i,j) end do end do c c finally, find dabc = M(a,b,c,1,2,3) = Det | a(1) a(2) a(3) | c | b(2) b(2) b(3) | c | c(3) c(2) c(3) | c dabc = a(1)*sbc(2,3) - b(1)*sac(2,3) + c(1)*sab(2,3) c c first check if A, B and C ate attached to D c call triangle_attach (a,b,c,d,ra,rb,rc,rd,s,t,dabc,attach) c c if attached, stop here as the triangle will not be part c of the alpha complex c if (attach) then iattach = 1 return end if c c if E exists, check if A,B,C attached to E c if (ie .ne. 0) then call triangle_attach (a,b,c,e,ra,rb,rc,re,s,t,dabc,attach) c c if attached, stop here as the triangle will not be part c of the alpha complex c if (attach) then iattach = 1 return end if end if c c now check if alpha is bigger than the radius of the sphere c orthogonal to the three balls at A, B and C c call triangle_radius (a,b,c,ra,rb,rc,s,t,dabc,testr,alpha) if (testr) irad = 1 return end c c c ################################################################ c ## ## c ## subroutine alf_edge -- checks edge in to alpha complex ## c ## ## c ################################################################ c c c "alf_edge" checks if an edge belongs to the alpha complex; c computes the radius of the sphere orthogonal to the two c balls defining the edge, if this radius is smaller than c alpha then the edge belongs to the alpha complex c c also checked if the edge is "attached", i.e., if the third c vertex of any of the triangles attached to the edge is c hidden by the edge c c variables and parameters: c c a,b coordinates of the points defining the edge c ra,rb radii of the two points c ncheck number of triangles in the star of the edge c chklist list of vertices to check c alpha value of alpha for the alpha shape c (usually 0 for measures of molecule) c irad integer flag set to 1 if radius(edge) < alpha c iattach integer flag set to 1 if edge is attached c c subroutine alf_edge (a,b,ra,rb,cg,ncheck,chklist, & irad,iattach,alpha) use shapes implicit none integer i,j,k,ic integer ncheck integer irad integer iattach integer chklist(*) real*8 alpha,val real*8 ra,rb,rc real*8 dab(4),sab(3),tab(3) real*8 a(4),b(4),c(4),cg(3) logical attach,rad save c c iattach = 1 irad = 0 val = a(4) + b(4) - 2.0d0*(a(1)*b(1)+a(2)*b(2)+a(3)*b(3)+ra*rb) if (val .gt. 0) return c c compute all Minors of the form c c dab(i) = M(a,b,i,0) = Det | a(i) 1 | c | b(i) 1 | c c for all i in [1,4] c do i = 1, 4 dab(i) = a(i) - b(i) end do c c compute all Minors of the form c c sab(i,j) = M(a,b,i,j) = Det | a(i) a(j) | c | b(i) b(j) | c do i = 1, 2 do j = i+1, 3 k = i + j - 2 sab(k) = a(i)*b(j) - b(i)*a(j) end do end do c c compute all Minors of the form c c tab(i) = M(a,b,i,4) = Det | a(i) a(4) | c | b(i) b(4) | c do i = 1, 3 tab(i) = a(i)*b(4) - b(i)*a(4) end do c c first check the attachment c do i = 1, ncheck ic = chklist(i) do j = 1, 3 c(j) = crdball(3*(ic-1)+j) - cg(j) end do rc = radball(ic) c(4) = c(1)*c(1) + c(2)*c(2) + c(3)*c(3) - rc*rc call edge_attach (a,b,c,ra,rb,rc,dab,sab,tab,attach) if (attach) return end do iattach = 0 c c edge is not attached, check radius c call edge_radius (a,b,ra,rb,dab,sab,tab,rad,alpha) if (rad) irad = 1 return end c c c ############################################################### c ## ## c ## subroutine edge_radius -- radius to edge circumsphere ## c ## ## c ############################################################### c c c "edge_radius" computes the radius of the smallest circumsphere c to an edge, and compares it to alpha c c variables and parameters: c c a,b coordinate of the two vertices defining the edge c dab minor(a,b,i,0) for all i=1,2,3,4 c sab minor(a,b,i,j) for i = 1,2 and j =i+1,3 c tab minor(a,b,i,4) for i = 1,2,3 c alpha value of alpha considered c testr flag that defines if radius smaller than alpha c c subroutine edge_radius (a,b,ra,rb,dab,sab,tab,testr,alpha) use iounit use shapes implicit none integer i real*8 d0,d1,d2,d3,d4 real*8 alpha real*8 num,den,rho2 real*8 ra,rb real*8 r_11,r_22,r_33 real*8 r_14,r_313,r_212,diff real*8 a(4),b(4) real*8 sab(3),dab(4),tab(3) real*8 res(0:3,1:4) logical testr save c c c formula have been derived by projection on 4D space, which c requires caution when some coordinates are equal c testr = .false. res(0,4) = dab(4) if (a(1) .ne. b(1)) then do i = 1, 3 res(0,i) = dab(i) res(i,4) = tab(i) end do res(1,2) = sab(1) res(1,3) = sab(2) res(2,3) = sab(3) else if (a(2) .ne. b(2)) then res(0,1) = dab(2) res(0,2) = dab(3) res(0,3) = dab(1) res(1,2) = sab(3) res(1,3) = -sab(1) res(2,3) = -sab(2) res(1,4) = tab(2) res(2,4) = tab(3) res(3,4) = tab(1) else if (a(3) .ne. b(3)) then res(0,1) = dab(3) res(0,2) = dab(1) res(0,3) = dab(2) res(1,2) = -sab(2) res(1,3) = -sab(3) res(2,3) = sab(1) res(1,4) = tab(3) res(2,4) = tab(1) res(3,4) = tab(2) else write (iout,10) 10 format (/,' EDGE_RADIUS -- A Fatal Error has Occurred') call fatal end if r_11 = res(0,1) * res(0,1) r_22 = res(0,2) * res(0,2) r_33 = res(0,3) * res(0,3) r_14 = res(0,1) * res(0,4) r_313 = res(0,3) * res(1,3) r_212 = res(0,2) * res(1,2) diff = res(0,3)*res(1,2) - res(0,2)*res(1,3) c c first compute the radius of circumsphere c d0 = -2.0d0 * res(0,1) * (r_11+r_22+r_33) d1 = res(0,1) * (2.0d0*(r_313+r_212)-r_14) d2 = -2.0d0*res(1,2)*(r_11+r_33) - res(0,2)*(r_14-2.0d0*r_313) d3 = -2.0d0*res(1,3)*(r_11+r_22) - res(0,3)*(r_14-2*r_212) d4 = 2.0d0 * res(0,1) * (res(0,1)*res(1,4) + res(0,2)*res(2,4) & + res(0,3)*res(3,4)) + 4.0d0*(res(2,3)*diff & - res(0,1)*(res(1,2)*res(1,2) + res(1,3)*res(1,3))) num = d1*d1 + d2*d2 + d3*d3 - d0*d4 den = d0 * d0 c c for efficiency, assume this routine is only used to compute c the dual complex (i.e., alpha=0) and thus do not consider c the denominator as it is always positive c c rho2 = num / den rho2 = num if (alpha .gt. rho2) testr = .true. return end c c c ################################################################ c ## ## c ## subroutine edge_attach -- edge attached to tetrahedron ## c ## ## c ################################################################ c c c "edge_attach" checks if edge AB of a tetrahedron is "attached" c to a given vertex C c c variables and parameters: c c a,b,c coordinates of the three points c ra,rb,rc radii of the three pointd c dab minor(a,b,i,0) for all i=1,2,3,4 c sab minor(a,b,i,j) for i = 1,2 and j =i+1,3 c tab minor(a,b,i,4) for all i=1,2,3 c testa logical flag marks if edge is attached or not c c subroutine edge_attach (a,b,c,ra,rb,rc,dab,sab,tab,testa) use iounit use shapes implicit none integer i,j,k real*8 dtest real*8 r_11,r_22,r_33 real*8 diff,d0,d5 real*8 ra,rb,rc real*8 sab(3),dab(4),tab(3) real*8 sc(3),tc(3) real*8 a(4),b(4),c(4) real*8 res(0:3,1:3) real*8 res2_c(3,4) logical testa save c c c need to compute: c sc as minor(a,b,c,i,j,0) for i = 1,2 and j = i+1,3 c tc as minor(a,b,c,i,4,0) for i = 1,2,3 c testa = .false. do i = 1, 2 do j = i+1, 3 k = i + j - 2 sc(k) = c(i)*dab(j) - c(j)*dab(i) + sab(k) end do end do do i = 1, 3 tc(i) = c(i)*dab(4) - c(4)*dab(i) + tab(i) end do c c formula have been derived by projection on 4D space, which c requires caution when some coordinates are equal c if (a(1) .ne. b(1)) then do i = 1, 3 res(0,i) = dab(i) res2_c(i,4) = tc(i) end do res(1,2) = sab(1) res(1,3) = sab(2) res(2,3) = sab(3) res2_c(1,2) = sc(1) res2_c(1,3) = sc(2) res2_c(2,3) = sc(3) else if (a(2) .ne. b(2)) then res(0,1) = dab(2) res(0,2) = dab(3) res(0,3) = dab(1) res(1,2) = sab(3) res(1,3) = -sab(1) res(2,3) = -sab(2) res2_c(1,2) = sc(3) res2_c(1,3) = -sc(1) res2_c(2,3) = -sc(2) res2_c(1,4) = tc(2) res2_c(2,4) = tc(3) res2_c(3,4) = tc(1) else if (a(3) .ne. b(3)) then res(0,1) = dab(3) res(0,2) = dab(1) res(0,3) = dab(2) res(1,2) = -sab(2) res(1,3) = -sab(3) res(2,3) = sab(1) res2_c(1,2) = -sc(2) res2_c(1,3) = -sc(3) res2_c(2,3) = sc(1) res2_c(1,4) = tc(3) res2_c(2,4) = tc(1) res2_c(3,4) = tc(2) else write (iout,10) 10 format (/,' EDGE_ATTACH -- A Fatal Error has Occurred') call fatal end if r_11 = res(0,1) * res(0,1) r_22 = res(0,2) * res(0,2) r_33 = res(0,3) * res(0,3) diff = res(0,3)*res(1,2) - res(0,2)*res(1,3) c c check the attachment with vertex C c d0 = -2.0d0 * res(0,1) * (r_11+r_22+r_33) d5 = res(0,1) * (res(0,1)*res2_c(1,4) + res(0,2)*res2_c(2,4) & + res(0,3)*res2_c(3,4) - 2.0d0*(res(1,3)*res2_c(1,3) & + res(1,2)*res2_c(1,2))) + 2.0d0*res2_c(2,3)*diff dtest = d0 * d5 if (dtest .lt. 0) testa = .true. return end c c c ################################################################## c ## ## c ## subroutine triangle_attach -- test point in circumsphere ## c ## ## c ################################################################## c c c "triangle_attach" tests whether a point D is inside the c circumsphere defined by three other points A, B and C c c for the three points A,B,C that form the triangles, the code c needs as input the following determinants: c c s(i,j) = Minor(a,b,c,i,j,0) = det | a(i) a(j) 1 | c | b(i) b(j) 1 | c | c(i) c(j) 1 | c for all i in [1,3], j in [i+1,4] c c t(i,j) = Minor(a,b,c,i,j,4) = det | a(i) a(j) a(4) | c | b(i) b(j) b(4) | c | c(i) c(j) c(4) | c c for all i in [1,2] and all j in [i+1,3] c c dabc = det | a(1) a(2) a(3) | c | b(1) b(2) b(3) | c | c(1) c(2) c(3) | c c and the coordinates of the fourth vertex d c c upon output "testa" is set to 1 if the fourth point d is c inside the circumsphere of {a,b,c} c c subroutine triangle_attach (a,b,c,d,ra,rb,rc,rd,s,t,dabc,testa) use shapes implicit none real*8 test real*8 dabc,deter real*8 det1,det2,det3 real*8 ra,rb,rc,rd real*8 a(4),b(4) real*8 c(4),d(4) real*8 s(3,4),t(2,3) logical testa save c c testa = .false. det1 = -d(2)*s(3,4) + d(3)*s(2,4) - d(4)*s(2,3) + t(2,3) det2 = -d(1)*s(3,4) + d(3)*s(1,4) - d(4)*s(1,3) + t(1,3) det3 = -d(1)*s(2,4) + d(2)*s(1,4) - d(4)*s(1,2) + t(1,2) deter = -d(1)*s(2,3) + d(2)*s(1,3) - d(3)*s(1,2) + dabc c c check if the face is attached to the fourth vertex of c the parent tetrahedron c test = det1*s(2,3) + det2*s(1,3) + det3*s(1,2) & - 2.0d0*deter*dabc if (test .gt. 0) testa = .true. return end c c c ################################################################## c ## ## c ## subroutine triangle_radius -- radius containing triangle ## c ## ## c ################################################################## c c c "triangle_radius" finds the radius of the smallest circumsphere c to a triangle c c for the three points A,B,C that form the triangles, the code c needs as input the following determinants: c c s(i,j) = Minor(a,b,c,i,j,0) = det | a(i) a(j) 1 | c | b(i) b(j) 1 | c | c(i) c(j) 1 | c c for i in [1,3] and j in [i+1,4] c c t(i,j) = Minor(a,b,c,i,j,4) = det | a(i) a(j) a(4) | c | b(i) b(j) b(4) | c | c(i) c(j) c(4) | c c dabc = Minor(a,b,c,1,2,3) c c upon output "testr" is set to 1 if alpha is larger than rho, c the radius of the circumsphere of the triangle c c subroutine triangle_radius (a,b,c,ra,rb,rc,s,t, & dabc,testr,alpha) use shapes implicit none real*8 dabc real*8 d0,d1,d2,d3,d4 real*8 alpha real*8 sums2,num real*8 ra,rb,rc real*8 a(4),b(4),c(4) real*8 s(3,4),t(2,3) logical testr save c c testr = .false. sums2 = s(1,2)*s(1,2) + s(1,3)*s(1,3) + s(2,3)*s(2,3) d0 = sums2 d1 = s(1,3)*s(3,4) + s(1,2)*s(2,4) - 2.0d0*dabc*s(2,3) d2 = s(1,2)*s(1,4) - s(2,3)*s(3,4) - 2.0d0*dabc*s(1,3) d3 = s(2,3)*s(2,4) + s(1,3)*s(1,4) + 2.0d0*dabc*s(1,2) d4 = s(1,2)*t(1,2) + s(1,3)*t(1,3) + s(2,3)*t(2,3) & - 2.0d0*dabc*dabc num = 4.0d0*(d1*d1+d2*d2+d3*d3) + 16.0d0*d0*d4 if (alpha .gt. num) testr = .true. return end c c c ############################################################## c ## ## c ## subroutine vertex_attach -- vertex-vertex attachment ## c ## ## c ############################################################## c c c "vertex_attach" tests for a vertex is attached to another c vertex, the computation is done in both directions c c let S be a simplex, and y_S the center of the ball orthogonal c to all balls in S; point p is attached to S if and only if c pi(y_S, p) < 0, where pi is the power distance between the c two weighted points y_S and p c c let S = {a}, with a weight of ra**2, then y_S is the ball c centered at a, but with weight -ra**2, the power distance c between y_S and a point b is: c c pi(y_S, b) = dist(a,b)**2 + ra**2 - rb**2 c c subroutine vertex_attach (a,b,ra,rb,testa,testb) use shapes implicit none integer i real*8 ra,rb,ra2,rb2 real*8 dist2 real*8 test1,test2 real*8 dab(3) real*8 a(4),b(4) logical testa,testb save c c testa = .false. testb = .false. do i = 1, 3 dab(i) = a(i) - b(i) end do ra2 = ra * ra rb2 = rb * rb dist2 = dab(1)*dab(1) + dab(2)*dab(2) + dab(3)*dab(3) test1 = dist2 + ra2 - rb2 test2 = dist2 - ra2 + rb2 if (test1 .lt. 0) testa = .true. if (test2 .lt. 0) testb = .true. return end c c c ################################################################# c ## ## c ## subroutine locate_jw -- find tetrahedron with new point ## c ## ## c ################################################################# c c c "locate_jw" finds the tetrahedron containing a new point to be c added in the triangulation c c variables and parameters: c c ival index of the points to be located c tetra_loc tetrahedron containing the point c iredundant flag set to 0 if not redundant, 1 otherwise c c the point location scheme uses a "jump-and-walk" technique; c first, N active tetrahedra are chosen at random, the distances c between these tetrahedra and the point to be added are computed, c and the tetrahedron closest to the point is chosen as a starting c point, then walk from that tetrahedron to the point, until a c tetrahedron containing the point is found; also checks if the c point is redundant in the current tetrahedron, ending the search c c subroutine locate_jw (iseed,ival,tetra_loc,iredundant) use shapes implicit none integer i,ival,itetra integer a,b,c,d integer idx,iorient,iseed integer tetra_loc,iredundant logical test_in,test_red save c c c start at the root of the history dag with tetra(1) c iredundant = 0 if (ntetra .eq. 1) then tetra_loc = 1 return end if if (tetra_loc .le. 0) then do i = ntetra, 1, -1 if (btest(tinfo(i),1)) then itetra = i goto 10 end if end do 10 continue else itetra = tetra_loc end if 20 continue a = tetra(1,itetra) b = tetra(2,itetra) c = tetra(3,itetra) d = tetra(4,itetra) iorient = -1 if (btest(tinfo(itetra),0)) iorient = 1 call inside_tetra_jw (ival,a,b,c,d,iorient,test_in,test_red,idx) if (test_in) goto 30 itetra = tneighbor(idx,itetra) goto 20 30 continue tetra_loc = itetra c c tetrahedron is found, so check if point is redundant c if (test_red) iredundant = 1 return end c c c ################################################################## c ## ## c ## subroutine inside_tetra_jw -- tests point in tetrahedron ## c ## ## c ################################################################## c c c "inside_tetra_jw" tests if a point P is inside the tetrahedron c defined by four points ABCD with orientation "iorient", if P c is inside the tetrahedron, then also checks if it is redundant c c variables and parameters: c c p index of the point to be checked c a,b,c,d four vertices of the tetrahedron c iorient orientation of the tetrahedron c inside logical flag to mark P inside the ABCD tetrahedron c redundant logical flag to mark whether point P is redundant c ifail index of the face that fails the orientation test c in case where P is not inside the tetrahedron c c subroutine inside_tetra_jw (p,a,b,c,d,iorient,inside, & redundant,ifail) use shapes implicit none integer i,j,k,l,m integer p,a,b,c,d integer ia,ib,ic,id,ie,idx integer ic1,ic5,ic1_k,ic1_l integer sign,sign5 integer sign_k,sign_l integer nswap,iswap,ninf integer iorient,ifail,val integer list(4) integer sign4_3(4) integer infpoint(4) integer inf4_1(4),sign4_1(4) integer inf4_2(4,4),sign4_2(4,4) integer inf5_2(4,4),sign5_2(4,4) integer inf5_3(4),sign5_3(4) integer order1(3,4),order2(2,6) integer order3(2,6) real*8 sij_1,sij_2,sij_3 real*8 skl_1,skl_2,skl_3 real*8 det_pijk,det_pjil real*8 det_pkjl,det_pikl real*8 det_pijkl real*8 detij(3) real*8 coordp(3) real*8 i_p(4),j_p(4) real*8 k_p(4),l_p(4) logical test_pijk,test_pjil logical test_pkjl,test_pikl logical inside,redundant logical doweight data inf4_1 / 2, 2, 1, 1 / data sign4_1 / -1, 1, 1, -1 / data inf4_2 / 0, 2, 3, 3, 2, 0, 3, 3, 3, 3, 0, 1, 3, 3, 1, 0 / data sign4_2 / 0, 1, -1, 1, -1, 0, 1, -1, & 1, -1, 0, 1, -1, 1, -1, 0 / data sign4_3 / -1, 1, -1, 1 / data inf5_2 / 0, 2, 1, 1, 2, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 0 / data sign5_2 / 0, -1, -1, 1, 1, 0, -1, 1, & 1, 1, 0, 1, -1, -1, -1, 0 / data inf5_3 / 1, 1, 3, 3/ data sign5_3 / 1, 1, -1, 1 / data order1 / 3, 2, 4, 1, 3, 4, 2, 1, 4, 1, 2, 3 / data order2 / 3, 4, 4, 2, 2, 3, 1, 4, 3, 1, 1, 2 / data order3 / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 / save c c c if IJKL is the tetrahedron in positive orientation, then test c PIJK, PJIL, PKJL and PIKL, if all four are positive, than P is c inside the tetrahedron, all four tests rely on the sign of the c corresponding 4x4 determinant. Interestingly, these four c determinants share some common lines, which can be used to c speed up the computation c c consider: det(p,i,j,k) = | p(1) p(2) p(3) 1 | c | i(1) i(2) i(3) 1 | c | j(1) j(2) j(3) 1 | c | k(1) k(2) k(3) 1 | c c note P appears in each determinant, so the corresponding line c can be substraced from all other lines; using the example c above gives: c c det(i,j,k,l) = - | ip(1) ip(2) ip(3) | c | jp(1) jp(2) jp(3) | c | kp(1) kp(2) kp(3) | c c where xp(m) = x(m)-p(m) for x = i,j,k and m = 1,2,3 c c notice the first two lines of det(p,i,j,k) and det(p,i,j,l) c are the same c c let us define: c c Sij_3=|ip(1) ip(2)| Sij_2=|ip(1) ip(3)| Sij_1=|ip(2) ip(3)| c |jp(1) jp(2)| |jp(1) jp(3)| |jp(2) jp(3)| c c then det(p,i,j,k) = -kp(1)*Sij_1 + kp(2)*Sij_2 - kp(3)*Sij_3, c and det(p,j,i,l) = lp(1)*Sij_1 - lp(2)*Sij_2 + lp(3)*Sij_3 c c similarly, define: c c Skl_3=|kp(1) kp(2)| Skl_2=|kp(1) kp(3)| Skl_1=|kp(2) kp(3)| c |lp(1) lp(2)| |lp(1) lp(3)| |lp(2) lp(3)| c c then det(p,k,j,l) = jp(1)*Skl_1 - jp(2)*Skl_2 + jp(3)*Skl_3, c and det(p,i,k,l) = -ip(1)*Skl_1 + ip(2)*Skl_2 - ip(3)*Skl_3 c c furthermore: c c det(p,i,j,k,l) = -ip(4)*det(p,k,j,l) - jp(4)*det(p,i,k,l) c - kp(4)*det(p,j,i,l) - lp(4)*det(p,i,j,k) c c the equations above hold for the general case, but special c care is required to take in account infinite points c doweight = .true. inside = .false. redundant = .false. list(1) = a list(2) = b list(3) = c list(4) = d infpoint(1) = 0 infpoint(2) = 0 infpoint(3) = 0 infpoint(4) = 0 if (a .le. 4) infpoint(1) = 1 if (b .le. 4) infpoint(2) = 1 if (c .le. 4) infpoint(3) = 1 if (d .le. 4) infpoint(4) = 1 ninf = infpoint(1) + infpoint(2) + infpoint(3) + infpoint(4) c c the general case, with no infinite point c do m = 1, 3 coordp(m) = crdball(3*p-3+m) end do c c set coordinates using i=a, j=b, k=c and l=d for convenience c if (ninf .eq. 0) then do m = 1, 3 i_p(m) = crdball(3*a-3+m) - coordp(m) j_p(m) = crdball(3*b-3+m) - coordp(m) k_p(m) = crdball(3*c-3+m) - coordp(m) l_p(m) = crdball(3*d-3+m) - coordp(m) end do c c compute the 2x2 determinants for Sij and Skl c sij_1 = i_p(2)*j_p(3) - i_p(3)*j_p(2) sij_2 = i_p(1)*j_p(3) - i_p(3)*j_p(1) sij_3 = i_p(1)*j_p(2) - i_p(2)*j_p(1) skl_1 = k_p(2)*l_p(3) - k_p(3)*l_p(2) skl_2 = k_p(1)*l_p(3) - k_p(3)*l_p(1) skl_3 = k_p(1)*l_p(2) - k_p(2)*l_p(1) c c tests for all determinants, start with inside set to false c inside = .false. det_pijk = -k_p(1)*sij_1 + k_p(2)*sij_2 - k_p(3)*sij_3 det_pijk = det_pijk * dble(iorient) test_pijk = (abs(det_pijk) .gt. epsln4) if (test_pijk .and. det_pijk.gt.0.0d0) then ifail = 4 return end if det_pjil = l_p(1)*sij_1 - l_p(2)*sij_2 + l_p(3)*sij_3 det_pjil = det_pjil * dble(iorient) test_pjil = (abs(det_pjil) .gt. epsln4) if (test_pjil .and. det_pjil.gt.0.0d0) then ifail = 3 return end if det_pkjl = j_p(1)*skl_1 - j_p(2)*skl_2 + j_p(3)*skl_3 det_pkjl = det_pkjl * dble(iorient) test_pkjl = (abs(det_pkjl) .gt. epsln4) if (test_pkjl .and. det_pkjl.gt.0.0d0) then ifail = 1 return end if det_pikl = -i_p(1)*skl_1 + i_p(2)*skl_2 - i_p(3)*skl_3 det_pikl = det_pikl * dble(iorient) test_pikl = (abs(det_pikl) .gt. epsln4) if (test_pikl .and. det_pikl.gt.0.0d0) then ifail = 2 return end if c c either all four determinants are positive, or one of the c determinants is imprecise in which case pecial care is c needed and the indices will be ranked c if (.not. test_pijk) then call valsort4 (p,a,b,c,ia,ib,ic,id,nswap) call minor4 (crdball,ia,ib,ic,id,val) val = val * nswap * iorient if (val .eq. 1) then ifail = 4 return end if end if if (.not. test_pjil) then call valsort4 (p,b,a,d,ia,ib,ic,id,nswap) call minor4 (crdball,ia,ib,ic,id,val) val = val * nswap * iorient if (val .eq. 1) then ifail = 3 return end if end if if (.not. test_pkjl) then call valsort4 (p,c,b,d,ia,ib,ic,id,nswap) call minor4 (crdball,ia,ib,ic,id,val) val = val * nswap * iorient if (val .eq. 1) then ifail = 1 return end if end if if (.not. test_pikl) then call valsort4 (p,a,c,d,ia,ib,ic,id,nswap) call minor4 (crdball,ia,ib,ic,id,val) val = val * nswap * iorient if (val .eq. 1) then ifail = 2 return end if end if c c at this point P is inside the tetrahedron, then check c to see whether P is redundant c inside = .true. if (.not. doweight) return i_p(4) = wghtball(a) - wghtball(p) j_p(4) = wghtball(b) - wghtball(p) k_p(4) = wghtball(c) - wghtball(p) l_p(4) = wghtball(d) - wghtball(p) det_pijkl = -i_p(4)*det_pkjl - j_p(4)*det_pikl & - k_p(4)*det_pjil - l_p(4)*det_pijk if (abs(det_pijkl) .lt. epsln5) then call valsort5 (p,a,b,c,d,ia,ib,ic,id,ie,nswap) call minor5 (crdball,radball,ia,ib,ic,id,ie,val) det_pijkl = val * nswap * iorient end if redundant = (det_pijkl .lt. 0.0d0) c c one of the vertices A, B, C or D is infinite, to find which c it is, we use a map between (inf(a),inf(b),inf(c),inf(d)) c and X, where inf(i) is 1 if i is infinite, 0 otherwise, c and X = 1,2,3,4 if A, B, C or D are infinite, respectively; c a good mapping function is: X = 3-inf(a)-inf(a)-inf(b)+inf(d) c else if (ninf .eq. 1) then idx = 3 - infpoint(1) - infpoint(1) - infpoint(2) + infpoint(4) l = list(idx) i = list(order1(1,idx)) j = list(order1(2,idx)) k = list(order1(3,idx)) ic1 = inf4_1(l) sign = sign4_1(l) c c there are four determinants that need to be computed: c c det_pijk unchanged c det_pjil 1 infinite point (l), becomes det3_pji c where det3_pij = | p(ic1) p(ic2) 1 | c | i(ic1) i(ic2) 1 | c | j(ic1) j(ic2) 1 | c and ic1 and ic2 depends on which infinite c (ic2 is always 3) point is considered c det_pkjl 1 infinite point (l), becomes det3_pkj c det_pikl 1 infinite point (l), becomes det3_pik c do m = 1, 3 i_p(m) = crdball(3*i-3+m) - coordp(m) j_p(m) = crdball(3*j-3+m) - coordp(m) k_p(m) = crdball(3*k-3+m) - coordp(m) end do detij(1) = i_p(1)*j_p(3) - i_p(3)*j_p(1) detij(2) = i_p(2)*j_p(3) - i_p(3)*j_p(2) detij(3) = i_p(1)*j_p(2) - i_p(2)*j_p(1) c c tests for all determinants, start with inside set to false c inside = .false. det_pijk = -k_p(1)*detij(2) + k_p(2)*detij(1) & - k_p(3)*detij(3) det_pijk = det_pijk * dble(iorient) test_pijk = (abs(det_pijk) .gt. epsln4) if (test_pijk .and. det_pijk.gt.0) then ifail = idx return end if det_pjil = -detij(ic1) * sign * iorient test_pjil = (abs(det_pjil) .gt. epsln3) if (test_pjil .and. det_pjil.gt.0.0d0) then ifail = order1(3,idx) return end if det_pkjl = k_p(ic1)*j_p(3) - k_p(3)*j_p(ic1) det_pkjl = det_pkjl * sign * iorient test_pkjl = (abs(det_pkjl) .gt. epsln3) if (test_pkjl .and. det_pkjl.gt.0.0d0) then ifail = order1(1,idx) return end if det_pikl = i_p(ic1)*k_p(3) - i_p(3)*k_p(ic1) det_pikl = det_pikl * sign * iorient test_pikl = (abs(det_pikl) .gt. epsln3) if (test_pikl .and. det_pikl.gt.0.0d0) then ifail = order1(2,idx) return end if c c either all four determinants are positive, or one of the c determinants is imprecise in which case special care is c needed and the indices will be ranked c if (.not. test_pijk) then call valsort4 (p,i,j,k,ia,ib,ic,id,nswap) call minor4 (crdball,ia,ib,ic,id,val) val = val * nswap * iorient if (val .eq. 1) then ifail = idx return end if end if if (.not. test_pjil) then call valsort3 (p,j,i,ia,ib,ic,nswap) call minor3 (crdball,ia,ib,ic,ic1,3,val) val = val * sign * nswap * iorient if (val .eq. 1) then ifail = order1(3,idx) return end if end if if (.not. test_pkjl) then call valsort3 (p,k,j,ia,ib,ic,nswap) call minor3 (crdball,ia,ib,ic,ic1,3,val) val = val * sign * nswap * iorient if (val .eq. 1) then ifail = order1(1,idx) return end if end if if (.not. test_pikl) then call valsort3 (p,i,k,ia,ib,ic,nswap) call minor3 (crdball,ia,ib,ic,ic1,3,val) val = val * sign * nswap * iorient if (val .eq. 1) then ifail = order1(2,idx) return end if end if c c at this point P is inside the tetrahedron, and since c det_pijkl = det_pijk > 1, P cannot be redundant c inside = .true. redundant = .false. c c two of the vertices A, B, C and D are infinite, to find which c they are, we use a map between (inf(a),inf(b),inf(c),inf(d)) c and X, where inf(i) is 1 if i is infinite, 0 otherwise, c and X = 1,2,3,4,5,6 if (a,b), (a,c), (a,d), (b,c), (b,d) or c (c,d) are infinite, respectively, a good mapping function is: c X = 3-inf(a)-inf(a)+inf(c)+inf(d)+inf(d) c else if (ninf .eq. 2) then idx = 3 - infpoint(1) - infpoint(1) + infpoint(3) & + infpoint(4) + infpoint(4) k = list(order3(1,idx)) l = list(order3(2,idx)) i = list(order2(1,idx)) j = list(order2(2,idx)) ic1_k = inf4_1(k) ic1_l = inf4_1(l) sign_k = sign4_1(k) sign_l = sign4_1(l) ic1 = inf4_2(k,l) sign = sign4_2(k,l) c c tests for all determinants, start with inside set to false c do m = 1, 3 i_p(m) = crdball(3*i-3+m) - coordp(m) j_p(m) = crdball(3*j-3+m) - coordp(m) end do inside = .false. det_pijk = i_p(ic1_k)*j_p(3) - i_p(3)*j_p(ic1_k) det_pijk = det_pijk * sign_k * iorient test_pijk = (abs(det_pijk) .gt. epsln3) if (test_pijk .and. det_pijk.gt.0.0d0) then ifail = order3(2,idx) return end if det_pjil = i_p(3)*j_p(ic1_l) - i_p(ic1_l)*j_p(3) det_pjil = det_pjil * sign_l * iorient test_pjil = (abs(det_pjil) .gt. epsln3) if (test_pjil .and. det_pjil.gt.0.0d0) then ifail = order3(1,idx) return end if det_pkjl = j_p(ic1) * sign * iorient test_pkjl = (abs(det_pkjl) .gt. epsln2) if (test_pkjl .and. det_pkjl.gt.0.0d0) then ifail = order2(1,idx) return end if det_pikl = -i_p(ic1) * sign * iorient test_pikl = (abs(det_pikl) .gt. epsln2) if (test_pikl .and. det_pikl.gt.0.0d0) then ifail = order2(2,idx) return end if c c either all four determinants are positive, or one of the c determinants is imprecise in which case special care is c needed and the indices will be ranked c if (.not. test_pijk) then call valsort3 (p,i,j,ia,ib,ic,nswap) call minor3 (crdball,ia,ib,ic,ic1_k,3,val) val = val * sign_k * nswap * iorient if (val .eq. 1) then ifail = order3(2,idx) return end if end if if (.not. test_pjil) then call valsort3 (p,j,i,ia,ib,ic,nswap) call minor3 (crdball,ia,ib,ic,ic1_l,3,val) val = val * sign_l * nswap * iorient if (val .eq. 1) then ifail = order3(1,idx) return end if end if if (.not. test_pkjl) then call valsort2 (p,j,ia,ib,nswap) call minor2 (crdball,ia,ib,ic1,val) val = -val * sign * nswap * iorient if (val .eq. 1) then ifail = order2(1,idx) return end if end if if (.not. test_pikl) then call valsort2 (p,i,ia,ib,nswap) call minor2 (crdball,ia,ib,ic1,val) val = val * sign * nswap * iorient if (val .eq. 1) then ifail = order2(2,idx) return end if end if c c at this point P is inside the tetrahedron, then check c to see whether P is redundant c inside = .true. redundant = .false. if (.not. doweight) return ic5 = inf5_2(k,l) sign5 = sign5_2(k,l) det_pijkl = i_p(ic5)*j_p(3) - i_p(3)*j_p(ic5) if (abs(det_pijkl) .lt. epsln3) then call valsort3 (p,i,j,ia,ib,ic,nswap) call minor3 (crdball,ia,ib,ic,ic5,3,val) det_pijkl = val * nswap end if det_pijkl = det_pijkl * sign5 * iorient redundant = (det_pijkl .lt. 0.0d0) c c three of vertices a, b, c and d are infinite, to find which c is finite, use a map between (inf(a),inf(b),inf(c),inf(d)) c and X, where inf(i) is 1 if i is infinite, 0 otherwise, and c X = 1,2,3,4 if a,b,c or d are finite, respectively; a good c mapping function is X = 1+inf(a)+inf(a)+inf(b)-inf(d) c else if (ninf .eq. 3) then idx = 1 + infpoint(1) + infpoint(1) & + infpoint(2) - infpoint(4) i = list(idx) j = list(order1(1,idx)) k = list(order1(2,idx)) l = list(order1(3,idx)) call missinf_sign (j,k,l,ie,iswap) do m = 1, 3 i_p(m) = crdball(3*i-3+m) - coordp(m) end do c c tests for all determinants, start with inside set to false c inside = .false. det_pijk = i_p(inf4_2(j,k)) * iorient * sign4_2(j,k) test_pijk = (abs(det_pijk) .gt. epsln2) if (test_pijk .and. det_pijk.gt.0.0d0) then ifail = order1(3,idx) return end if det_pjil = -i_p(inf4_2(j,l)) * iorient * sign4_2(j,l) test_pjil = (abs(det_pjil) .gt. epsln2) if (test_pjil .and. det_pjil.gt.0.0d0) then ifail = order1(2,idx) return end if det_pkjl = iorient * iswap * sign4_3(ie) if (det_pkjl .gt. 0.0d0) then ifail = idx return end if det_pikl = i_p(inf4_2(k,l)) * iorient * sign4_2(k,l) test_pikl = (abs(det_pikl) .gt. epsln2) if (test_pikl .and. det_pikl.gt.0.0d0) then ifail = order1(1,idx) return end if c c either all four determinants are positive, or one of the c determinants is imprecise in which case special care is c needed and the indices will be ranked c if (.not. test_pijk) then call valsort2 (p,i,ia,ib,nswap) call minor2 (crdball,ia,ib,inf4_2(j,k),val) val = -val * sign4_2(j,k) * iorient * nswap if (val .eq. 1) then ifail = order1(3,idx) return end if end if if (.not. test_pjil) then call valsort2 (p,i,ia,ib,nswap) call minor2 (crdball,ia,ib,inf4_2(j,l),val) val = val * sign4_2(j,l) * iorient * nswap if (val .eq. 1) then ifail = order1(2,idx) return end if end if if (.not. test_pikl) then call valsort2 (p,i,ia,ib,nswap) call minor2 (crdball,ia,ib,inf4_2(k,l),val) val = -val * sign4_2(k,l) * iorient * nswap if (val .eq. 1) then ifail = order1(1,idx) return end if end if c c at this point P is inside the tetrahedron, then check c to see whether P is redundant c inside = .true. redundant = .false. if (.not. doweight) return ic1 = inf5_3(ie) sign5 = sign5_3(ie) det_pijkl = -i_p(ic1) if (abs(det_pijkl) .lt. epsln2) then call valsort2 (p,i,ia,ib,nswap) call minor2 (crdball,ia,ib,ic1,val) det_pijkl = val * nswap end if det_pijkl = -det_pijkl * sign5 * iorient * iswap redundant = (det_pijkl .lt. 0.0d0) c c if all four points ia, ib, ic and id are infinite, c then inside must be true and redundant is false c else inside = .true. redundant = .false. end if return end c c c ################################################################# c ## ## c ## subroutine regular_convex -- locally regular link facet ## c ## ## c ################################################################# c c c "regular_convex" checks if a link facet (a,b,c) is locally c regular, as well as if the union of the two tetrahedra ABCP c and ABCO that connect to the facet is convex c c for floating point, points need not be in lexicographic order c prior to computing a determinant; this is not true if the c value is near zero where special care is needed and the points c are ordered using a series of "valsort" routines c c variables and parameters: c c a,b,c three points defining the link facet c p current point inserted in the triangulation c o fourth point of the tetrahedron that attaches c to ABC opposite to the tetrahedron ABCP c itest_abcp orientation of the tetrahedron ABCP c convex set "true" if ABCP U ABCO is convex, else "false" c regular set "true" if ABC is locally regular, in which c case it does not matter if convex c c subroutine regular_convex (a,b,c,p,o,itest_abcp,regular,convex, & test_abpo,test_bcpo,test_capo) use iounit use shapes implicit none integer i,j,k,l,m integer p,a,b,c,o integer ia,ib,ic,id,ie integer ninf,infp,info integer iswap,iswap2,idx,val integer icol1,sign1,icol2,sign2 integer icol4,sign4,icol5,sign5 integer itest_abcp integer list(3) integer sign4_3(4) integer infpoint(4) integer inf4_1(4),sign4_1(4) integer inf5_3(4),sign5_3(4) integer inf4_2(4,4),sign4_2(4,4) integer inf5_2(4,4),sign5_2(4,4) integer order(2,3) integer order1(3,3) real*8 det_abpo,det_bcpo,det_capo real*8 det_abcpo,det_abpc real*8 a_p(4),b_p(4),c_p(4),o_p(0:4) real*8 i_p(0:3),j_p(0:3) real*8 mbo(3),mca(3),mjo(3),mio(0:3) real*8 coordp(3) logical convex,regular logical test_abpo,test_bcpo logical test_capo logical testc(3) data inf4_1 / 2, 2, 1, 1 / data sign4_1 / -1, 1, 1, -1 / data inf4_2 / 0, 2, 3, 3, 2, 0, 3, 3, 3, 3, 0, 1, 3, 3, 1, 0 / data sign4_2 / 0, 1, -1, 1, -1, 0, 1, -1, & 1, -1, 0, 1, -1, 1, -1, 0 / data sign4_3 / -1, 1, -1, 1 / data inf5_2 / 0, 2, 1, 1, 2, 0, 1, 1, 1, 1, 0, 1, 1, 1, 1, 0 / data sign5_2 / 0, -1, -1, 1, 1, 0, -1, 1, & 1, 1, 0, 1, -1, -1, -1, 0 / data inf5_3 / 1, 1, 3, 3 / data sign5_3 / 1, 1, -1, 1 / data order1 / 1, 2, 3, 3, 1, 2, 2, 3, 1 / data order / 2, 3, 3, 1, 1, 2 / save c c c test if the union of the two tetrahedra is convex; check the c position of O with respect to the three faces ABP, BCP and CAP c of ABCP; to do that, we evaluate the three determinants: c det(ABPO), det(BCPO) and det(CAPO) c c if the determinants are positive, and det(ABCP) is negative, c then the union is convex; also, if the three determinants are c negative, and det(ABCP) is positive, then the union is convex; c in all other cases, the union is non convex c c the regularity is tested by computing det(ABCPO) c c count how many infinite points we have, except for O, note c only A, B and C can be infinite points c regular = .true. convex = .true. test_abpo = .false. test_bcpo = .false. test_capo = .false. list(1) = a list(2) = b list(3) = c infpoint(1) = 0 infpoint(2) = 0 infpoint(3) = 0 if (a .le. 4) infpoint(1) = 1 if (b .le. 4) infpoint(2) = 1 if (c .le. 4) infpoint(3) = 1 ninf = infpoint(1) + infpoint(2) + infpoint(3) do m = 1, 3 coordp(m) = crdball(3*p-3+m) end do c c handle the general case with no infinite points; first is c when O is infinite, then det(ABCPO) = -det(ABCP) and thus c ABCPO is regular, so there is nothing to do c if (ninf .eq. 0) then if (o .le. 4) then regular = .true. return end if c c determinants det(ABPO), det(BCPO), and det(CAPO) are "real" c 4x4 determinants; first substract the row corresponding to c P from the other row, and develop with respect to P c c the determinants become: c c det(a,b,p,o) = - | ap(1) ap(2) ap(3) | c | bp(1) bp(2) bp(3) | c | op(1) op(2) op(3) | c c det(b,c,p,o) = - | bp(1) bp(2) bp(3) | c | cp(1) cp(2) cp(3) | c | op(1) op(2) op(3) | c c det(c,a,p,o) = - | cp(1) cp(2) cp(3) | c | ap(1) ap(2) ap(3) | c | op(1) op(2) op(3) | c c where ip(j) = i(j)-p(j) for all i in {a,b,c,o} and j in {1,2,3} c c compute two types of minors: mbo_ij = bp(i)op(j) - bp(j)op(i) c and mca_ij = cp(i)ap(j) - cp(j)op(i), store mbo_12 in mbo(3), c mbo_13 in mbo(2), and so on c do m = 1, 3 a_p(m) = crdball(3*a-3+m) - coordp(m) b_p(m) = crdball(3*b-3+m) - coordp(m) c_p(m) = crdball(3*c-3+m) - coordp(m) o_p(m) = crdball(3*o-3+m) - coordp(m) end do a_p(4) = wghtball(a) - wghtball(p) b_p(4) = wghtball(b) - wghtball(p) c_p(4) = wghtball(c) - wghtball(p) o_p(4) = wghtball(o) - wghtball(p) mbo(1) = b_p(2)*o_p(3) - b_p(3)*o_p(2) mbo(2) = b_p(1)*o_p(3) - b_p(3)*o_p(1) mbo(3) = b_p(1)*o_p(2) - b_p(2)*o_p(1) mca(1) = c_p(2)*a_p(3) - c_p(3)*a_p(2) mca(2) = c_p(1)*a_p(3) - c_p(3)*a_p(1) mca(3) = c_p(1)*a_p(2) - c_p(2)*a_p(1) det_abpo = -a_p(1)*mbo(1) + a_p(2)*mbo(2) - a_p(3)*mbo(3) det_bcpo = c_p(1)*mbo(1) - c_p(2)*mbo(2) + c_p(3)*mbo(3) det_capo = -o_p(1)*mca(1) + o_p(2)*mca(2) - o_p(3)*mca(3) det_abpc = -b_p(1)*mca(1) + b_p(2)*mca(2) - b_p(3)*mca(3) c c now compute det(a,b,c,p,o) = | a(1) a(2) a(3) a(4) 1 | c | b(1) b(2) b(3) b(4) 1 | c | c(1) c(2) c(3) c(4) 1 | c | p(1) p(2) p(3) p(4) 1 | c | o(1) o(2) o(3) o(4) 1 | c c which after substraction of row P gives: c c det(a,b,c,p,o) = - | ap(1) ap(2) ap(3) ap(4) | c | bp(1) bp(2) bp(3) bp(4) | c | cp(1) cp(2) cp(3) cp(4) | c | op(1) op(2) op(3) op(4) | c c then developing with respect to the last column yields: c det_abcpo = -a_p(4)*det_bcpo - b_p(4)*det_capo & - c_p(4)*det_abpo + o_p(4)*det_abpc c c test if (ABCPO) is regular, in which case no flip is needed c if (abs(det_abcpo) .lt. epsln5) then call valsort5 (a,b,c,p,o,ia,ib,ic,id,ie,iswap) call minor5 (crdball,radball,ia,ib,ic,id,ie,val) det_abcpo = val * iswap end if if (det_abcpo*itest_abcp .lt. 0.0d0) then regular = .true. return end if regular = .false. c c if (ABCPO) is not regular, then test for convexity c if (abs(det_abpo) .lt. epsln4) then call valsort4 (a,b,p,o,ia,ib,ic,id,iswap) call minor4 (crdball,ia,ib,ic,id,val) det_abpo = val * iswap end if if (abs(det_bcpo) .lt. epsln4) then call valsort4 (b,c,p,o,ia,ib,ic,id,iswap) call minor4 (crdball,ia,ib,ic,id,val) det_bcpo = val * iswap end if if (abs(det_capo) .lt. epsln4) then call valsort4 (c,a,p,o,ia,ib,ic,id,iswap) call minor4 (crdball,ia,ib,ic,id,val) det_capo = val * iswap end if test_abpo = (det_abpo .gt. 0.0d0) test_bcpo = (det_bcpo .gt. 0.0d0) test_capo = (det_capo .gt. 0.0d0) convex = .false. if (itest_abcp*det_abpo .gt. 0) return if (itest_abcp*det_bcpo .gt. 0) return if (itest_abcp*det_capo .gt. 0) return convex = .true. c c second case where one of A, B or C is infinite; define X c as the infinite point, and (i,j) the pair of finite points c c if X=A then (i,j)=(b,c), or if X=B then (i,j)=(c,a), or c if X=C then (i,j)=(a,b) c c define inf(a)=1 if A is infinite, or 0 otherwise, then c idx_X = 2-inf(a)+inf(c) c else if (ninf .eq. 1) then idx = 2 -infpoint(1) + infpoint(3) infp = list(idx) i = list(order(1,idx)) j = list(order(2,idx)) do m = 1, 3 i_p(m) = crdball(3*i-3+m) - coordp(m) j_p(m) = crdball(3*j-3+m) - coordp(m) o_p(m) = crdball(3*o-3+m) - coordp(m) end do c c handle the case where O is finite c if (o .gt. 4) then icol1 = inf4_1(infp) sign1 = sign4_1(infp) c c the three 4x4 determinants become -det(i,p,o) [X missing], c det(j,p,o) [X missing], and det(i,j,p,o) c c and the 5x5 determinant becomes -det(i,j,p,o) c mjo(1) = j_p(1)*o_p(3) - j_p(3)*o_p(1) mjo(2) = j_p(2)*o_p(3) - j_p(3)*o_p(2) mjo(3) = j_p(1)*o_p(2) - j_p(2)*o_p(1) c c the correspondence between A,B,C and i,j is not essential c here use the correspondence for A infinite; in the two other c cases (B or C infinite), compute the same determinants, but c they are not in the same order c det_abpo = i_p(icol1)*o_p(3) - i_p(3)*o_p(icol1) if (abs(det_abpo) .lt. epsln3) then call valsort3 (i,p,o,ia,ib,ic,iswap) call minor3 (crdball,ia,ib,ic,icol1,3,val) det_abpo = -val * iswap end if det_abpo = det_abpo * sign1 det_capo = -mjo(icol1) if (abs(det_capo) .lt. epsln3) then call valsort3 (j,p,o,ia,ib,ic,iswap) call minor3 (crdball,ia,ib,ic,icol1,3,val) det_capo = val * iswap end if det_capo = det_capo * sign1 det_bcpo = -i_p(1)*mjo(2) + i_p(2)*mjo(1) - i_p(3)*mjo(3) if (abs(det_bcpo) .lt. epsln3) then call valsort4 (i,j,p,o,ia,ib,ic,id,iswap) call minor4 (crdball,ia,ib,ic,id,val) det_bcpo = val * iswap end if det_abcpo = -det_bcpo c c handle the case where O is infinite c c the three 4x4 determinants become -det(i,p) [O,X missing], c det(j,p) [O,X missing], and det(i,j,p) [O missing] c c and the 5x5 determinant becomes det(i,j,p) [O,X missing] c else info = o icol1 = inf4_2(info,infp) sign1 = sign4_2(info,infp) icol2 = inf4_1(info) sign2 = sign4_1(info) icol5 = inf5_2(info,infp) sign5 = sign5_2(info,infp) det_abpo = -i_p(icol1) * sign1 if (abs(det_abpo) .lt. epsln2) then call valsort2 (i,p,ia,ib,iswap) call minor2 (crdball,ia,ib,icol1,val) det_abpo = -val * iswap * sign1 end if det_capo = j_p(icol1) * sign1 if (abs(det_capo) .lt. epsln2) then call valsort2 (j,p,ia,ib,iswap) call minor2 (crdball,ia,ib,icol1,val) det_capo = val * iswap * sign1 end if det_bcpo = i_p(icol2)*j_p(3) - i_p(3)*j_p(icol2) if (abs(det_bcpo) .lt. epsln3) then call valsort3 (i,j,p,ia,ib,ic,iswap) call minor3 (crdball,ia,ib,ic,icol2,3,val) det_bcpo = val * iswap end if det_bcpo = det_bcpo * sign2 det_abcpo = i_p(icol5)*j_p(3) - i_p(3)*j_p(icol5) if (abs(det_abcpo) .lt. epsln3) then call valsort3 (i,j,p,ia,ib,ic,iswap) call minor3 (crdball,ia,ib,ic,icol5,3,val) det_abcpo = val * iswap end if det_abcpo = det_abcpo * sign5 end if c c test if (ABCPO) is regular, in which case no flip is needed c if (det_abcpo*itest_abcp .lt. 0) then regular = .true. return end if regular = .false. c c if (ABCPO) is not regular, then test for convexity c testc(1) = (det_abpo .gt. 0.0d0) testc(2) = (det_bcpo .gt. 0.0d0) testc(3) = (det_capo .gt. 0.0d0) test_abpo = testc(order1(1,idx)) test_bcpo = testc(order1(2,idx)) test_capo = testc(order1(3,idx)) convex = .false. if (itest_abcp*det_abpo .gt. 0) return if (itest_abcp*det_bcpo .gt. 0) return if (itest_abcp*det_capo .gt. 0) return convex = .true. c c third case where two points are infinite; define (k,l) as c the two infinite points, and i the point that is finite c c if i=A then (k,l)=(b,c), or if i=B then (k,l)=(c,a), or c if i=C then (k,l)=(a,b); again i = 2+inf(a)-inf(c) c else if (ninf .eq. 2) then idx = 2 + infpoint(1) - infpoint(3) i = list(idx) k = list(order(1,idx)) l = list(order(2,idx)) do m = 1, 3 i_p(m) = crdball(3*i-3+m) - coordp(m) o_p(m) = crdball(3*o-3+m) - coordp(m) end do c c handle the case where O is finite c c the three 4x4 determinants become det(i,p,o) [k missing], c -det(i,p,o) [l missing], and S*det(p,o) [k,l missing, c with S=1 if k4 flip for triangulation ## c ## ## c ############################################################## c c c "flipjw_1_4" performs a 1->4 flip for regular triangulation c where a 1->4 flip is a transformation in which a tetrahedron c and a single vertex included in the tetrahedron are transformed c to four tetrahedra defined from the four faces of the initial c tetrahedron, connected to the new point, each of the faces is c then called a "linkfacet" and is stored on a queue c c variables and parameters: c c ipoint index of the point P to be included c itetra index of the tetrahedra considered (ABCD) c c subroutine flipjw_1_4 (ipoint,itetra,tetra_last) use shapes implicit none integer i,j,k integer ipoint integer newtetra integer ival,ikeep integer itetra,jtetra integer fact,idx integer tetra_last integer vertex(4) integer nindex(4) integer neighbor(4) integer position(4) integer idx_list(3,4) data idx_list / 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3 / save c c c store information about the old tetrahedron c ikeep = tinfo(itetra) do i = 1, 4 vertex(i) = tetra(i,itetra) neighbor(i) = tneighbor(i,itetra) ival = ibits(tnindex(itetra),2*(i-1),2) nindex(i) = ival + 1 end do fact = -1 if (btest(tinfo(itetra),0)) fact = 1 c c the four new tetrahedra are stored in free space in the c tetrahedron list and at the end of the known tetrahedra list c k = 0 do i = nfree, max(nfree-3,1), -1 k = k + 1 position(k) = freespace(i) end do nfree = max(nfree-4,0) do i = k+1, 4 ntetra = ntetra + 1 position(i) = ntetra end do tetra_last = position(4) c c "itetra" is set to 0, and added to the kill list c tinfo(itetra) = ibclr(tinfo(itetra),1) nkill = 1 killspace(nkill) = itetra c c the tetrahedron is defined as (IJKL), then four new tetrahedra c are created: JKLP, IKLP, IJLP, and IJKP, where P is the new c point to be included c c for each new tetrahedron define all four neighbors, for c each neighbor store the index of the vertex opposite to c the common face in "tnindex" c c for JKLP, the neighbors are IKLP, IJLP, IJKP and neighbor c of IJKL on face JKL c for IKLP, the neighbors are JKLP, IJLP, IJKP and neighbor c of IJKL on face IKL c for IJLP, the neighbors are JKLP, IKLP, IJKP and neighbor c of IJKL on face IJL c for IJKP, the neighbors are JKLP, IKLP, IJLP and neighbor c of IJKL on face IJK c do i = 1, 4 newtetra = position(i) nnew = nnew + 1 newlist(nnew) = newtetra tinfo(newtetra) = 0 tnindex(newtetra) = 0 k = 0 do j = 1, 4 if (j .ne. i) then k = k + 1 tetra(k,newtetra) = vertex(j) tneighbor(k,newtetra) = position(j) ival = idx_list(k,i) - 1 call mvbits (ival,0,2,tnindex(newtetra),2*(k-1)) end if end do jtetra = neighbor(i) idx = nindex(i) tetra(4,newtetra) = ipoint tneighbor(4,newtetra) = jtetra ival = idx - 1 call mvbits (ival,0,2,tnindex(newtetra),6) call mvbits (ikeep,2+i,1,tinfo(newtetra),2+i) if (jtetra.ne.0 .and. idx.ne.0) then tneighbor(idx,jtetra) = newtetra ival = 3 call mvbits (ival,0,2,tnindex(jtetra),2*(idx-1)) end if tinfo(newtetra) = ibset(tinfo(newtetra),1) c c store the tetrahedron orientation, (jklp) and (ijlp) are c clockwise, while (iklp) and (ijkp) are counter-clockwise c fact = -fact if (fact .eq. 1) tinfo(newtetra) = & ibset(tinfo(newtetra),0) end do c c add all four faces of new tetraheda in the linkfacet queue, c each linkfacet is a triangle implicitly defined as intersection c of two tetrahedra c c for facet JKL, tetrahedra are JKLP and neighbor of IJKL on JKL c for facet IKL, tetrahedra are IKLP and neighbor of IJKL on IKL c for facet IJL, tetrahedra are IJLP and neighbor of IJKL on IJL c for facet IJK, tetrahedra are IJKP and neighbor of IJKL on IJK c nlinkfacet = 0 do i = 1, 4 newtetra = position(i) nlinkfacet = nlinkfacet + 1 linkfacet(1,nlinkfacet) = newtetra linkfacet(2,nlinkfacet) = tneighbor(4,newtetra) linkindex(1,nlinkfacet) = 4 ival = ibits(tnindex(newtetra),6,2) linkindex(2,nlinkfacet) = ival + 1 end do return end c c c ################################################################# c ## ## c ## subroutine define_facet -- facet between two tetrahedra ## c ## ## c ################################################################# c c c "define_facet" a triangle or facet is defined by intersection c of two tetrahedra; knowing the position of its three vertices c in the first tetrahedron, find the indices of these vertices c in the second tetrahedron; also stores information about the c neighbors of the two tetrahedra considered c c note the vertices are called A, B, C, P and O, where (ABC) is c the common facet c c variables and parameters: c c itetra index of the tetrahedra (a,b,c,p) considered c jtetra index of the tetrahedra (a,b,c,o) considered c idx_o position of o in the vertices of jtetra c itouch itouch(i) is the tetrahedron sharing c the face opposite to i in tetrahedron itetra c idx idx(i) is the vertex of itouch(i) opposite c to the face shared with itetra c jtouch jtouch(i) is the tetrahedron sharing c the face opposite to i in tetrahedron jtetra c jdx jdx(i) is the vertex of jtouch(i) opposite c to the face shared with jtetra c c subroutine define_facet (itetra,jtetra,idx_o,facei,facej) use shapes implicit none integer i,k,idx_o integer ia,ib,ie,if integer itetra,jtetra integer other(3,4) integer other2(2,4,4) integer facei(3) integer facej(3) data other / 2, 3, 4, 1, 3, 4, 1, 2, 4, 1, 2, 3 / data other2 / 0, 0, 3, 4, 2, 4, 2, 3, 3, 4, 0, 0, & 1, 4, 1, 3, 2, 4, 1, 4, 0, 0, 1, 2, & 2, 3, 1, 3, 1, 2, 0, 0 / save c c c find the three vertices that define the common face and c store in the array triangle, then find vertices P and O c do i = 1, 3 facei(i) = i end do ia = tetra(1,itetra) do i = 1, 3 k = other(i,idx_o) ie = tetra(k,jtetra) if (ia .eq. ie) then facej(1) = k goto 10 end if end do 10 continue ib = tetra(2,itetra) ie = other2(1,facej(1),idx_o) if = other2(2,facej(1),idx_o) if (ib .eq. tetra(ie,jtetra)) then facej(2) = ie facej(3) = if else facej(2) = if facej(3) = ie end if return end c c c ################################################################# c ## ## c ## subroutine find_tetra -- tests for existing tetrahedron ## c ## ## c ################################################################# c c c "find_tetra" tests if four given points form an existing c tetrahedron in the current Delaunay c c variables and parameters: c c itetra index of tetrahedron ABCP c idx_c index of C in tetrahedron ABCP c o index of the vertex O c ifind set to 1 if tetrahedron exists, 0 otherwise c tetra_loc index of existing tetrahedron, if it exists c c first test if tetrahedron ABPO exists, if it exists it is a c neighbor of ABCP, on the face opposite to vertex C, then test c that tetrahedron and see if it contains O c c subroutine find_tetra (itetra,idx_c,a,b,o,ifind, & tetra_loc,idx_a,idx_b) use shapes implicit none integer i,ifind,ival integer itetra,tetra_loc integer ot,otx,otest integer idx_c,idx_a,idx_b integer o,a,b save c c ot = tneighbor(idx_c,itetra) ival = ibits(tnindex(itetra),2*(idx_c-1),2) otx = ival + 1 otest = tetra(otx,ot) c c locate the tetrahedron, then find the position of A and B c if (otest .eq. o) then ifind = 1 tetra_loc = ot do i = 1, 4 if (tetra(i,tetra_loc) .eq. a) then idx_a = i else if (tetra(i,tetra_loc) .eq. b) then idx_b = i end if end do else ifind = 0 end if return end c c c ############################################################## c ## ## c ## subroutine flipjw_2_3 -- 2->3 flip for triangulation ## c ## ## c ############################################################## c c c "flipjw_2_3" implements a 2->3 flip for regular triangulation c c the 2->3 flip is a transformation in which two tetrahedra are c flipped into three tetrahedra. The two tetrahedra ABCP and c ABCO share a triangle ABC which is in the linkfacet of the c current point P added to the triangulation c c this flip is only possible if the union of the two tetrahedra c is convex, and if their shared triangle is not locally regular c c assume that these tests have been performed and satisfied, c once the flip has been performed three tetrahedra are added c and three new link facets are added to the link facet queue c c variables and parameters: c c itetra index of the tetrahedra (a,b,c,p) considered c jtetra index of the tetrahedra (a,b,c,o) considered c vertices the five vertices a,b,c,o,p c facei indices of the vertices a,b,c in (a,b,c,p) c facej indices of the vertices a,b,c in (a,b,c,o) c test_abpo orientation of the four points a,b,p,o c test_bcpo orientation of the four points b,c,p,o c test_capo orientation of the four points c,a,p,o c nlinkfacet three new link facets are added c linkfacet the three faces of the initial tetrahedron c (a,b,c,o) containing the vertex o are added c as link facets c linkindex linkfacet is a triangle defined from its c two neighboring tetrahedra; store the position c of the vertex opposite to the triangle in each c tetrehedron in the array linkindex c ierr set to 1 if flip was not possible c c subroutine flipjw_2_3 (itetra,jtetra,vertices,facei,facej, & test_abpo,test_bcpo,test_capo,ierr, & tetra_last) use shapes implicit none integer i,j,k,o,p integer ierr integer itetra,jtetra integer it,jt,idx,jdx integer ival,ikeep,jkeep integer newtetra integer tetra_last integer jtetra_touch(3) integer itetra_touch(3) integer jtetra_idx(3) integer itetra_idx(3) integer idx_list(2,3) integer face(3),vertices(5) integer facei(3),facej(3) integer tests(3),position(3) logical test_abpo,test_bcpo,test_capo data idx_list / 1, 1, 1, 2, 2, 2 / save c c c if itetra or jtetra are inactive, then cannot flip c ierr = 0 if (.not.btest(tinfo(itetra),1) .or. & .not.btest(tinfo(jtetra),1)) then ierr = 1 return end if c c itetra_touch the three tetrahedra that touches itetra on c the faces opposite to the 3 vertices a,b,c c itetra_idx for the three tetrahedra defined by itetra_touch, c index of the vertex opposite to the face c common with itetra c jtetra_touch the three tetrahedra that touches jtetra on the c faces opposite to the 3 vertices a,b,c c jtetra_idx for the three tetrahedra defined by jtetra_touch, c index of the vertex opposite to the face c common with jtetra c do i = 1, 3 itetra_touch(i) = tneighbor(facei(i),itetra) ival = ibits(tnindex(itetra),2*(facei(i)-1),2) itetra_idx(i) = ival + 1 jtetra_touch(i) = tneighbor(facej(i),jtetra) ival = ibits(tnindex(jtetra),2*(facej(i)-1),2) jtetra_idx(i) = ival + 1 end do c c first three vertices define triangle that is removed c face(1) = vertices(1) face(2) = vertices(2) face(3) = vertices(3) p = vertices(4) o = vertices(5) c c three tetrahedra are stored in free space in the tetrahedron c list and at the end of the list of known tetrahedra if needed c k = 0 do i = nfree, max(nfree-2,1), -1 k = k + 1 position(k) = freespace(i) end do nfree = max(nfree-3,0) do i = k+1, 3 ntetra = ntetra + 1 position(i) = ntetra end do tetra_last = position(3) c c set itetra and jtetra to 0, and add them to kill list c ikeep = tinfo(itetra) jkeep = tinfo(jtetra) tinfo(itetra) = ibclr(tinfo(itetra),1) tinfo(jtetra) = ibclr(tinfo(jtetra),1) killspace(nkill+1) = itetra killspace(nkill+2) = jtetra nkill = nkill + 2 c c the vertices A, B and C are the first vertices of itetra, c and the other two vertices P and O c for each vertex in the triangle, define the opposing faces c in the two tetrahedra itetra and jtetra, and tetrahedra c that share faces with itetra and jtetra, respectively, c this information is stored in itetra_touch and jtetra_touch c c for bookkeeping reasons, always store P as the last vertex c c define the three new tetrahedra BCOP, ACOP and ABOP as well c as their neighbors c c for BCOP, the neighbors are ACOP, ABOP, neighbor of ABCP on c on face BCP, and neighbor of ABCO on face BCO c for ACOP, the neighbors are BCOP, ABOP, neighbor of ABCP on c on face ACP, and neighbor of ABCO on face ACO c for ABOP, the neighbors are BCOP, ACOP, neighbor of ABCP on c on face ABP, and neighbor of ABCO on face ABO c tests(1) = 1 if (test_bcpo) tests(1) = -1 tests(2) = -1 if (test_capo) tests(2) = 1 tests(3) = 1 if (test_abpo) tests(3) = -1 do i = 1, 3 newtetra = position(i) nnew = nnew + 1 newlist(nnew) = newtetra tinfo(newtetra) = 0 tnindex(newtetra) = 0 k = 0 do j = 1, 3 if (j .ne. i) then k = k + 1 tetra(k,newtetra) = face(j) tneighbor(k,newtetra) = position(j) ival = idx_list(k,i) - 1 call mvbits (ival,0,2,tnindex(newtetra),2*(k-1)) end if end do tetra(3,newtetra) = o it = itetra_touch(i) idx = itetra_idx(i) tneighbor(3,newtetra) = it ival = idx - 1 call mvbits (ival,0,2,tnindex(newtetra),4) call mvbits (ikeep,2+facei(i),1,tinfo(newtetra),5) if (idx.ne.0 .and. it.ne.0) then tneighbor(idx,it) = newtetra ival = 2 call mvbits (ival,0,2,tnindex(it),2*(idx-1)) end if tetra(4,newtetra) = p jt = jtetra_touch(i) jdx = jtetra_idx(i) tneighbor(4,newtetra) = jt ival = jdx - 1 call mvbits (ival,0,2,tnindex(newtetra),6) call mvbits (jkeep,2+facej(i),1,tinfo(newtetra),6) if (jdx.ne.0 .and. jt.ne.0) then tneighbor(jdx,jt) = newtetra ival = 3 call mvbits (ival,0,2,tnindex(jt),2*(jdx-1)) end if tinfo(newtetra) = ibset(tinfo(newtetra),1) if (tests(i) .eq. 1) then tinfo(newtetra) = ibset(tinfo(newtetra),0) end if end do c c add all three faces of jtetra containing O in the linkfacet c queue, each linkfacet is a triangle implicitly defined as the c intersection of two tetrahedra c c for facet BCO, tetrahedra are BCOP and neighbor of ABCO on BCO c for facet ACO, tetrahedra are ACOP and neighbor of ABCO on ACO c for facet ABO, tetrahedra are ABOP and neighbor of ABCO on ABO c do i = 1, 3 newtetra = position(i) nlinkfacet = nlinkfacet + 1 linkfacet(1,nlinkfacet) = newtetra linkfacet(2,nlinkfacet) = tneighbor(4,newtetra) linkindex(1,nlinkfacet) = 4 ival = ibits(tnindex(newtetra),6,2) linkindex(2,nlinkfacet) = ival + 1 end do return end c c c ############################################################## c ## ## c ## subroutine flipjw_3_2 -- 3->2 flip for triangulation ## c ## ## c ############################################################## c c c "flipjw_3_2" implements a 3->2 flip for regular triangulation c c the 3->2 flip is a transformation in which three tetrahedra are c flipped into two tetrahedra, the three tetrahedra ABPO, ABCP and c ABCO share an edge AB which is in the linkfacet of the current c point P added to the triangulation c c this flip is only possible if the edge AB is reflex, with degree c three, assume these tests have been performed and satisfied, c once the flip has been performed, two new tetrahedra are added c and two new "link facet" are added to the link facet queue c c variables and parameters: c c itetra index of the tetrahedron ABCP considered c jtetra index of the tetrahedron ABCO considered c ktetra index of the tetrahedron ABOP considered c vertices the five vertices A, B, C, P and O c edgei indices of AB in ABCP c edgej indices of AB in ABCO c edgek indices of AB in ABOP c test_bcpo orientation of the four points BCPO c test_acpo orientation of the four points ACPO c nlinkfacet two new link facets are added c linkfacet the two faces of the initial tetrahedron c ABOP containing the edge op are added c as link facets c linkindex linkfacet is a triangle defined from its two c neighboring tetrahedra, store the position c of the vertex opposite to the triangle in each c tetrehedron in the array linkindex c ierr set to 1 if flip was not possible c c subroutine flipjw_3_2 (itetra,jtetra,ktetra,vertices,edgei, & edgej,edgek,test_bcpo,test_acpo,ierr, & tetra_last) use shapes implicit none integer i,j,k,c,o,p integer ierr,ival integer ikeep,jkeep,kkeep integer itetra,jtetra,ktetra integer it,jt,kt,idx,jdx,kdx integer newtetra integer tetra_last integer edge(2),tests(2) integer vertices(5) integer itetra_touch(2) integer jtetra_touch(2) integer ktetra_touch(2) integer itetra_idx(2) integer jtetra_idx(2) integer ktetra_idx(2) integer position(2) integer edgei(2),edgej(2) integer edgek(2) logical test_bcpo,test_acpo save c c tests(1) = 1 if (test_bcpo) tests(1) = -1 tests(2) = 1 if (test_acpo) tests(2) = -1 ierr = 0 c c if itetra, jtetra or ktetra are inactive, cannot flip c if (.not.btest(tinfo(itetra),1) .or. & .not.btest(tinfo(jtetra),1) .or. & .not.btest(tinfo(ktetra),1)) then ierr = 1 return end if c c store the old information c ikeep = tinfo(itetra) jkeep = tinfo(jtetra) kkeep = tinfo(ktetra) c c itetra_touch indices of the two tetrahedra that share the c faces opposite to A and B in itetra c itetra_idx for the two tetrahedra defined by itetra_touch, c index position of vertex opposite the face c common with itetra c jtetra_touch indices of the two tetrahedra that share the c faces opposite to a and b in jtetra c jtetra_idx for the two tetrahedra defined by jtetra_touch, c index position of vertex opposite the face c common with jtetra c ktetra_touch indices of the two tetrahedra that share the c faces opposite to a and b in ktetra c ktetra_idx for the two tetrahedra defined by ktetra_touch, c index position of vertex opposite the face c common with ktetra c do i = 1, 2 itetra_touch(i) = tneighbor(edgei(i),itetra) jtetra_touch(i) = tneighbor(edgej(i),jtetra) ktetra_touch(i) = tneighbor(edgek(i),ktetra) ival = ibits(tnindex(itetra),2*(edgei(i)-1),2) itetra_idx(i) = ival + 1 ival = ibits(tnindex(jtetra),2*(edgej(i)-1),2) jtetra_idx(i) = ival + 1 ival = ibits(tnindex(ktetra),2*(edgek(i)-1),2) ktetra_idx(i) = ival + 1 end do edge(1) = vertices(1) edge(2) = vertices(2) c = vertices(3) p = vertices(4) o = vertices(5) c c store the new tetrahedra in "free" space or at the list end c k = 0 do i = nfree, max(nfree-1,1), -1 k = k + 1 position(k) = freespace(i) end do nfree = max(nfree-2,0) do i = k+1, 2 ntetra = ntetra + 1 position(i) = ntetra end do tetra_last = position(2) c c itetra, jtetra and ktetra become available and are added c to the kill list c tinfo(itetra) = ibclr(tinfo(itetra),1) tinfo(jtetra) = ibclr(tinfo(jtetra),1) tinfo(ktetra) = ibclr(tinfo(ktetra),1) killspace(nkill+1) = itetra killspace(nkill+2) = jtetra killspace(nkill+3) = ktetra nkill = nkill + 3 c c the two vertices that define their common edge AB are c stored in the array edge c the vertices C, P and O form the new triangle c for each vertex in the edge AB, define the opposing faces c in the tetrahedra itetra, jtetra and ktetra, and the c tetrahedron that share these faces with itetra, jtetra c and ktetra, respectively c this info is stored in itetra_touch, jtetra_touch and c ktetra_touch c c always set P to be the last vertex of the new tetrahedra c c define new tetrahedra BCOP and ACOP as well as their neighbors c c for BCOP, the neighbors are ACOP, neighbor of ABOP on face c BPO, neighbor of ABCP on face BCP, and neighbor of ABCO c on face BCO c for ACOP, the neighbors are BCOP, neighbor of ABOP on face c APO, neighbor of ABCP on face ACP, and neighbor of ABCO c on face ACO c do i = 1, 2 newtetra = position(i) nnew = nnew + 1 newlist(nnew) = newtetra tinfo(newtetra) = 0 tnindex(newtetra) = 0 k = 0 do j = 1, 2 if (j .ne. i) then k = k + 1 tetra(k,newtetra) = edge(j) tneighbor(k,newtetra) = position(j) end if end do tetra(2,newtetra) = c kt = ktetra_touch(i) kdx = ktetra_idx(i) tneighbor(2,newtetra) = kt ival = kdx - 1 call mvbits (ival,0,2,tnindex(newtetra),2) call mvbits (kkeep,2+edgek(i),1,tinfo(newtetra),4) if (kdx.ne.0 .and. kt.ne.0) then tneighbor(kdx,kt) = newtetra ival = 1 call mvbits (ival,0,2,tnindex(kt),2*(kdx-1)) end if tetra(3,newtetra) = o it = itetra_touch(i) idx = itetra_idx(i) tneighbor(3,newtetra) = it ival = idx - 1 call mvbits (ival,0,2,tnindex(newtetra),4) call mvbits (ikeep,2+edgei(i),1,tinfo(newtetra),5) if (idx.ne.0 .and. it.ne.0) then tneighbor(idx,it) = newtetra ival = 2 call mvbits (ival,0,2,tnindex(it),2*(idx-1)) end if tetra(4,newtetra) = p jt = jtetra_touch(i) jdx = jtetra_idx(i) tneighbor(4,newtetra) = jt ival = jdx - 1 call mvbits (ival,0,2,tnindex(newtetra),6) call mvbits (jkeep,2+edgej(i),1,tinfo(newtetra),6) if (jdx.ne.0 .and. jt.ne.0) then tneighbor(jdx,jt) = newtetra ival = 3 call mvbits (ival,0,2,tnindex(jt),2*(jdx-1)) end if tinfo(newtetra) = ibset(tinfo(newtetra),1) if (tests(i) .eq. 1) then tinfo(newtetra) = ibset(tinfo(newtetra),0) end if end do c c add the two faces of ktetra containing CO in the linkfacet c queue, each linkfacet is a triangle implicitly defined as the c intersection of two tetrahedra c c for facet BCO, tetrahedra are BCOP and neighbor of ABCO on BCO c for facet ACO, tetrahedra are ACOP and neighbor of ABCO on ACO c do i = 1, 2 newtetra = position(i) nlinkfacet = nlinkfacet + 1 linkfacet(1,nlinkfacet) = newtetra linkfacet(2,nlinkfacet) = tneighbor(4,newtetra) linkindex(1,nlinkfacet) = 4 ival = ibits(tnindex(newtetra),6,2) + 1 linkindex(2,nlinkfacet) = ival end do return end c c c ############################################################## c ## ## c ## subroutine flipjw_4_1 -- 4->1 flip for triangulation ## c ## ## c ############################################################## c c c "flipjw_4_1" implements a 4->1 flip for regular triangulation c c the 4->1 flip is a transformation where four tetrahedra are c flipped into one tetrahedron; the four tetrahedra ABOP, BCOP, c ABCP and ABO share a vertex B which is in the linkfacet of c the current point P added to the triangulation, after the c flip, B is set to redundant c c this flip is only possible if the two edges AB and BC are c reflex of order 3 c c assume that these tests have been performed and satisfied, c once the flip has been performed one tetrahedron is added c and one new link facet is added to the link facet queue c c variables and parameters: c c itetra index of the tetrahedra ABCP considered c jtetra index of the tetrahedra ABCO considered c ktetra index of the tetrahedra ABOP considered c ltetra index of the tetrahedra BCOP considered c vertices index of A, B, C, P, O c idp index of B in ABCP c jdp index of B in ABCO c kdp index of B in ABOP c ldp index of B in BCOP c test_acpo orientation of the four points A, C, P and O c linkfacet face of the initial tetrahedron ABCO opposite c to the vertex b is added as link facet c linkindex linkfacet is a triangle defined from its two c neighboring tetrahedra, store the position c of the vertex opposite to the triangle in c each tetrehedron in the array "linkindex" c ierr set to 1 if flip was not possible c c subroutine flipjw_4_1 (itetra,jtetra,ktetra,ltetra,vertices,idp, & jdp,kdp,ldp,test_acpo,ierr,tetra_last) use shapes implicit none integer a,b,c,o,p integer ierr,ival integer ikeep,jkeep integer kkeep,lkeep integer itetra,jtetra integer ktetra,ltetra integer ishare,jshare integer kshare,lshare integer idx,jdx,kdx,ldx integer idp,jdp,kdp,ldp integer test1,newtetra integer tetra_last integer vertices(5) logical test_acpo save c c ierr = 0 test1 = 1 if (test_acpo) test1 = -1 c c if itetra, jtetra, ktetra, ltetra are inactive, cannot flip c if (.not.btest(tinfo(itetra),1) .or. & .not.btest(tinfo(jtetra),1) .or. & .not.btest(tinfo(ktetra),1) .or. & .not.btest(tinfo(ltetra),1)) then ierr = 1 return end if c c store the "old" info c ikeep = tinfo(itetra) jkeep = tinfo(jtetra) kkeep = tinfo(ktetra) lkeep = tinfo(ltetra) c c ishare index of tetrahedron sharing the face c opposite to b in itetra c idx index of the vertex of ishare opposite to the c face of ishare shared with itetra c jshare index of tetrahedron sharing the face c opposite to b in jtetra c jdx index of the vertex of jshare opposite to the c face of jshare shared with jtetra c kshare index of tetrahedron sharing the face c opposite to b in ktetra c kdx index of the vertex of kshare opposite to the c face of kshare shared with ktetra c lshare index of tetrahedron sharing the face c opposite to b in ltetra c ldx index of the vertex of lshare opposite to the c face of lshare shared with ltetra c ishare = tneighbor(idp,itetra) jshare = tneighbor(jdp,jtetra) kshare = tneighbor(kdp,ktetra) lshare = tneighbor(ldp,ltetra) ival = ibits(tnindex(itetra),2*(idp-1),2) idx = ival + 1 ival = ibits(tnindex(jtetra),2*(jdp-1),2) jdx = ival + 1 ival = ibits(tnindex(ktetra),2*(kdp-1),2) kdx = ival + 1 ival = ibits(tnindex(ltetra),2*(ldp-1),2) ldx = ival + 1 c c store the new tetrahedron in place of itetra c if (nfree .ne. 0) then newtetra = freespace(nfree) nfree = nfree - 1 else ntetra = ntetra + 1 newtetra = ntetra end if tetra_last = newtetra nnew = nnew + 1 newlist(nnew) = newtetra tinfo(newtetra) = 0 tnindex(newtetra) = 0 c c jtetra, ktetra and ltetra become "available", so they c are added to the "kill" zone c killspace(nkill+1) = itetra killspace(nkill+2) = jtetra killspace(nkill+3) = ktetra killspace(nkill+4) = ltetra nkill = nkill + 4 tinfo(itetra) = ibclr(tinfo(itetra),1) tinfo(jtetra) = ibclr(tinfo(jtetra),1) tinfo(ktetra) = ibclr(tinfo(ktetra),1) tinfo(ltetra) = ibclr(tinfo(ltetra),1) c c the vertex B that is shared by all four tetrahedra, the other c vertices are A, C, P and O; for each tetrahedron, find neighbor c attached to the face oposite to B c a = vertices(1) b = vertices(2) c = vertices(3) p = vertices(4) o = vertices(5) c c note P is set to be the last vertex of the new tetrahedron, c define the new tetrahedron, ACOP c vinfo(b) = ibclr(vinfo(b),0) tetra(1,newtetra) = a tneighbor(1,newtetra) = lshare ival = ldx - 1 call mvbits (ival,0,2,tnindex(newtetra),0) call mvbits (lkeep,2+ldp,1,tinfo(newtetra),3) if (lshare.ne.0 .and. ldx.ne.0) then tneighbor(ldx,lshare) = newtetra ival = 0 call mvbits (ival,0,2,tnindex(lshare),2*(ldx-1)) end if tetra(2,newtetra) = c tneighbor(2,newtetra) = kshare ival = kdx - 1 call mvbits (ival,0,2,tnindex(newtetra),2) call mvbits (kkeep,2+kdp,1,tinfo(newtetra),4) if (kshare.ne.0 .and. kdx.ne.0) then tneighbor(kdx,kshare) = newtetra ival = 1 call mvbits (ival,0,2,tnindex(kshare),2*(kdx-1)) end if tetra(3,newtetra) = o tneighbor(3,newtetra) = ishare ival = idx - 1 call mvbits (ival,0,2,tnindex(newtetra),4) call mvbits (ikeep,2+idp,1,tinfo(newtetra),5) if (ishare.ne.0 .and. idx.ne.0) then tneighbor(idx,ishare) = newtetra ival = 2 call mvbits (ival,0,2,tnindex(ishare),2*(idx-1)) end if tetra(4,newtetra) = p tneighbor(4,newtetra) = jshare ival = jdx - 1 call mvbits (ival,0,2,tnindex(newtetra),6) call mvbits (jkeep,2+jdp,1,tinfo(newtetra),6) if (jshare.ne.0 .and. jdx.ne.0) then tneighbor(jdx,jshare) = newtetra ival = 3 call mvbits (ival,0,2,tnindex(jshare),2*(jdx-1)) end if tinfo(newtetra) = ibset(tinfo(newtetra),1) if (test1 .eq. 1) then tinfo(newtetra) = ibset(tinfo(newtetra),0) end if c c for facet ACO, tetrahedra are ACOP and neighbor of ABCO on ACO c nlinkfacet = nlinkfacet + 1 linkfacet(1,nlinkfacet) = newtetra linkfacet(2,nlinkfacet) = jshare linkindex(1,nlinkfacet) = 4 linkindex(2,nlinkfacet) = jdx return end c c c ############################################################## c ## ## c ## subroutine remove_inf -- sets status of tetrahedron ## c ## ## c ############################################################## c c c "remove_inf" sets the status to zero for tetrahedra that c contain infinite points c c subroutine remove_inf use shapes implicit none integer i,a,b,c,d save c c do i = 1, ntetra if (btest(tinfo(i),1)) then a = tetra(1,i) b = tetra(2,i) c = tetra(3,i) d = tetra(4,i) if (a.le.4 .or. b.le.4 .or. c.le.4 .or. d.le.4) then tinfo(i) = ibset(tinfo(i),2) tinfo(i) = ibclr(tinfo(i),1) if (a .le. 4) call mark_zero (i,1) if (b .le. 4) call mark_zero (i,2) if (c .le. 4) call mark_zero (i,3) if (d .le. 4) call mark_zero (i,4) end if end if end do do i = 1, 4 vinfo(i) = ibclr(vinfo(i),0) end do return end c c c ############################################################## c ## ## c ## subroutine mark_zero -- marks a touching tetrahedron ## c ## ## c ############################################################## c c c "mark_zero" marks the tetrahedron that touches a tetrahedron c with infinite point as part of the convex hull (i.e., one of c its neighbors is zero) c c subroutine mark_zero (itetra,ivertex) use shapes implicit none integer ival integer itetra,ivertex integer jtetra,jvertex save c c jtetra = tneighbor(ivertex,itetra) if (jtetra .ne. 0) then ival = ibits(tnindex(itetra),2*(ivertex-1),2) jvertex = ival + 1 tneighbor(jvertex,jtetra) = 0 end if return end c c c ################################################################ c ## ## c ## subroutine peel -- removes flat tetrahedra at boundary ## c ## ## c ################################################################ c c c "peel" removes the flat tetrahedra at the boundary of the DT c c subroutine peel (ntry) use shapes implicit none integer i,j,k,m integer ia,ib,ic,id,val integer ntry,ival real*8 vol save c c c loop over all tetrahedra, and test the tetrahedra at c the boundary c ntry = 0 do i = 1, ntetra if (btest(tinfo(i),1)) then do j = 1, 4 if (tneighbor(j,i) .eq. 0) goto 10 end do c c the tetrahedron idx is interior, and cannot be flat c goto 20 10 continue c c the tetrahedron is at the boundary; test if it is flat, c i.e., if its volume is 0 c ia = tetra(1,i) ib = tetra(2,i) ic = tetra(3,i) id = tetra(4,i) call tetra_vol (crdball,ia,ib,ic,id,vol) if (abs(vol) .lt. epsln4) then call minor4x (crdball,ia,ib,ic,id,val) if (val .eq. 0) then tinfo(i) = ibset(tinfo(i),2) ntry = ntry + 1 end if end if 20 continue end if end do c c remove flat tetrahedra and update links to their neighbors c do i = 1, ntetra if (btest(tinfo(i),2)) then if (btest(tinfo(i),1)) then tinfo(i) = ibclr(tinfo(i),1) do j = 1, 4 k = tneighbor(j,i) if (k .ne. 0) then ival = ibits(tnindex(i),2*(j-1),2) m = ival + 1 tneighbor(m,k) = 0 end if end do end if end if end do return end c c c ################################################################ c ## ## c ## subroutine tetra_vol -- find the volume of tetrahedron ## c ## ## c ################################################################ c c c "tetra_vol" computes the volume of a tetrahedron c c variables and parameters: c c coord array containing coordinates of all vertices c ia,ib,ic,id four vertices defining the tetrahedron c vol volume of the tetrahedron via floating point c c subroutine tetra_vol (crdball,ia,ib,ic,id,vol) implicit none integer i integer ia,ib,ic,id real*8 vol real*8 ad(3),bd(3),cd(3) real*8 sbcd(3) real*8 crdball(*) save c c volume of the tetrahedron is proportional to: c c vol = det | a(1) a(2) a(3) 1 | c | b(1) b(2) b(3) 1 | c | c(1) c(2) c(3) 1 | c | d(1) d(2) d(3) 1 | c c after substracting the last row from the first 3 rows, and c developping with respect to the last column, we obtain: c c vol = det | ad(1) ad(2) ad(3) | c | bd(1) bd(2) bd(3) | c | cd(1) cd(2) cd(3) | c c where ad(i) = a(i) - d(i), etc. c do i = 1, 3 ad(i) = crdball(3*(ia-1)+i) - crdball(3*(id-1)+i) bd(i) = crdball(3*(ib-1)+i) - crdball(3*(id-1)+i) cd(i) = crdball(3*(ic-1)+i) - crdball(3*(id-1)+i) end do sbcd(3) = bd(1)*cd(2) - cd(1)*bd(2) sbcd(2) = bd(1)*cd(3) - cd(1)*bd(3) sbcd(1) = bd(2)*cd(3) - cd(2)*bd(3) vol = ad(1)*sbcd(1) - ad(2)*sbcd(2) + ad(3)*sbcd(3) if (vol < 0.0d0) vol = 0.0d0 return end c c c ################################################################ c ## ## c ## subroutine sort4_sign -- sort integers and permutation ## c ## ## c ################################################################ c c c "sort4_sign" sorts a list of four numbers, and computes the c signature of the permutation c c subroutine sort4_sign (list,index,nswap,n) integer i,j,k integer n,nswap integer list(*) integer index(*) save c c do i = 1, n index(i) = i end do nswap = 1 do i = 1, n-1 do j = i+1, n if (list(i) .gt. list(j)) then k = list(i) list(i) = list(j) list(j) = k k = index(i) index(i) = index(j) index(j) = k nswap = -nswap end if end do end do return end c c c ################################################################## c ## ## c ## subroutine reorder_tetra -- reorder tetrahedron vertices ## c ## ## c ################################################################## c c c "reorder_tetra" reorders the vertices of a list of tetrahedra c such that the indices are in increasing order c c if iflag is set to 1, all tetrahedra are reordered c if iflag is set to 0, only new tetrahedra are reordered, c and stored in list_tetra c c subroutine reorder_tetra (iflag,new,list_tetra) use shapes implicit none integer i,j,idx,ival integer iflag,new integer ntot,nswap integer index(4) integer vertex(4) integer neighbor(4) integer nsurf(4) integer nindex(4) integer list_tetra(*) save c c if (iflag .eq. 1) then ntot = ntetra else ntot = new end if do idx = 1, ntot if (iflag .eq. 1) then i = idx else i = list_tetra(idx) end if if (btest(tinfo(i),1)) then do j = 1, 4 vertex(j) = tetra(j,i) end do call sort4_sign (vertex,index,nswap,4) do j = 1, 4 neighbor(j) = tneighbor(index(j),i) nindex(j) = ibits(tnindex(i),2*(index(j)-1),2) nsurf(j) = ibits(tinfo(i),2+index(j),1) if (neighbor(j) .ne. 0) then ival = j - 1 call mvbits (ival,0,2,tnindex(neighbor(j)), & 2*nindex(j)) end if end do do j = 1, 4 tetra(j,i) = vertex(j) tneighbor(j,i) = neighbor(j) call mvbits (nindex(j),0,2,tnindex(i),2*(j-1)) call mvbits (nsurf(j),0,1,tinfo(i),2+j) end do if (nswap .eq. -1) then if (btest(tinfo(i),0)) then tinfo(i) = ibclr(tinfo(i),0) else tinfo(i) = ibset(tinfo(i),0) end if end if end if end do return end c c c ############################################################## c ## ## c ## subroutine find_edges -- list edges not fully buried ## c ## ## c ############################################################## c c c "find_edges" builds a list of edges that are not fully buried, c returns the total number of edges and definition of the edges c c subroutine find_edges (nedge,edges) use shapes implicit none integer i,j,idx integer ia,ib,ic,id integer i1,i2,i3,i4 integer nedge,iedge integer ival,edge_b integer trig1,trig2,trig_in integer trig_out,triga,trigb integer jtetra,ktetra,npass integer ipair,i_out integer face_info(2,6) integer face_pos(2,6) integer pair(2,6) integer edges(2,*) integer, allocatable :: tmask(:) data face_info / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 / data face_pos / 2, 1, 3, 1, 4, 1, 3, 2, 4, 2, 4, 3 / data pair / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 / save c c c perform dynamic allocation of some local arrays c allocate (tmask(ntetra)) c c find list of all edges in the alpha complex c do i = 1, ntetra tmask(i) = 0 end do c c loop over tetrahedra, if belong to the Delaunay triangulation, c check the edges and include in edge list if not seen before c c nedge = 0 do idx = 1, ntetra if (btest(tinfo(idx),1)) then ia = tetra(1,idx) ib = tetra(2,idx) ic = tetra(3,idx) id = tetra(4,idx) c c check all six edges c do iedge = 1, 6 c c if this edge has already been considered, from another c tetrahedron, then discard c if (btest(tmask(idx),iedge-1)) goto 40 c c if this edge is not in the alpha complex, then discard c if (.not. btest(tedge(idx),iedge-1)) goto 40 c c note iedge is the edge number in the tetrahedron idx, with: c iedge = 1 (c,d); iedge = 2 (b,d); iedge = 3 (b,c) c iedge = 4 (a,d); iedge = 5 (a,c); iedge = 6 (a,b) c c define indices of the edge c i = tetra(pair(1,iedge),idx) j = tetra(pair(2,iedge),idx) c c set edge as buried c edge_b = 1 if (.not. btest(tinfo(idx),7)) edge_b = 0 c c trig1 and trig2 are the two faces of idx that share iedge c i1 and i2 are positions of the third vertices of trig1 and trig2 c trig1 = face_info(1,iedge) i1 = face_pos(1,iedge) trig2 = face_info(2,iedge) i2 = face_pos(2,iedge) i3 = tetra(i1,idx) i4 = tetra(i2,idx) c c now we look at the star of the edge c ktetra = idx npass = 1 trig_out = trig1 jtetra = tneighbor(trig_out,ktetra) 10 continue c c leave this side of the star if we hit the convex hull c in this case, the edge is not buried c if (jtetra .eq. 0) then edge_b = 0 goto 20 end if c c leave the loop completely if we have described the full cycle c if (jtetra .eq. idx) goto 30 c c identify the position of iedge in tetrahedron jtetra c if (i .eq. tetra(1,jtetra)) then if (j .eq. tetra(2,jtetra)) then ipair = 6 else if (j .eq. tetra(3,jtetra)) then ipair = 5 else ipair = 4 end if else if (i .eq. tetra(2,jtetra)) then if (j .eq. tetra(3,jtetra)) then ipair = 3 else ipair = 2 end if else ipair = 1 end if tmask(jtetra) = ibset(tmask(jtetra),ipair-1) if (.not. btest(tinfo(jtetra),7)) edge_b = 0 c c find out the face we "went in" c ival = ibits(tnindex(ktetra),2*(trig_out-1),2) trig_in = ival + 1 c c we know the two faces of jtetra that share iedge c triga = face_info(1,ipair) i1 = face_pos(1,ipair) trigb = face_info(2,ipair) i2 = face_pos(2,ipair) trig_out = triga i_out = i1 if (trig_in .eq. triga) then i_out = i2 trig_out = trigb end if ktetra = jtetra jtetra = tneighbor(trig_out,ktetra) if (jtetra .eq. idx) goto 30 goto 10 20 continue if (npass .eq. 2) goto 30 npass = npass + 1 ktetra = idx trig_out = trig2 jtetra = tneighbor(trig_out,ktetra) goto 10 30 continue if (edge_b .eq. 0) then nedge = nedge + 1 edges(1,nedge) = i edges(2,nedge) = j end if 40 continue end do end if end do c c sort the list of all edges into increasing order c call hpsort_two_int (edges,nedge) c c perform deallocation of some local arrays c deallocate (tmask) return end c c c ################################################################## c ## ## c ## subroutine find_all_edges -- construct list of all edges ## c ## ## c ################################################################## c c c "find_all_edges" builds a list of all edges in the alpha complex, c returns the total number of edges and definition of the edges c c subroutine find_all_edges (nedge,edges) use shapes implicit none integer i,j,idx integer ia,ib,ic,id integer i1,i2,i3,i4 integer nedge,iedge,ival integer trig1,trig2,trig_in integer trig_out,triga,trigb integer jtetra,ktetra,npass integer ipair,i_out integer face_info(2,6) integer face_pos(2,6) integer pair(2,6) integer edges(2,*) integer, allocatable :: tmask(:) data face_info / 1, 2, 1, 3, 1, 4, 2, 3, 2, 4, 3, 4 / data face_pos / 2, 1, 3, 1, 4, 1, 3, 2, 4, 2, 4, 3 / data pair / 3, 4, 2, 4, 2, 3, 1, 4, 1, 3, 1, 2 / save c c c perform dynamic allocation of some local arrays c allocate (tmask(ntetra)) c c find list of all edges in the alpha complex c do i = 1, ntetra tmask(i) = 0 end do c c loop over tetrahedra, if belong to the Delaunay triangulation, c check the edges and include in edge list if not seen before c c nedge = 0 do idx = 1, ntetra if (btest(tinfo(idx),1)) then ia = tetra(1,idx) ib = tetra(2,idx) ic = tetra(3,idx) id = tetra(4,idx) c c check all six edges c do iedge = 1, 6 c c if this edge has already been considered, from another c tetrahedron, then discard c if (btest(tmask(idx),iedge-1)) goto 30 c c if this edge is not in the alpha complex, then discard c if (.not. btest(tedge(idx),iedge-1)) goto 30 c c note iedge is the edge number in the tetrahedron idx, with: c iedge = 1 (c,d); iedge = 2 (b,d); iedge = 3 (b,c) c iedge = 4 (a,d); iedge = 5 (a,c); iedge = 6 (a,b) c c define indices of the edge c i = tetra(pair(1,iedge),idx) j = tetra(pair(2,iedge),idx) c c set edge as buried c nedge = nedge + 1 edges(1,nedge) = i edges(2,nedge) = j c c trig1 and trig2 are the two faces of idx that share iedge c i1 and i2 are positions of the third vertices of trig1 and trig2 c trig1 = face_info(1,iedge) i1 = face_pos(1,iedge) trig2 = face_info(2,iedge) i2 = face_pos(2,iedge) i3 = tetra(i1,idx) i4 = tetra(i2,idx) c c now we look at the star of the edge c ktetra = idx npass = 1 trig_out = trig1 jtetra = tneighbor(trig_out,ktetra) 10 continue c c leave this side of the star if we hit the convex hull c in this case, the edge is not buried c if (jtetra .eq. 0) goto 20 c c leave the loop completely if we have described the full cycle c if (jtetra .eq. idx) goto 30 c c identify the position of iedge in tetrahedron jtetra c if (i .eq. tetra(1,jtetra)) then if (j .eq. tetra(2,jtetra)) then ipair = 6 else if (j .eq. tetra(3,jtetra)) then ipair = 5 else ipair = 4 end if else if (i .eq. tetra(2,jtetra)) then if (j .eq. tetra(3,jtetra)) then ipair = 3 else ipair = 2 end if else ipair = 1 end if tmask(jtetra) = ibset(tmask(jtetra),ipair-1) c c find out the face we "went in" c ival = ibits(tnindex(ktetra),2*(trig_out-1),2) trig_in = ival + 1 c c we know the two faces of jtetra that share iedge c triga = face_info(1,ipair) i1 = face_pos(1,ipair) trigb = face_info(2,ipair) i2 = face_pos(2,ipair) trig_out = triga i_out = i1 if (trig_in .eq. triga) then i_out = i2 trig_out = trigb end if ktetra = jtetra jtetra = tneighbor(trig_out,ktetra) if (jtetra .eq. idx) goto 30 goto 10 20 continue if (npass .eq. 2) goto 30 npass = npass + 1 ktetra = idx trig_out = trig2 jtetra = tneighbor(trig_out,ktetra) goto 10 30 continue end do end if end do c c sort list of all edges in increasing order c call hpsort_two_int (edges,nedge) c c perform deallocation of some local arrays c deallocate (tmask) return end c c c ################################################################# c ## ## c ## subroutine get_coords2 -- extracts and stores two atoms ## c ## ## c ################################################################# c c c "get_coord2" extracts two atoms from the global array containing c all atoms, centers them on (0,0,0), recomputes their weights c and stores them in local arrays c c variables and parameters: c c ia,ja indices of the four points considered c a,b centered coordinates of the two points c ra,rb radii of the two points c cg center of gravity of the points c c subroutine get_coord2 (ia,ja,a,b,ra,rb,cg) use shapes implicit none integer i,ia,ja real*8 ra,rb real*8 a(*),b(*),cg(3) c c c get coordinates and center of mass, then center the points c do i = 1, 3 a(i) = crdball(3*(ia-1)+i) b(i) = crdball(3*(ja-1)+i) cg(i) = a(i) + b(i) end do do i = 1, 3 cg(i) = 0.5d0 * cg(i) end do do i = 1, 3 a(i) = a(i) - cg(i) b(i) = b(i) - cg(i) end do ra = radball(ia) rb = radball(ja) a(4) = a(1)*a(1) + a(2)*a(2) + a(3)*a(3) - ra*ra b(4) = b(1)*b(1) + b(2)*b(2) + b(3)*b(3) - rb*rb return end c c c ################################################################## c ## ## c ## subroutine get_coords4 -- extracts and stores four atoms ## c ## ## c ################################################################## c c c "get_coord4" extracts four atoms from the global array containing c all atoms, centers them on (0,0,0), recomputes their weights and c stores them in local arrays c c variables and parameters: c c ia,ja,ka,la indices of the four points considered c a,b,c,d centered coordinates of the four points c ra,rb,rc,rd radii of the four points c cg center of gravity of the points c c subroutine get_coord4 (ia,ja,ka,la,a,b,c,d,ra,rb,rc,rd,cg) use shapes implicit none integer i,ia,ja,ka,la real*8 ra,rb,rc,rd real*8 a(*),b(*),c(*) real*8 d(*),cg(3) c c c get coordinates and center of mass, and center the points c do i = 1, 3 a(i) = crdball(3*(ia-1)+i) b(i) = crdball(3*(ja-1)+i) c(i) = crdball(3*(ka-1)+i) d(i) = crdball(3*(la-1)+i) cg(i) = a(i) + b(i) + c(i) + d(i) end do do i = 1, 3 cg(i) = 0.25d0 * cg(i) end do do i = 1, 3 a(i) = a(i) - cg(i) b(i) = b(i) - cg(i) c(i) = c(i) - cg(i) d(i) = d(i) - cg(i) end do ra = radball(ia) rb = radball(ja) rc = radball(ka) rd = radball(la) a(4) = a(1)*a(1) + a(2)*a(2) + a(3)*a(3) - ra*ra b(4) = b(1)*b(1) + b(2)*b(2) + b(3)*b(3) - rb*rb c(4) = c(1)*c(1) + c(2)*c(2) + c(3)*c(3) - rc*rc d(4) = d(1)*d(1) + d(2)*d(2) + d(3)*d(3) - rd*rd return end c c c ################################################################## c ## ## c ## subroutine get_coords5 -- extracts and stores five atoms ## c ## ## c ################################################################## c c c "get_coord5" extracts five atoms from the global array containing c all atoms, centers them on (0,0,0), recomputes their weights and c stores them in local arrays c c variables and parameters: c c ia,ja,ka,la,ma indices of the four points considered c a,b,c,d,e centered coordinates of the five points c ra,rb,rc,rd,re radii of the four points c cg center of gravity of the points c c subroutine get_coord5 (ia,ja,ka,la,ma,a,b,c,d,e, & ra,rb,rc,rd,re,cg) use shapes implicit none integer i,ia,ja,ka,la,ma real*8 ra,rb,rc,rd,re real*8 a(*),b(*),c(*) real*8 d(*),e(*),cg(3) c c c get coordinates and center of mass, and center the points c do i = 1, 3 a(i) = crdball(3*(ia-1)+i) b(i) = crdball(3*(ja-1)+i) c(i) = crdball(3*(ka-1)+i) d(i) = crdball(3*(la-1)+i) e(i) = crdball(3*(ma-1)+i) cg(i) = a(i) + b(i) + c(i) + d(i) + e(i) end do do i = 1, 3 cg(i) = 0.2d0 * cg(i) end do do i = 1, 3 a(i) = a(i) - cg(i) b(i) = b(i) - cg(i) c(i) = c(i) - cg(i) d(i) = d(i) - cg(i) e(i) = e(i) - cg(i) end do ra = radball(ia) rb = radball(ja) rc = radball(ka) rd = radball(la) re = radball(ma) a(4) = a(1)*a(1) + a(2)*a(2) + a(3)*a(3) - ra*ra b(4) = b(1)*b(1) + b(2)*b(2) + b(3)*b(3) - rb*rb c(4) = c(1)*c(1) + c(2)*c(2) + c(3)*c(3) - rc*rc d(4) = d(1)*d(1) + d(2)*d(2) + d(3)*d(3) - rd*rd e(4) = e(1)*e(1) + e(2)*e(2) + e(3)*e(3) - re*re return end c c c ################################################################ c ## ## c ## subroutine resize_tet -- resize all tetrahedron arrays ## c ## ## c ################################################################ c c c "resize_tet" resizes all arrays related to tetrahedra, when c the initial estimate of the number of tetrahedron was wrong c c subroutine resize_tet use shapes implicit none integer i,j integer, allocatable :: tetra2(:,:) integer, allocatable :: tneighbor2(:,:) integer, allocatable :: tinfo2(:) integer, allocatable :: tnindex2(:) save c c c set size of space for tetrahedra-related arrays c maxtetra = (3*ntetra) / 2 maxtetra = max(maxtetra,ntetra+1000) c c perform dynamic allocation of some local arrays c allocate (tinfo2(maxtetra)) allocate (tnindex2(maxtetra)) allocate (tetra2(4,maxtetra)) allocate (tneighbor2(4,maxtetra)) c c copy prior information into resized arrays c do i = 1, ntetra tinfo2(i) = tinfo(i) tnindex2(i) = tnindex(i) do j = 1, 4 tetra2(j,i) = tetra(j,i) tneighbor2(j,i) = tneighbor(j,i) end do end do c c move the extended array storage into prior arrays; note c deallocation of new temporary arrays happens automatically c call move_alloc (tinfo2,tinfo) call move_alloc (tnindex2,tnindex) call move_alloc (tetra2,tetra) call move_alloc (tneighbor2,tneighbor) return end c c c ################################################################# c ## ## c ## subroutine hpsort_three -- heapsort 3D reals with index ## c ## ## c ################################################################# c c c "hpsort_three" rearranges an array in ascending order and c provide an index of the ranked element c c subroutine hpsort_three (ra,index,n) implicit none integer i,j,k,m,n integer ir,idx,comp3 integer index(n) real*8 rra(3) real*8 ra(3,n) save c c do i = 1, n index(i) = i end do if (n .lt. 2) return m = n/2 + 1 ir = n 10 continue if (m .gt. 1) then m = m - 1 do k = 1, 3 rra(k) = ra(k,m) end do idx = m else do k = 1, 3 rra(k) = ra(k,ir) end do idx = index(ir) do k = 1, 3 ra(k,ir) = ra(k,1) end do index(ir) = index(1) ir = ir - 1 if (ir .eq. 1) then do k = 1, 3 ra(k,1) = rra(k) end do index(1) = idx return end if end if i = m j = m + m 20 continue if (j .le. ir) then if (j .lt. ir) then if (comp3(ra(1,j),ra(1,j+1)) .eq. 1) j = j + 1 end if if (comp3(rra,ra(1,j)) .eq. 1) then do k = 1, 3 ra(k,i) = ra(k,j) end do index(i) = index(j) i = j j = j + j else j = ir + 1 end if goto 20 end if do k = 1, 3 ra(k,i) = rra(k) end do index(i) = idx goto 10 return end c c c ################################################################## c ## ## c ## function comp3 -- compare two 3-dimensional real vectors ## c ## ## c ################################################################## c c c "comp3" is a function comparing two arrays each containing c three real numbers c c function comp3 (a,b) implicit none integer i,comp3 real*8 a(3),b(3) save c c comp3 = 0 do i = 1, 3 if (a(i) .lt. b(i)) then comp3 = 1 return else if (a(i) .gt. b(i)) then return end if end do return end c c c ################################################################ c ## ## c ## subroutine hpsort_two_int -- heapsort 2D integer array ## c ## ## c ################################################################ c c c "hpsort_two_int" rearranges an array in ascending order and c provide an index of the ranked element c c subroutine hpsort_two_int (ra,n) implicit none integer i,j,k,m,n integer ir,idx,comp2 integer rra(2) integer ra(2,n) save c c if (n .lt. 2) return m = n/2 + 1 ir = n 10 continue if (m .gt. 1) then m = m - 1 do k = 1, 2 rra(k) = ra(k,m) end do idx = m else do k = 1, 2 rra(k) = ra(k,ir) end do do k = 1, 2 ra(k,ir) = ra(k,1) end do ir = ir - 1 if (ir .eq. 1) then do k = 1, 2 ra(k,1) = rra(k) end do return end if end if i = m j = m + m 20 continue if (j .le. ir) then if (j .lt. ir) then if (comp2(ra(1,j),ra(1,j+1)) .eq. 1) j = j + 1 end if if (comp2(rra,ra(1,j)) .eq. 1) then do k = 1, 2 ra(k,i) = ra(k,j) end do i = j j = j + j else j = ir + 1 end if goto 20 end if do k = 1, 2 ra(k,i) = rra(k) end do goto 10 return end c c c ################################################################## c ## ## c ## function comp2 -- compare two 2-dimensional real vectors ## c ## ## c ################################################################## c c c "comp2" is a function comparing two arrays each containing c two real numbers c c function comp2 (a,b) implicit none integer i,comp2 integer a(2),b(2) save c c comp2 = 0 do i = 1, 2 if (a(i) .lt. b(i)) then comp2 = 1 return else if (a(i) .gt. b(i)) then return end if end do return end c c c ################################################################33 c ## ## c ## subroutine distance2 -- distance squares between spheres ## c ## ## c ################################################################## c c c "distance2" computes the square of the distance between two c sphere centers c c subroutine distance2 (crdball,n1,n2,dist) implicit none integer i,n1,n2 real*8 dist,val real*8 crdball(*) save c c dist = 0.0d0 do i = 1, 3 val = crdball(3*(n1-1)+i) - crdball(3*(n2-1)+i) dist = dist + val*val end do return end c c c ################################################################ c ## ## c ## subroutine plane_dist -- find sphere to plane distance ## c ## ## c ################################################################ c c c "plane_dist" computes the distance between the center of c sphere A and the Voronoi plane between this sphere and c another sphere B c c subroutine plane_dist (ra2,rb2,rab2,lambda) implicit none real*8 ra2,rb2,rab2 real*8 lambda save c c lambda = 0.5d0 - (ra2-rb2)/(2.0d0*rab2) return end c c c ############################################################### c ## ## c ## subroutine twosphere_surf -- sphere intersection area ## c ## ## c ############################################################### c c c "twosphere_surf" computes the surface area of the intersection c of two spheres, only called when the intersection exists c c variables and parameters: c c rab distance between the centers of the two spheres c rab2 squared distance between the centers of spheres c ra,rb radii of spheres A and B, respectively c ra2,rb2 squared radii of the spheres A and B c surfa partial contribution of A to the total surface c of the intersection c surfb partial contribution of B to the total surface c of the intersection c c subroutine twosphere_surf (ra,ra2,rb,rb2,rab,rab2,surfa,surfb) use math implicit none real*8 ra,rb,surfa,surfb real*8 vala,valb,lambda real*8 ra2,rb2,rab,rab2,ha,hb save c c c find the distance between center of sphere A and the c Voronoi plane between A and B c call plane_dist (ra2,rb2,rab2,lambda) valb = lambda * rab vala = rab - valb c c get height of the cap of sphere A occluded by sphere B c ha = ra - vala c c now do the same as above for sphere B c hb = rb - valb c c get the surface areas of intersection c surfa = twopi * ra * ha surfb = twopi * rb * hb return end c c c ################################################################ c ## ## c ## subroutine twosphere_vol -- sphere intersection volume ## c ## ## c ################################################################ c c c "twosphere_vol" calculates the volume of the intersection of c two balls and the surface area of the intersection of two c corresponding spheres c c variables and parameters: c c rab distance between the centers of the two spheres c rab2 squared distance between the centers of spheres c ra,rb radii of spheres A and B, respectively c ra2,rb2 squared radii of the spheres A and B c surfa partial contribution of A to the total surface c of the intersection c surfb partial contribution of B to the total surface c of the intersection c vola partial contribution of A to the total volume c of the intersection c volb partial contribution of B to the total volume c of the intersection c c subroutine twosphere_vol (ra,ra2,rb,rb2,rab,rab2, & surfa,surfb,vola,volb) use math implicit none real*8 ra,rb,surfa,surfb real*8 vola,volb real*8 vala,valb,lamda real*8 ra2,rb2,rab,rab2 real*8 ha,hb,sa,ca,sb,cb real*8 aab save c c c find the distance between center of sphere A and the c Voronoi plane between A and B c call plane_dist (ra2,rb2,rab2,lamda) valb = lamda * rab vala = rab - valb c c get height of the cap of sphere A occluded by sphere B c ha = ra - vala c c now do the same as above for sphere B c hb = rb - valb c c get the surface areas of intersection c surfa = twopi * ra * ha surfb = twopi * rb * hb c c now get the associated volume c aab = pi * (ra2-vala*vala) sa = ra * surfa ca = vala * aab vola = (sa-ca) / 3.0d0 sb = rb * surfb cb = valb * aab volb = (sb-cb) / 3.0d0 return end c c c ############################################################### c ## ## c ## subroutine threesphere_surf -- find three sphere area ## c ## ## c ############################################################### c c c "threesphere_surf" calculates the surface area of intersection c of three spheres c c variables and parameters: c c ra,rb,rc radii of spheres A, B and C, respectively c ra2,rb2,rc2 squared distance between the centers of spheres c rab,rab2 distance between the centers of sphere A and B c rac,rac2 distance between the centers of sphere A and C c rbc,rbc2 distance between the centers of sphere B and C c surfa,surfb, contribution of A, B and C to the total surface c surfc of the intersection of A, B and C c c subroutine threesphere_surf (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc, & rab2,rac2,rbc2,surfa,surfb,surfc) use math implicit none real*8 surfa,surfb,surfc real*8 ra,rb,rc real*8 rab,rac,rbc real*8 rab2,rac2,rbc2 real*8 ra2,rb2,rc2 real*8 a1,a2,a3 real*8 seg_ang_ab,seg_ang_ac real*8 seg_ang_bc real*8 ang_dih_ap,ang_dih_bp real*8 ang_dih_cp real*8 l1,l2,l3 real*8 val1,val2,val3 real*8 val1b,val2b,val3b real*8 angle(6),cosine(6),sine(6) save c c call plane_dist (ra2,rb2,rab2,l1) call plane_dist (ra2,rc2,rac2,l2) call plane_dist (rb2,rc2,rbc2,l3) val1 = l1 * rab val2 = l2 * rac val3 = l3 * rbc val1b = rab - val1 val2b = rac - val2 val3b = rbc - val3 c c consider the tetrahedron (A,B,C,P) where P is the point c of intersection of the three spheres such that (A,B,C,P) c is counter-clockwise; the edge lengths in this tetrahedron c are rab, rac, rAP=ra, rbc, rBP=rb and rCP=rc c call tetra_dihed (rab2,rac2,ra2,rbc2,rb2,rc2,angle,cosine,sine) c c the seg_ang values are the dihedral angles around the three c edges AB, AC and BC c seg_ang_ab = angle(1) seg_ang_ac = angle(2) seg_ang_bc = angle(4) c c the ang_dih values are the dihedral angles around the three c edges AP, BP and CP c ang_dih_ap = angle(3) ang_dih_bp = angle(5) ang_dih_cp = angle(6) a1 = ra * (1.0d0-2.0d0*ang_dih_ap) a2 = 2.0d0 * seg_ang_ab * val1b a3 = 2.0d0 * seg_ang_ac * val2b surfa = twopi * ra * (a1-a2-a3) a1 = rb * (1.0d0-2.0d0*ang_dih_bp) a2 = 2.0d0 * seg_ang_ab * val1 a3 = 2.0d0 * seg_ang_bc * val3b surfb = twopi * rb * (a1-a2-a3) a1 = rc * (1.0d0-2.0d0*ang_dih_cp) a2 = 2.0d0 * seg_ang_ac * val2 a3 = 2.0d0 * seg_ang_bc * val3 surfc = twopi * rc * (a1-a2-a3) return end c c c ################################################################ c ## ## c ## subroutine threesphere_vol -- find three sphere volume ## c ## ## c ################################################################ c c c "threesphere_vol" calculates the volume of intersection of c three balls as well as the surface area of intersection c c variables and parameters: c c ra,rb,rc radii of spheres A, B and C, respectively c ra2,rb2,rc2 squared distance between the centers of spheres c rab,rab2 distance between the centers of sphere A and B c rac,rac2 distance between the centers of sphere A and C c rbc,rbc2 distance between the centers of sphere B and C c surfa,surfb, contribution of A, B and C to the total surface c surfc of the intersection of A, B and C c vola,volb, contribution of A, B and C tothe total volume c volc of the intersection of A, B and C c c subroutine threesphere_vol (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc, & rab2,rac2,rbc2,surfa,surfb,surfc, & vola,volb,volc) use math implicit none real*8 surfa,surfb,surfc real*8 vola,volb,volc real*8 ra,rb,rc real*8 rab,rac,rbc real*8 rab2,rac2,rbc2 real*8 ra2,rb2,rc2 real*8 a1,a2,a3,s2,c1,c2 real*8 seg_ang_ab,seg_ang_ac real*8 seg_ang_bc real*8 ang_dih_ap,ang_dih_bp real*8 ang_dih_cp real*8 ang_abc,ang_acb,ang_bca real*8 cos_abc,cos_acb,cos_bca real*8 sin_abc,sin_acb,sin_bca real*8 s_abc,s_acb,s_bca real*8 l1,l2,l3 real*8 val1,val2,val3 real*8 val1b,val2b,val3b real*8 rho_ab2,rho_ac2,rho_bc2 real*8 angle(6),cosine(6),sine(6) save c c call plane_dist (ra2,rb2,rab2,l1) call plane_dist (ra2,rc2,rac2,l2) call plane_dist (rb2,rc2,rbc2,l3) val1 = l1 * rab val2 = l2 * rac val3 = l3 * rbc val1b = rab - val1 val2b = rac - val2 val3b = rbc - val3 c c consider the tetrahedron (A,B,C,P) where P is the point c of intersection of the three spheres such that (A,B,C,P) c is counter-clockwise; the edge lengths in this tetrahedron c are rab, rac, rAP=ra, rbc, rBP=rb and rCP=rc c call tetra_dihed (rab2,rac2,ra2,rbc2,rb2,rc2,angle,cosine,sine) c c the seg_ang values are the dihedral angles around the three c edges AB, AC and BC c seg_ang_ab = angle(1) seg_ang_ac = angle(2) seg_ang_bc = angle(4) c c the ang_dih values are the dihedral angles around the three c edges AP, BP and CP c ang_dih_ap = angle(3) ang_dih_bp = angle(5) ang_dih_cp = angle(6) a1 = ra * (1.0d0-2.0d0*ang_dih_ap) a2 = 2.0d0 * seg_ang_ab * val1b a3 = 2.0d0 * seg_ang_ac * val2b surfa = twopi * ra * (a1-a2-a3) a1 = rb * (1.0d0-2.0d0*ang_dih_bp) a2 = 2.0d0 * seg_ang_ab * val1 a3 = 2.0d0 * seg_ang_bc * val3b surfb = twopi * rb * (a1-a2-a3) a1 = rc * (1.0d0-2.0d0*ang_dih_cp) a2 = 2.0d0 * seg_ang_ac * val2 a3 = 2.0d0 * seg_ang_bc * val3 surfc = twopi * rc * (a1-a2-a3) ang_abc = twopi * seg_ang_ab ang_acb = twopi * seg_ang_ac ang_bca = twopi * seg_ang_bc cos_abc = cosine(1) sin_abc = sine(1) cos_acb = cosine(2) sin_acb = sine(2) cos_bca = cosine(4) sin_bca = sine(4) rho_ab2 = ra2 - val1b*val1b rho_ac2 = ra2 - val2b*val2b rho_bc2 = rb2 - val3b*val3b s_abc = rho_ab2 * (ang_abc-sin_abc*cos_abc) s_acb = rho_ac2 * (ang_acb-sin_acb*cos_acb) s_bca = rho_bc2 * (ang_bca-sin_bca*cos_bca) s2 = ra * surfa c1 = val1b * s_abc c2 = val2b * s_acb vola = (s2-c1-c2) / 3.0d0 s2 = rb * surfb c1 = val1 * s_abc c2 = val3b * s_bca volb = (s2-c1-c2) / 3.0d0 s2 = rc * surfc c1 = val2 * s_acb c2 = val3 * s_bca volc = (s2-c1-c2) / 3.0d0 return end c c c ############################################################## c ## ## c ## subroutine triangle_surf -- three sphere area driver ## c ## ## c ############################################################## c c c "triangle_surf" computes the surface area of intersection c of three balls, provides a wrapper to "threesphere_surf" c c subroutine triangle_surf (a,b,c,rab,rac,rbc,rab2,rac2,rbc2,ra, & rb,rc,ra2,rb2,rc2,surfa,surfb,surfc) implicit none real*8 rab,rac,rbc real*8 rab2,rac2,rbc2 real*8 ra,rb,rc real*8 ra2,rb2,rc2 real*8 surfa,surfb,surfc real*8 a(3),b(3),c(3),u(3) c c if (rab .eq. 0.0d0) then call diffvect (a,b,u) call normvect (u,rab) rab2 = rab * rab end if if (rac .eq. 0.0d0) then call diffvect (a,c,u) call normvect (u,rac) rac2 = rac * rac end if if (rbc .eq. 0.0d0) then call diffvect (b,c,u) call normvect (u,rbc) rbc2 = rbc * rbc end if call threesphere_surf (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc, & rab2,rac2,rbc2,surfa,surfb,surfc) return end c c c ############################################################### c ## ## c ## subroutine triangle_vol -- three sphere volume driver ## c ## ## c ############################################################### c c c "triangle_vol" computes the volume of intersection of three c balls, provides a wrapper to "threesphere_vol" c c subroutine triangle_vol (a,b,c,rab,rac,rbc,rab2,rac2,rbc2, & ra,rb,rc,ra2,rb2,rc2,surfa,surfb, & surfc,vola,volb,volc) implicit none real*8 rab,rac,rbc real*8 rab2,rac2,rbc2 real*8 ra,rb,rc real*8 ra2,rb2,rc2 real*8 surfa,surfb,surfc real*8 vola,volb,volc real*8 a(3),b(3),c(3),u(3) c c if (rab .eq. 0.0d0) then call diffvect (a,b,u) call normvect (u,rab) rab2 = rab * rab end if if (rac .eq. 0.0d0) then call diffvect (a,c,u) call normvect (u,rac) rac2 = rac * rac end if if (rbc .eq. 0.0d0) then call diffvect (b,c,u) call normvect (u,rbc) rbc2 = rbc * rbc end if call threesphere_vol (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc, & rab2,rac2,rbc2,surfa,surfb,surfc, & vola,volb,volc) return end c c c ############################################################# c ## ## c ## subroutine tetra_voronoi -- find four sphere volume ## c ## ## c ############################################################# c c c "tetra_voronoi" computes the volume of intersection of the c tetrahedron formed by the center of four balls with the c Voronoi cells corresponding to these balls c c variables and parameters: c c ra2,rb2,rc2,rd2 squared radii of the spheres A, B, C, D c rab,rac,rad, all distances between the ball centers c rbc,rbd,rcd c rab2,rac2,rad2, squared distances between ball centers c rbc2,rbd2,rcd2 c cos_ang cosine of the six dihedral angles of the c tetrahedron c sin_ang sine of the six dihedral angles of the c tetrahedron c vola,volb, fraction of the volume of tetrahedron c volc,vold corresponding to the four balls c c subroutine tetra_voronoi (ra2,rb2,rc2,rd2,rab,rac,rad,rbc,rbd, & rcd,rab2,rac2,rad2,rbc2,rbd2,rcd2, & cos_ang,sin_ang,vola,volb,volc,vold) integer i real*8 ra2,rb2,rc2,rd2 real*8 rab,rac,rad real*8 rbc,rbd,rcd real*8 rab2,rac2,rad2 real*8 rbc2,rbd2,rcd2 real*8 vola,volb,volc,vold real*8 l1,l2,l3,l4,l5,l6 real*8 val1,val2,val3 real*8 val4,val5,val6 real*8 val1b,val2b,val3b real*8 val4b,val5b,val6b real*8 cos_abc,cos_acb,cos_bca real*8 cos_abd,cos_adb,cos_bda real*8 cos_acd,cos_adc,cos_cda real*8 cos_bcd,cos_bdc,cos_cdb real*8 rho_ab2,rho_ac2,rho_ad2 real*8 rho_bc2,rho_bd2,rho_cd2 real*8 cap_ab,cap_ac,cap_ad real*8 cap_bc,cap_bd,cap_cd real*8 eps real*8 cosine_abc(3),cosine_abd(3) real*8 cosine_acd(3),cosine_bcd(3) real*8 cos_ang(6),sin_ang(6) real*8 invsin(6),cotan(6) save c c call plane_dist (ra2,rb2,rab2,l1) call plane_dist (ra2,rc2,rac2,l2) call plane_dist (ra2,rd2,rad2,l3) call plane_dist (rb2,rc2,rbc2,l4) call plane_dist (rb2,rd2,rbd2,l5) call plane_dist (rc2,rd2,rcd2,l6) val1 = l1 * rab val2 = l2 * rac val3 = l3 * rad val4 = l4 * rbc val5 = l5 * rbd val6 = l6 * rcd val1b = rab - val1 val2b = rac - val2 val3b = rad - val3 val4b = rbc - val4 val5b = rbd - val5 val6b = rcd - val6 c c consider the tetrahedron (A,B,C,P) where P is the point c of intersection of the three spheres such that (A,B,C,P) c is counter-clockwise; the edge lengths in this tetrahedron c are rab, rac, rAP=ra, rbc, rBP=rb and rCP=rc c call tetra_3dihed_cos (rab2,rac2,ra2,rbc2,rb2,rc2,cosine_abc) c c repeat the above for tetrahedron (A,B,D,P) c call tetra_3dihed_cos (rab2,rad2,ra2,rbd2,rb2,rd2,cosine_abd) c c repeat the above for tetrahedron (A,C,D,P) c call tetra_3dihed_cos (rac2,rad2,ra2,rcd2,rc2,rd2,cosine_acd) c c repeat the above for tetrahedron (B,C,D,P) c call tetra_3dihed_cos (rbc2,rbd2,rb2,rcd2,rc2,rd2,cosine_bcd) c cos_abc = cosine_abc(1) cos_acb = cosine_abc(2) cos_bca = cosine_abc(3) cos_abd = cosine_abd(1) cos_adb = cosine_abd(2) cos_bda = cosine_abd(3) cos_acd = cosine_acd(1) cos_adc = cosine_acd(2) cos_cda = cosine_acd(3) cos_bcd = cosine_bcd(1) cos_bdc = cosine_bcd(2) cos_cdb = cosine_bcd(3) rho_ab2 = ra2 - val1b*val1b rho_ac2 = ra2 - val2b*val2b rho_ad2 = ra2 - val3b*val3b rho_bc2 = rb2 - val4b*val4b rho_bd2 = rb2 - val5b*val5b rho_cd2 = rc2 - val6b*val6b eps = 1.0d-14 do i = 1, 6 if (abs(sin_ang(i)) < eps) then invsin(i) = 0.0d0; cotan(i) = 0.0d0; else invsin(i) = 1.0d0 / sin_ang(i) cotan(i) = cos_ang(i)*invsin(i) end if end do cap_ab = -rho_ab2*(cos_abc*cos_abc+cos_abd*cos_abd)*cotan(1) & + 2*rho_ab2*cos_abc*cos_abd*invsin(1) cap_ac = -rho_ac2*(cos_acb*cos_acb+cos_acd*cos_acd)*cotan(2) & + 2*rho_ac2*cos_acb*cos_acd*invsin(2) cap_ad = -rho_ad2*(cos_adb*cos_adb+cos_adc*cos_adc)*cotan(3) & + 2*rho_ad2*cos_adb*cos_adc*invsin(3) cap_bc = -rho_bc2*(cos_bca*cos_bca+cos_bcd*cos_bcd)*cotan(4) & + 2*rho_bc2*cos_bca*cos_bcd*invsin(4) cap_bd = -rho_bd2*(cos_bda*cos_bda+cos_bdc*cos_bdc)*cotan(5) & + 2*rho_bd2*cos_bda*cos_bdc*invsin(5) cap_cd = -rho_cd2*(cos_cda*cos_cda+cos_cdb*cos_cdb)*cotan(6) & + 2*rho_cd2*cos_cda*cos_cdb*invsin(6) vola = (val1b*cap_ab+val2b*cap_ac+val3b*cap_ad) / 6.0d0 volb = (val1*cap_ab+val4b*cap_bc+val5b*cap_bd) / 6.0d0 volc = (val2*cap_ac+val4*cap_bc+val6b*cap_cd) / 6.0d0 vold = (val3*cap_ad+val5*cap_bd+val6*cap_cd) / 6.0d0 return end c c c ############################################################## c ## ## c ## subroutine twosphere_dsurf -- two sphere area derivs ## c ## ## c ############################################################## c c c "twosphere_dsurf" calculates the surface area of intersection c of two spheres; also computes the derivatives of the surface c area with respect to the distance between the sphere centers c c note this version uses only the radii of the spheres and the c distance between their centers c c variables and parameters: c c rab distance between the centers of the spheres c rab2 distance squared between the sphere centers c ra,rb radii of spheres A and B, respectively c ra2,rb2 radii squared of the two spheres c option set to 1 to compute derivatives, or 0 if not c surfa partial contribution of A to the total c surface area of the intersection c surfb partial contribution of B to the total c surface area of the intersection c dsurfa derivative of surfa with respect to rab c dsurfb derivative of surfb with respect to rab c c subroutine twosphere_dsurf (ra,ra2,rb,rb2,rab,rab2,surfa, & surfb,dsurfa,dsurfb,option) use math implicit none integer option real*8 ra,rb real*8 surfa,surfb real*8 dsurfa,dsurfb real*8 vala,valb real*8 ra2,rb2 real*8 rab,rab2 real*8 ha,hb,lambda real*8 dera,derb save c c c get distance between center of sphere A and the Voronoi c plane between A and B c call plane_dist (ra2,rb2,rab2,lambda) valb = lambda * rab vala = rab - valb c c find height of the cap of sphere A occluded by sphere B c ha = ra - vala c c find height of the cap of sphere B occluded by sphere A c hb = rb - valb c c compute the surface areas of intersection c surfa = twopi * ra * ha surfb = twopi * rb * hb if (option .ne. 1) return c c compute the accessible surface area derivatives c dera = -lambda derb = lambda - 1.0d0 dsurfa = twopi * ra * dera dsurfb = twopi * rb * derb return end c c c ############################################################### c ## ## c ## subroutine twosphere_dvol -- two sphere volume derivs ## c ## ## c ############################################################### c c c "twosphere_dvol" finds the volume of intersection of two balls c and the corresponding surface area of intersection; also finds c derivatives of the surface area and volume with respect to the c distance between the two centers c c variables and parameters: c c rab distance between the centers of the spheres c rab2 distance squared between the sphere centers c ra,rb radii of spheres A and B, respectively c ra2,rb2 radii squared of spheres A and B c option set to 1 to compute derivatives, or 0 if not c surfa partial contribution of A to the total c surface area of the intersection c surfb partial contribution of B to the total c surface area of the intersection c vola partial contribution of A to the total c volume of the intersection c volb partial contribution of B to the total c volume of the intersection c dsurfa derivative of surfa with respect to rab c dsurfb derivative of surfb with respect to rab c dvola derivative of vola with respect to rab c dvolb derivative of volb with respect to rab c c subroutine twosphere_dvol (ra,ra2,rb,rb2,rab,rab2,surfa,surfb, & vola,volb,dsurfa,dsurfb,dvola,dvolb, & option) use math implicit none integer option real*8 ra,rb real*8 surfa,surfb real*8 vola,volb real*8 dsurfa,dsurfb real*8 dvola,dvolb real*8 vala,valb,lambda real*8 ra2,rb2,rab,rab2 real*8 ha,hb,sa,ca,sb,cb real*8 dera,derb,aab save c c c get distance between center of sphere A and the Voronoi c plane between A and B c call plane_dist (ra2,rb2,rab2,lambda) valb = lambda * rab vala = rab - valb c c find height of the cap of sphere A occluded by sphere B c ha = ra - vala c c find height of the cap of sphere B occluded by sphere A c hb = rb - valb c c compute the surface areas of intersection c surfa = twopi * ra * ha surfb = twopi * rb * hb c c next get the volumes of intersection c aab = pi * (ra2-vala*vala) sa = ra * surfa ca = vala * aab vola = (sa-ca) / 3.0d0 sb = rb * surfb cb = valb * Aab volb = (sb-cb) / 3.0d0 if (option .ne. 1) return c c compute the surface area and volume derivatives c dera = -lambda derb = lambda - 1.0d0 dsurfa = twopi * ra * dera dsurfb = twopi * rb * derb dvola = -aab * lambda dvolb = -dvola - Aab return end c c c ################################################################## c ## ## c ## subroutine threesphere_dsurf -- three sphere area derivs ## c ## ## c ################################################################## c c c "threesphere_dsurf" computes the surface area of intersection c of three spheres A, B and C; also computes the derivatives of c the surface area with respect to the distances rAB, rAC and rBC c c variables and parameters: c c ra,rb,rc radii of the spheres A, B and C c ra2,rb2,rc2 radii squared of the spheres A, B and C c rab,rab2 distance and square between spheres A and B c rac,rac2 distance and square between spheres A and C c rbc,rbc2 distance and square between spheres B and C c option set to 1 to compute derivatives, or 0 if not c surfa,surfb, contribution of A, B and C to total surface c surfc of the intersection of A, B and C c dsurfa derivatives of surfa over rAB, rAC and rBC c dsurfb derivatives of surfb over rAB, rAC and rBC c dsurfc derivatives of surfc over rAB, rAC and rBC c c subroutine threesphere_dsurf (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc, & rab2,rac2,rbc2,surfa,surfb,surfc, & dsurfa,dsurfb,dsurfc,option) use math implicit none integer option real*8 surfa,surfb,surfc real*8 ra,rb,rc real*8 rab,rac,rbc real*8 rab2,rac2,rbc2 real*8 ra2,rb2,rc2 real*8 a1,a2,a3 real*8 seg_ang_ab,seg_ang_ac real*8 seg_ang_bc real*8 ang_dih_ap,ang_dih_bp real*8 ang_dih_cp real*8 val1,val2,val3,l1,l2,l3 real*8 val1b,val2b,val3b real*8 der_val1b,der_val1,der_val2b real*8 der_val2,der_val3b,der_val3 real*8 angle(6),cosine(6),sine(6) real*8 dsurfa(3),dsurfb(3),dsurfc(3) real*8 deriv(6,3) save c c call plane_dist (ra2,rb2,rab2,l1) call plane_dist (ra2,rc2,rac2,l2) call plane_dist (rb2,rc2,rbc2,l3) val1 = l1 * rab val2 = l2 * rac val3 = l3 * rbc val1b = rab - val1 val2b = rac - val2 val3b = rbc - val3 c c consider tetrahedron (A,B,C,P) where P is the intersection point c of the three spheres such that (A,B,C,P) is counter-clockwise c c the edge lengths in this tetrahedron are rab, rac, rAP=ra, rbc, c rBP=rb and rCP=rc c call tetra_dihed_der3 (rab2,rac2,ra2,rbc2,rb2,rc2, & angle,cosine,sine,deriv,option) c c the seg_ang_ values are the dihedral angles around the three c edges AB, AC and BC c seg_ang_ab = angle(1) seg_ang_ac = angle(2) seg_ang_bc = angle(4) c c the ang_dih_ values are the dihedral angles around the three c edges AP, BP and CP c ang_dih_ap = angle(3) ang_dih_bp = angle(5) ang_dih_cp = angle(6) a1 = ra * (1.0d0-2.0d0*ang_dih_ap) a2 = 2.0d0 * seg_ang_ab * val1b a3 = 2.0d0 * seg_ang_ac * val2b surfa = twopi * ra * (a1-a2-a3) a1 = rb * (1.0d0-2.0d0*ang_dih_bp) a2 = 2.0d0 * seg_ang_ab * val1 a3 = 2.0d0 * seg_ang_bc * val3b surfb = twopi * rb * (a1-a2-a3) a1 = rc * (1.0d0-2.0d0*ang_dih_cp) a2 = 2.0d0 * seg_ang_ac * val2 a3 = 2.0d0 * seg_ang_bc * val3 surfc = twopi * rc * (a1-a2-a3) if (option .ne. 1) return c c compute the accessible surface area derivatives c der_val1b = l1 der_val1 = 1.0d0 - l1 der_val2b = l2 der_val2 = 1.0d0 - l2 der_val3b = l3 der_val3 = 1.0d0 - l3 dsurfa(1) = -2.0d0 * ra * (twopi*seg_ang_ab*der_val1b & + 2.0d0*rab*(ra*deriv(3,1)+val1b*deriv(1,1) & +val2b*deriv(2,1))) dsurfa(2) = -2.0d0 * ra * (twopi*seg_ang_ac*der_val2b & + 2.0d0*rac*(ra*deriv(3,2)+val1b*deriv(1,2) & +val2b*deriv(2,2))) dsurfa(3) = ra * (-4.0d0*rbc*(ra*deriv(3,3)+val1b*deriv(1,3) & +val2b*deriv(2,3))) dsurfb(1) = -2.0d0 * rb * (twopi*seg_ang_ab*der_val1 & +2.0d0*rab*(rb*deriv(5,1)+val1*deriv(1,1) & +val3b*deriv(4,1))) dsurfb(2) = rb * (-4.0d0*rac*(rb*deriv(5,2)+val1*deriv(1,2) & +val3b*deriv(4,2))) dsurfb(3) = -2.0d0 * rb * (twopi*seg_ang_bc*der_val3b & +2.0d0*rbc*(rb*deriv(5,3)+val1*deriv(1,3) & +val3b*deriv(4,3))) dsurfc(1) = rc * (-4.0d0*rab*(rc*deriv(6,1)+val2*deriv(2,1) & +val3*deriv(4,1))) dsurfc(2) = -2.0d0 * rc * (twopi*seg_ang_ac*der_val2 & +2.0d0*rac*(rc*deriv(6,2)+val2*deriv(2,2) & +val3*deriv(4,2))) dsurfc(3) = -2.0d0 * rc * (twopi*seg_ang_bc*der_val3 & +2.0d0*rbc*(rc*deriv(6,3)+val2*deriv(2,3) & +val3*deriv(4,3))) return end c c c ################################################################## c ## ## c ## subroutine threesphere_dvol -- three sphere volume deriv ## c ## ## c ################################################################## c c c "threesphere_dvol" calculates the volume of the intersection of c three balls as well as the surface area of intersection of the c corresponding three spheres c c variables and parameters: c c ra,rb,rc radii of spheres A, B and C c ra2,rb2,rc2 radii squared of spheres A, B and C c rab,rab2 distance and square between spheres A and B c rac,rac2 distance and square between spheres A and C c rbc,rbc2 distance and square between spheres B and C c surfa,surfb, contribution of A, B and C to total surface of c surfc the intersection of A, B and C c vola,volb, contribution of A, B and C to total volume of c volc the intersection of A, B and C c c subroutine threesphere_dvol (ra,rb,rc,ra2,rb2,rc2,rab,rac,rbc, & rab2,rac2,rbc2,surfa,surfb,surfc, & vola,volb,volc,dsurfa,dsurfb,dsurfc, & dvola,dvolb,dvolc,option) use math implicit none integer option real*8 surfa,surfb,surfc real*8 vola,volb,volc real*8 ra,rb,rc real*8 rab,rac,rbc real*8 rab2,rac2,rbc2 real*8 ra2,rb2,rc2 real*8 a1,a2,a3,s2,c1,c2 real*8 seg_ang_ab,seg_ang_ac real*8 seg_ang_bc real*8 ang_dih_ap,ang_dih_bp real*8 ang_dih_cp real*8 ang_abc,ang_acb,ang_bca real*8 cos_abc,cos_acb,cos_bca real*8 sin_abc,sin_acb,sin_bca real*8 s_abc,s_acb,s_bca real*8 val1,val2,val3,l1,l2,l3 real*8 val1b,val2b,val3b real*8 rho_ab2,rho_ac2,rho_bc2 real*8 drho_ab2,drho_ac2,drho_bc2 real*8 val_abc,val_acb,val_bca real*8 val2_abc,val2_acb,val2_bca real*8 der_val1b,der_val2b,der_val3b real*8 der_val1,der_val2,der_val3 real*8 angle(6),cosine(6),sine(6) real*8 dsurfa(3),dsurfb(3),dsurfc(3) real*8 dvola(3),dvolb(3),dvolc(3) real*8 deriv(6,3) save c c call plane_dist (ra2,rb2,rab2,l1) call plane_dist (ra2,rc2,rac2,l2) call plane_dist (rb2,rc2,rbc2,l3) val1 = l1 * rab val2 = l2 * rac val3 = l3 * rbc val1b = rab - val1 val2b = rac - val2 val3b = rbc - val3 c c consider tetrahedron (A,B,C,P) where P is the intersection point c of the three spheres such that (A,B,C,P) is counter-clockwise c c the edge lengths in this tetrahedron are rab, rac, rAP=ra, rbc, c rBP=rb and rCP=rc c call tetra_dihed_der3 (rab2,rac2,ra2,rbc2,rb2,rc2, & angle,cosine,sine,deriv,option) c c the seg_ang_ values are the dihedral angles around the three c edges AB, AC and BC c seg_ang_ab = angle(1) seg_ang_ac = angle(2) seg_ang_bc = angle(4) c c the ang_dih_ values are the dihedral angles around the three c edges AP, BP and CP c ang_dih_ap = angle(3) ang_dih_bp = angle(5) ang_dih_cp = angle(6) a1 = ra * (1.0d0-2.0d0*ang_dih_ap) a2 = 2.0d0 * seg_ang_ab * val1b a3 = 2.0d0 * seg_ang_ac * val2b surfa = twopi * ra * (a1-a2-a3) a1 = rb * (1.0d0-2.0d0*ang_dih_bp) a2 = 2.0d0 * seg_ang_ab * val1 a3 = 2.0d0 * seg_ang_bc * val3b surfb = twopi * rb * (a1-a2-a3) a1 = rc * (1.0d0-2.0d0*ang_dih_cp) a2 = 2.0d0 * seg_ang_ac * val2 a3 = 2.0d0 * seg_ang_bc * val3 surfc = twopi * rc * (a1-a2-a3) ang_abc = twopi * seg_ang_ab ang_acb = twopi * seg_ang_ac ang_bca = twopi * seg_ang_bc cos_abc = cosine(1) sin_abc = sine(1) cos_acb = cosine(2) sin_acb = sine(2) cos_bca = cosine(4) sin_bca = sine(4) rho_ab2 = ra2 - val1b*val1b rho_ac2 = ra2 - val2b*val2b rho_bc2 = rb2 - val3b*val3b val_abc = ang_abc - sin_abc*cos_abc val_acb = ang_acb - sin_acb*cos_acb val_bca = ang_bca - sin_bca*cos_bca s_abc = rho_ab2 * val_abc s_acb = rho_ac2 * val_acb s_bca = rho_bc2 * val_bca s2 = ra * surfa c1 = val1b * s_abc c2 = val2b * s_acb vola = (s2-c1-c2) / 3.0d0 s2 = rb * surfb c1 = val1 * s_abc c2 = val3b * s_bca volb = (s2-c1-c2) / 3.0d0 s2 = rc * surfc c1 = val2 * s_acb c2 = val3 * s_bca volc = (s2-c1-c2) / 3.0d0 if (option .ne. 1) return c c compute the accessible surface area derivatives c der_val1b = l1 der_val1 = 1.0d0 - l1 der_val2b = l2 der_val2 = 1.0d0 - l2 der_val3b = l3 der_val3 = 1.0d0 - l3 drho_ab2 = -2.0d0 * der_val1b * val1b drho_ac2 = -2.0d0 * der_val2b * val2b drho_bc2 = -2.0d0 * der_val3b * val3b dsurfa(1) = -2.0d0 * ra * (twopi*seg_ang_ab*der_val1b & + 2.0d0*rab*(ra*deriv(3,1)+val1b*deriv(1,1) & +val2b*deriv(2,1))) dsurfa(2) = -2.0d0 * ra * (twopi*seg_ang_ac*der_val2b & + 2.0d0*rac*(ra*deriv(3,2)+val1b*deriv(1,2) & +val2b*deriv(2,2))) dsurfa(3) = ra * (-4.0d0*rbc*(ra*deriv(3,3)+val1b*deriv(1,3) & +val2b*deriv(2,3))) dsurfb(1) = -2.0d0 * rb * (twopi*seg_ang_ab*der_val1 & +2.0d0*rab*(rb*deriv(5,1)+val1*deriv(1,1) & +val3b*deriv(4,1))) dsurfb(2) = rb * (-4.0d0*rac*(rb*deriv(5,2)+val1*deriv(1,2) & +val3b*deriv(4,2))) dsurfb(3) = -2.0d0 * rb * (twopi*seg_ang_bc*der_val3b & +2.0d0*rbc*(rb*deriv(5,3)+val1*deriv(1,3) & +val3b*deriv(4,3))) dsurfc(1) = rc * (-4.0d0*rab*(rc*deriv(6,1)+val2*deriv(2,1) & +val3*deriv(4,1))) dsurfc(2) = -2.0d0 * rc * (twopi*seg_ang_ac*der_val2 & +2.0d0*rac*(rc*deriv(6,2)+val2*deriv(2,2) & +val3*deriv(4,2))) dsurfc(3) = -2.0d0 * rc * (twopi*seg_ang_bc*der_val3 & +2.0d0*rbc*(rc*deriv(6,3)+val2*deriv(2,3) & +val3*deriv(4,3))) c c compute the excluded volume derivatives c val2_abc = rho_ab2 * (1.0d0-cos_abc*cos_abc+sin_abc*sin_abc) val2_acb = rho_ac2 * (1.0d0-cos_acb*cos_acb+sin_acb*sin_acb) val2_bca = rho_bc2 * (1.0d0-cos_bca*cos_bca+sin_bca*sin_bca) dvola(1) = ra*dsurfa(1) - der_val1b*s_abc & - 2.0d0*rab*(val1b*deriv(1,1)*val2_abc & +val2b*deriv(2,1)*val2_acb) & - val1b*drho_ab2*val_abc dvola(1) = dvola(1) / 3.0d0 dvola(2) = ra*dsurfa(2) - der_val2b*s_acb & - 2.0d0*rac*(val1b*deriv(1,2)*val2_abc & +val2b*deriv(2,2)*val2_acb) & - val2b*drho_ac2*val_acb dvola(2) = dvola(2) / 3.0d0 dvola(3) = ra*dsurfa(3) - 2.0d0*rbc*(val1b*deriv(1,3)*val2_abc & +val2b*deriv(2,3)*val2_acb) dvola(3) = dvola(3) / 3.0d0 dvolb(1) = rb*dsurfb(1) - der_val1*s_abc & - 2.0d0*rab*(val1*deriv(1,1)*val2_abc & +val3b*deriv(4,1)*val2_bca) & - val1*drho_ab2*val_abc dvolb(1) = dvolb(1) / 3.0d0 dvolb(2) = rb*dsurfb(2) - 2.0d0*rac*(val1*deriv(1,2)*val2_abc & +val3b*deriv(4,2)*val2_bca) dvolb(2) = dvolb(2) / 3.0d0 dvolb(3) = rb*dsurfb(3) - der_val3b*s_bca & - 2.0d0*rbc*(val1*deriv(1,3)*val2_abc & + val3b*deriv(4,3)*val2_bca) & - val3b*drho_bc2*val_bca dvolb(3) = dvolb(3) / 3.0d0 dvolc(1) = rc*dsurfc(1) - 2.0d0*rab*(val2*deriv(2,1)*val2_acb & +val3*deriv(4,1)*val2_bca) dvolc(1) = dvolc(1) / 3.0d0 dvolc(2) = rc*dsurfc(2) - der_val2*s_acb & - 2.0d0*rac*(val2*deriv(2,2)*val2_acb & +val3*deriv(4,2)*val2_bca) & - val2*drho_ac2*val_acb dvolc(2) = dvolc(2) / 3.0d0 dvolc(3) = rc*dsurfc(3) - der_val3*s_bca & - 2.0d0*rbc*(val2*deriv(2,3)*val2_acb & +val3*deriv(4,3)*val2_bca) & - val3*drho_bc2*val_bca dvolc(3) = dvolc(3) / 3.0d0 return end c c c ################################################################## c ## ## c ## subroutine tetra_voronoi_der -- four sphere volume deriv ## c ## ## c ################################################################## c c c "tetra_voronoi_der" computes the volume of the intersection c of the tetrahedron formed by the center of four balls with the c Voronoi cells corresponding to these balls; also computes the c derivatives of these volumes with respect to the edge lengths; c only computed if the four balls have a common intersection c c variables and parameters: c c ra,rb,rc,rd radii of the four balls c ra2,rb2,rc2,rd2 radii squared of the four balls c rab,rac,rad, distance between pairs of balls c rbc,rbd,rcd c rab2,rac2,rad2, distance squared between pairs of balls c rbc2,rbd2,rcd2 c cos_ang cosine of the six tetrahedral dihedral angles c sin_ang sine of the six tetrahedral dihedral angles c deriv derivatives of the six dihedral angles c with respect to edge lengths c vola,volb, fraction of the volume of the tetrahedron c volc,vold corresponding to balls a, b, c and d c dvola derivatives of vola wrt the six edge lengths c dvolb derivatives of volb wrt the six edge lengths c dvolc derivatives of volc wrt the six edge lengths c dvold derivatives of vold wrt the six edge lengths c c subroutine tetra_voronoi_der (ra2,rb2,rc2,rd2,rab,rac,rad,rbc, & rbd,rcd,rab2,rac2,rad2,rbc2,rbd2, & rcd2,cos_ang,sin_ang,deriv,vola, & volb,volc,vold,dvola,dvolb,dvolc, & dvold,option) implicit none integer i,j,option real*8 ra2,rb2,rc2,rd2 real*8 rab,rac,rad real*8 rbc,rbd,rcd real*8 rab2,rac2,rad2 real*8 rbc2,rbd2,rcd2 real*8 vola,volb,volc,vold real*8 l1,l2,l3,l4,l5,l6 real*8 val1,val2,val3 real*8 val4,val5,val6 real*8 val1b,val2b,val3b real*8 val4b,val5b,val6b real*8 cos_abc,cos_acb,cos_bca real*8 cos_abd,cos_adb,cos_bda real*8 cos_acd,cos_adc,cos_cda real*8 cos_bcd,cos_bdc,cos_cdb real*8 rho_ab2,rho_ac2,rho_ad2 real*8 rho_bc2,rho_bd2,rho_cd2 real*8 drho_ab2,drho_ac2,drho_ad2 real*8 drho_bc2,drho_bd2,drho_cd2 real*8 dval1,dval2,dval3 real*8 dval4,dval5,dval6 real*8 dval1b,dval2b,dval3b real*8 dval4b,dval5b,dval6b real*8 val_ab,val_ac,val_ad real*8 val_bc,val_bd,val_cd real*8 val1_ab,val1_ac,val1_ad real*8 val1_bc,val1_bd,val1_cd real*8 val2_ab,val2_ac,val2_ad real*8 val2_bc,val2_bd,val2_cd real*8 cap_ab,cap_ac,cap_ad real*8 cap_bc,cap_bd,cap_cd real*8 eps,tetvol,teteps real*8 dist(6),invsin(6),cotan(6) real*8 cosine_abc(3),cosine_abd(3) real*8 cosine_acd(3),cosine_bcd(3) real*8 cos_ang(6),sin_ang(6) real*8 deriv(6,6) real*8 deriv_abc(3,3),deriv_abd(3,3) real*8 deriv_acd(3,3),deriv_bcd(3,3) real*8 dinvsin(6,6),dcotan(6,6) real*8 dval1_ab(6),dval1_ac(6) real*8 dval1_ad(6),dval1_bc(6) real*8 dval1_bd(6),dval1_cd(6) real*8 dval2_ab(6),dval2_ac(6) real*8 dval2_ad(6),dval2_bc(6) real*8 dval2_bd(6),dval2_cd(6) real*8 dcap_ab(6),dcap_ac(6) real*8 dcap_ad(6),dcap_bc(6) real*8 dcap_bd(6),dcap_cd(6) real*8 dvola(6),dvolb(6) real*8 dvolc(6),dvold(6) save c c call plane_dist (ra2,rb2,rab2,l1) call plane_dist (ra2,rc2,rac2,l2) call plane_dist (ra2,rd2,rad2,l3) call plane_dist (rb2,rc2,rbc2,l4) call plane_dist (rb2,rd2,rbd2,l5) call plane_dist (rc2,rd2,rcd2,l6) val1 = l1 * rab val2 = l2 * rac val3 = l3 * rad val4 = l4 * rbc val5 = l5 * rbd val6 = l6 * rcd val1b = rab - val1 val2b = rac - val2 val3b = rad - val3 val4b = rbc - val4 val5b = rbd - val5 val6b = rcd - val6 c c consider the tetrahedron (A,B,C,P_ABC) where P_ABC is the c point of intersection of the three spheres so that (A,B,C,P_ABC) c is counter-clockwise; the edge lengths for this tetrahedron are c rab, rac, rAP=ra, rbc, rBP=rb and rCP=rc c call tetra_3dihed_dcos (rab2,rac2,ra2,rbc2,rb2,rc2, & cosine_abc,deriv_abc,option) c c repeat the above for tetrahedron (A,B,D,P_ABD) c call tetra_3dihed_dcos (rab2,rad2,ra2,rbd2,rb2,rd2, & cosine_abd,deriv_abd,option) c c repeat the above for tetrahedron (A,C,D,P_ACD) c call tetra_3dihed_dcos (rac2,rad2,ra2,rcd2,rc2,rd2, & cosine_acd,deriv_acd,option) c c repeat the above for tetrahedron (B,C,D,P_BCD) c call tetra_3dihed_dcos (rbc2,rbd2,rb2,rcd2,rc2,rd2, & cosine_bcd,deriv_bcd,option) c cos_abc = cosine_abc(1) cos_acb = cosine_abc(2) cos_bca = cosine_abc(3) cos_abd = cosine_abd(1) cos_adb = cosine_abd(2) cos_bda = cosine_abd(3) cos_acd = cosine_acd(1) cos_adc = cosine_acd(2) cos_cda = cosine_acd(3) cos_bcd = cosine_bcd(1) cos_bdc = cosine_bcd(2) cos_cdb = cosine_bcd(3) rho_ab2 = ra2 - val1b*val1b rho_ac2 = ra2 - val2b*val2b rho_ad2 = ra2 - val3b*val3b rho_bc2 = rb2 - val4b*val4b rho_bd2 = rb2 - val5b*val5b rho_cd2 = rc2 - val6b*val6b eps = 1.0d-14 do i = 1, 6 if (abs(sin_ang(i)) < eps) then invsin(i) = 0.0d0; cotan(i) = 0.0d0; else invsin(i) = 1.0d0 / sin_ang(i) cotan(i) = cos_ang(i) * invsin(i) end if end do val_ab = -(cos_abc*cos_abc+cos_abd*cos_abd)*cotan(1) & + 2.0d0*cos_abc*cos_abd*invsin(1) val_ac = -(cos_acb*cos_acb+cos_acd*cos_acd)*cotan(2) & + 2.0d0*cos_acb*cos_acd*invsin(2) val_ad = -(cos_adb*cos_adb+cos_adc*cos_adc)*cotan(3) & + 2.0d0*cos_adb*cos_adc*invsin(3) val_bc = -(cos_bca*cos_bca+cos_bcd*cos_bcd)*cotan(4) & + 2.0d0*cos_bca*cos_bcd*invsin(4) val_bd = -(cos_bda*cos_bda+cos_bdc*cos_bdc)*cotan(5) & + 2.0d0*cos_bda*cos_bdc*invsin(5) val_cd = -(cos_cda*cos_cda+cos_cdb*cos_cdb)*cotan(6) & + 2.0d0*cos_cda*cos_cdb*invsin(6) cap_ab = rho_ab2 * val_ab cap_ac = rho_ac2 * val_ac cap_ad = rho_ad2 * val_ad cap_bc = rho_bc2 * val_bc cap_bd = rho_bd2 * val_bd cap_cd = rho_cd2 * val_cd vola = (val1b*cap_ab+val2b*cap_ac+val3b*cap_ad) / 6.0d0 volb = (val1*cap_ab+val4b*cap_bc+val5b*cap_bd) / 6.0d0 volc = (val2*cap_ac+val4*cap_bc+val6b*cap_cd) / 6.0d0 vold = (val3*cap_ad+val5*cap_bd+val6*cap_cd) / 6.0d0 if (option .ne. 1) return do i = 1, 6 dvola(i) = 0.0d0 dvolb(i) = 0.0d0 dvolc(i) = 0.0d0 dvold(i) = 0.0d0 end do teteps = 1.0d-5 call tetra_volume (rab2,rac2,rad2,rbc2,rbd2,rcd2,tetvol) if (tetvol .lt. teteps) return dist(1) = rab dist(2) = rac dist(3) = rad dist(4) = rbc dist(5) = rbd dist(6) = rcd dval1b = l1 dval2b = l2 dval3b = l3 dval4b = l4 dval5b = l5 dval6b = l6 dval1 = 1.0d0 - l1 dval2 = 1.0d0 - l2 dval3 = 1.0d0 - l3 dval4 = 1.0d0 - l4 dval5 = 1.0d0 - l5 dval6 = 1.0d0 - l6 drho_ab2 = -2.0d0 * dval1b * val1b drho_ac2 = -2.0d0 * dval2b * val2b drho_ad2 = -2.0d0 * dval3b * val3b drho_bc2 = -2.0d0 * dval4b * val4b drho_bd2 = -2.0d0 * dval5b * val5b drho_cd2 = -2.0d0 * dval6b * val6b c do i = 1, 6 do j = 1, 6 dcotan(i,j) = -deriv(i,j) * (1.0d0+cotan(i)*cotan(i)) dinvsin(i,j) = -deriv(i,j) * cotan(i) * invsin(i) end do end do val1_ab = cos_abc*cos_abc + cos_abd*cos_abd val2_ab = 2.0d0 * cos_abc * cos_abd dval1_ab(1) = 2.0d0 * (deriv_abc(1,1)*cos_abc & +deriv_abd(1,1)*cos_abd) dval1_ab(2) = 2.0d0 * deriv_abc(1,2) * cos_abc dval1_ab(3) = 2.0d0 * deriv_abd(1,2) * cos_abd dval1_ab(4) = 2.0d0 * deriv_abc(1,3) * cos_abc dval1_ab(5) = 2.0d0 * deriv_abd(1,3) * cos_abd dval1_ab(6) = 0.0d0 dval2_ab(1) = 2.0d0 * (deriv_abc(1,1)*cos_abd & +deriv_abd(1,1)*cos_abc) dval2_ab(2) = 2.0d0 * deriv_abc(1,2) * cos_abd dval2_ab(3) = 2.0d0 * deriv_abd(1,2) * cos_abc dval2_ab(4) = 2.0d0 * deriv_abc(1,3) * cos_abd dval2_ab(5) = 2.0d0 * deriv_abd(1,3) * cos_abc dval2_ab(6) = 0.0d0 c do i = 1, 6 dcap_ab(i) = -dval1_ab(i)*cotan(1) - val1_ab*dcotan(1,i) & + dval2_ab(i)*invsin(1) + val2_ab*dinvsin(1,i) dcap_ab(i) = 2.0d0 * dist(i) * rho_ab2 * dcap_ab(i) end do dcap_ab(1) = dcap_ab(1) + drho_ab2*val_ab val1_ac = cos_acb*cos_acb + cos_acd*cos_acd val2_ac = 2.0d0 * cos_acb * cos_acd dval1_ac(1) = 2.0d0 * deriv_abc(2,1) * cos_acb dval1_ac(2) = 2.0d0 * (deriv_abc(2,2)*cos_acb & +deriv_acd(1,1)*cos_acd) dval1_ac(3) = 2.0d0 * deriv_acd(1,2) * cos_acd dval1_ac(4) = 2.0d0 * deriv_abc(2,3) * cos_acb dval1_ac(5) = 0.0d0 dval1_ac(6) = 2.0d0 * deriv_acd(1,3) * cos_acd dval2_ac(1) = 2.0d0 * deriv_abc(2,1) * cos_acd dval2_ac(2) = 2.0d0 * (deriv_abc(2,2)*cos_acd & +deriv_acd(1,1)*cos_acb) dval2_ac(3) = 2.0d0 * deriv_acd(1,2) * cos_acb dval2_ac(4) = 2.0d0 * deriv_abc(2,3) * cos_acd dval2_ac(5) = 0.0d0 dval2_ac(6) = 2.0d0 * deriv_acd(1,3) * cos_acb c do i = 1, 6 dcap_ac(i) = -dval1_ac(i)*cotan(2) - val1_ac*dcotan(2,i) & + dval2_ac(i)*invsin(2) + val2_ac*dinvsin(2,i) dcap_ac(i) = 2.0d0 * dist(i) * rho_ac2 * dcap_ac(i) end do dcap_ac(2) = dcap_ac(2) + drho_ac2*val_ac val1_ad = cos_adb*cos_adb + cos_adc*cos_adc val2_ad = 2.0d0 * cos_adb * cos_adc dval1_ad(1) = 2.0d0 * deriv_abd(2,1) * cos_adb dval1_ad(2) = 2.0d0 * deriv_acd(2,1) * cos_adc dval1_ad(3) = 2.0d0 * (deriv_abd(2,2)*cos_adb & +deriv_acd(2,2)*cos_adc) dval1_ad(4) = 0.0d0 dval1_ad(5) = 2.0d0 * deriv_abd(2,3) * cos_adb dval1_ad(6) = 2.0d0 * deriv_acd(2,3) * cos_adc dval2_ad(1) = 2.0d0 * deriv_abd(2,1) * cos_adc dval2_ad(2) = 2.0d0 * deriv_acd(2,1) * cos_adb dval2_ad(3) = 2.0d0 * (deriv_abd(2,2)*cos_adc & +deriv_acd(2,2)*cos_adb) dval2_ad(4) = 0.0d0 dval2_ad(5) = 2.0d0 * deriv_abd(2,3) * cos_adc dval2_ad(6) = 2.0d0 * deriv_acd(2,3) * cos_adb c do i = 1, 6 dcap_ad(i) = -dval1_ad(i)*cotan(3) - val1_ad*dcotan(3,i) & + dval2_ad(i)*invsin(3) + val2_ad*dinvsin(3,i) dcap_ad(i) = 2.0d0 * dist(i) * rho_ad2 * dcap_ad(i) end do dcap_ad(3) = dcap_ad(3) + drho_ad2*val_ad val1_bc = cos_bca*cos_bca + cos_bcd*cos_bcd val2_bc = 2.0d0 * cos_bca * cos_bcd dval1_bc(1) = 2.0d0 * deriv_abc(3,1) * cos_bca dval1_bc(2) = 2.0d0 * deriv_abc(3,2) * cos_bca dval1_bc(3) = 0.0d0 dval1_bc(4) = 2.0d0 * (deriv_abc(3,3)*cos_bca & +deriv_bcd(1,1)*cos_bcd) dval1_bc(5) = 2.0d0 * deriv_bcd(1,2) * cos_bcd dval1_bc(6) = 2.0d0 * deriv_bcd(1,3) * cos_bcd dval2_bc(1) = 2.0d0 * deriv_abc(3,1) * cos_bcd dval2_bc(2) = 2.0d0 * deriv_abc(3,2) * cos_bcd dval2_bc(3) = 0.0d0 dval2_bc(4) = 2.0d0 * (deriv_abc(3,3)*cos_bcd & +deriv_bcd(1,1)*cos_bca) dval2_bc(5) = 2.0d0 * deriv_bcd(1,2) * cos_bca dval2_bc(6) = 2.0d0 * deriv_bcd(1,3) * cos_bca c do i = 1, 6 dcap_bc(i) = -dval1_bc(i)*cotan(4) - val1_bc*dcotan(4,i) & + dval2_bc(i)*invsin(4) + val2_bc*dinvsin(4,i) dcap_bc(i) = 2.0d0 * dist(i) * rho_bc2 * dcap_bc(i) end do dcap_bc(4) = dcap_bc(4) + drho_bc2*val_bc val1_bd = cos_bda*cos_bda + cos_bdc*cos_bdc val2_bd = 2.0d0 * cos_bda * cos_bdc dval1_bd(1) = 2.0d0*deriv_abd(3,1)*cos_bda dval1_bd(2) = 0.0d0 dval1_bd(3) = 2.0d0*deriv_abd(3,2)*cos_bda dval1_bd(4) = 2.0d0*deriv_bcd(2,1)*cos_bdc dval1_bd(5) = 2.0d0*(deriv_abd(3,3)*cos_bda & +deriv_bcd(2,2)*cos_bdc) dval1_bd(6) = 2.0d0*deriv_bcd(2,3)*cos_bdc dval2_bd(1) = 2.0d0*deriv_abd(3,1)*cos_bdc dval2_bd(2) = 0.0d0 dval2_bd(3) = 2.0d0*deriv_abd(3,2)*cos_bdc dval2_bd(4) = 2.0d0*deriv_bcd(2,1)*cos_bda dval2_bd(5) = 2.0d0*(deriv_abd(3,3)*cos_bdc & +deriv_bcd(2,2)*cos_bda) dval2_bd(6) = 2.0d0*deriv_bcd(2,3)*cos_bda c do i = 1, 6 dcap_bd(i) = -dval1_bd(i)*cotan(5) - val1_bd*dcotan(5,i) & + dval2_bd(i)*invsin(5) + val2_bd*dinvsin(5,i) dcap_bd(i) = 2.0d0 * dist(i) * rho_bd2 * dcap_bd(i) end do dcap_bd(5) = dcap_bd(5) + drho_bd2*val_bd val1_cd = cos_cda*cos_cda + cos_cdb*cos_cdb val2_cd = 2.0d0 * cos_cda * cos_cdb dval1_cd(1) = 0.0d0 dval1_cd(2) = 2.0d0 * deriv_acd(3,1) * cos_cda dval1_cd(3) = 2.0d0 * deriv_acd(3,2) * cos_cda dval1_cd(4) = 2.0d0 * deriv_bcd(3,1) * cos_cdb dval1_cd(5) = 2.0d0 * deriv_bcd(3,2) * cos_cdb dval1_cd(6) = 2.0d0 * (deriv_acd(3,3)*cos_cda & +deriv_bcd(3,3)*cos_cdb) dval2_cd(1) = 0.0d0 dval2_cd(2) = 2.0d0 * deriv_acd(3,1) * cos_cdb dval2_cd(3) = 2.0d0 * deriv_acd(3,2) * cos_cdb dval2_cd(4) = 2.0d0 * deriv_bcd(3,1) * cos_cda dval2_cd(5) = 2.0d0 * deriv_bcd(3,2) * cos_cda dval2_cd(6) = 2.0d0 * (deriv_acd(3,3)*cos_cdb & +deriv_bcd(3,3)*cos_cda) c do i = 1, 6 dcap_cd(i) = -dval1_cd(i)*cotan(6) - val1_cd*dcotan(6,i) & + dval2_cd(i)*invsin(6) + val2_cd*dinvsin(6,i) dcap_cd(i) = 2.0d0*dist(i)*rho_cd2*dcap_cd(i) end do dcap_cd(6) = dcap_cd(6) +drho_cd2*val_cd do i = 1, 6 dvola(i) = (val1b*dcap_ab(i) + val2b*dcap_ac(i) & + val3b*dcap_ad(i)) / 6.0d0 dvolb(i) = (val1*dcap_ab(i) + val4b*dcap_bc(i) & + val5b*dcap_bd(i)) / 6.0d0 dvolc(i) = (val2*dcap_ac(i) + val4*dcap_bc(i) & + val6b*dcap_cd(i)) / 6.0d0 dvold(i) = (val3*dcap_ad(i) + val5*dcap_bd(i) & + val6*dcap_cd(i)) / 6.0d0 end do dvola(1) = dvola(1) + dval1b*cap_ab/6.0d0 dvola(2) = dvola(2) + dval2b*cap_ac/6.0d0 dvola(3) = dvola(3) + dval3b*cap_ad/6.0d0 dvolb(1) = dvolb(1) + dval1*cap_ab/6.0d0 dvolb(4) = dvolb(4) + dval4b*cap_bc/6.0d0 dvolb(5) = dvolb(5) + dval5b*cap_bd/6.0d0 dvolc(2) = dvolc(2) + dval2*cap_ac/6.0d0 dvolc(4) = dvolc(4) + dval4*cap_bc/6.0d0 dvolc(6) = dvolc(6) + dval6b*cap_cd/6.0d0 dvold(3) = dvold(3) + dval3*cap_ad/6.0d0 dvold(5) = dvold(5) + dval5*cap_bd/6.0d0 dvold(6) = dvold(6) + dval6*cap_cd/6.0d0 return end c c c ################################################################ c ## ## c ## subroutine update_deriv -- update distance derivatives ## c ## ## c ################################################################ c c c "update_deriv" updates the derivatives of the surface or volume c with respect to distances, it takes into account the info from c three sphere/ball intersection c subroutine update_deriv (dsurf,dera,derb,derc,coefa,coefb, & coefc,coef,idx1,idx2,idx3) implicit none integer i,idx1,idx2,idx3 integer list(3) real*8 coefa,coefb,coefc,coef real*8 dera(3),derb(3),derc(3) real*8 dsurf(*) c c list(1) = idx1 list(2) = idx2 list(3) = idx3 do i = 1, 3 dsurf(list(i)) = dsurf(list(i)) & + coef*(coefa*dera(i)+coefb*derb(i) & +coefc*derc(i)) end do return end c c c ############################################################### c ## ## c ## subroutine tetra_dihed -- tetrahedron dihedral angles ## c ## ## c ############################################################### c c c "tetra_dihed" computes the six dihedral angles of a tetrahedron c from its edge lengths c c literature reference: c c L. Yang and Z. Zeng, "Constructing a Tetrahedron with Prescribed c Heights and Widths", in F. Botana and T. Recio, Proceedings of c ADG2006, 203-211 (2007) c c variables and parameters: c c angle dihedral angles as fraction of 2*pi c cosine cosine of the dihedral angles c sine sine of the dihedral angle c c the tetrahedron is defined by its vertices A1, A2, A3 and A4, c the edge between vertex Ai and Aj has length Rij c c if T1=(A2,A3,A4), T2=(A1,A3,A4), T3=(A1,A2,A4), T4=(A1,A2,A3), c the dihedral angle "angij" is between the faces Ti and Tj c c input is r12sq,r13sq,r14sq,r23sq,r24sq,r34sq, where r12sq is c the square of the distance between A1 and A2, etc. c c ang12 is the dihedral angle between (A2,A3,A4) and (A1,A3,A4), c and alpha12 is the dihedral angle around the edge A1A2, then c ang12=alpha34, ang13=alpha24, ang14=alpha23, ang23=alpha14, c ang24=alpha13 and ang34=alpha12 c c upon output the angles are in order: alpha12, alpha13, alpha14, c alpha23, alpha24, alpha34; the derivatives form a 6x6 matrix c c subroutine tetra_dihed (r12sq,r13sq,r14sq,r23sq,r24sq, & r34sq,angle,cosine,sine) use math implicit none integer i real*8 r12sq,r13sq,r14sq real*8 r23sq,r24sq,r34sq real*8 val1,val2,val3,val4 real*8 val123,val124,val134 real*8 val234,val213,val214 real*8 val314,val324,val312 real*8 det12,det13,det14 real*8 det23,det24,det34 real*8 cosine(6),sine(6),angle(6) real*8 minori(4) c c c the Cayley Menger matrix is defined as: c c M = ( 0 r12^2 r13^2 r14^2 1 ) c ( r12^2 0 r23^2 r24^2 1 ) c ( r13^2 r23^2 0 r34^2 1 ) c ( r14^2 r24^2 r34^2 0 1 ) c ( 1 1 1 1 0 ) c c find all minors M(i,i) as determinants of the Cayley-Menger c matrix with row i and column j removed c c these determinants are of the form: c c det = | 0 a b 1 | c | a 0 c 1 | c | b c 0 1 | c | 1 1 1 0 | c c then det = (c - a - b )^2 - 4ab c val234 = r34sq - r23sq - r24sq val134 = r34sq - r14sq - r13sq val124 = r24sq - r12sq - r14sq val123 = r23sq - r12sq - r13sq minori(1) = val234*val234 - 4.0d0*r23sq*r24sq minori(2) = val134*val134 - 4.0d0*r13sq*r14sq minori(3) = val124*val124 - 4.0d0*r12sq*r14sq minori(4) = val123*val123 - 4.0d0*r12sq*r13sq val4 = 1.0d0 / sqrt(-minori(1)) val3 = 1.0d0 / sqrt(-minori(2)) val2 = 1.0d0 / sqrt(-minori(3)) val1 = 1.0d0 / sqrt(-minori(4)) c c next compute all angles, as the cosine of the angle c c (-1)^(i+j) * det(Mij) c cos(i,j) = --------------------- c sqrt(M(i,i)*M(j,j)) c c where det(Mij) = M(i,j) is the determinant of the Cayley-Menger c matrix with row i and column j removed c det12 = -2.0d0*r12sq*val134 - val123*val124 det13 = -2.0d0*r13sq*val124 - val123*val134 det14 = -2.0d0*r14sq*val123 - val124*val134 val213 = r13sq -r12sq -r23sq val214 = r14sq -r12sq -r24sq val312 = r12sq -r13sq -r23sq val314 = r14sq -r13sq -r34sq val324 = r24sq -r23sq -r34sq det23 = -2.0d0*r23sq*val214 - val213*val234 det24 = -2.0d0*r24sq*val213 - val214*val234 det34 = -2.0d0*r34sq*val312 - val314*val324 cosine(1) = det12 * val1 * val2 cosine(2) = det13 * val1 * val3 cosine(3) = det14 * val2 * val3 cosine(4) = det23 * val1 * val4 cosine(5) = det24 * val2 * val4 cosine(6) = det34 * val3 * val4 do i = 1, 6 if (cosine(i) > 1.0d0) then cosine(i) = 1.0d0 else if (cosine(i) .lt. -1.0d0) then cosine(i) = -1.0d0 end if end do do i = 1, 6 angle(i) = acos(cosine(i)) sine(i) = sin(angle(i)) angle(i) = angle(i) / twopi end do c c surface area of the four faces of the tetrahedron c c surf_234 = sqrt(-minori(1)/16.0d0) c surf_134 = sqrt(-minori(2)/16.0d0) c surf_124 = sqrt(-minori(3)/16.0d0) c surf_123 = sqrt(-minori(4)/16.0d0) return end c c c ################################################################## c ## ## c ## subroutine tetra_3dihed_cos -- tetrahedron cosine values ## c ## ## c ################################################################## c c c "tetra_3dihed_cos" computes three of the six dihedral angles c of a tetrahedron from edge lengths, and outputs their cosines c c literature reference: c c L. Yang and Z. Zeng, "Constructing a Tetrahedron with Prescribed c Heights and Widths", in F. Botana and T. Recio, Proceedings of c ADG2006, 203-211 (2007) c c the tetrahedron is defined by its vertices A1, A2, A3 and A4, c the edge between vertex Ai and Aj has length Rij; here we only c need the dihedral angles around A1A2, A1A3 and A2A3 c c input is r12sq,r13sq,r14sq,r23sq,r24sq,r34sq, where r12sq is c the square of the distance between A1 and A2, etc.; output is c the cosine of the three dihedral angles c c subroutine tetra_3dihed_cos (r12sq,r13sq,r14sq,r23sq, & r24sq,r34sq,cosine) implicit none real*8 r12sq,r13sq,r14sq real*8 r23sq,r24sq,r34sq real*8 val1,val2,val3,val4 real*8 val123,val124,val134 real*8 val234,val213,val214 real*8 det12,det13,det23 real*8 cosine(3) real*8 minori(4) c c c the Cayley Menger matrix is defined as: c c M = ( 0 r12^2 r13^2 r14^2 1 ) c ( r12^2 0 r23^2 r24^2 1 ) c ( r13^2 r23^2 0 r34^2 1 ) c ( r14^2 r24^2 r34^2 0 1 ) c ( 1 1 1 1 0 ) c c find all minors M(i,i) as determinants of the Cayley-Menger c matrix with row i and column j removed c c these determinants are of the form: c c det = | 0 a b 1 | c | a 0 c 1 | c | b c 0 1 | c | 1 1 1 0 | c c then det = (c - a - b )^2 - 4ab c val234 = r34sq - r23sq - r24sq val134 = r34sq - r14sq - r13sq val124 = r24sq - r12sq - r14sq val123 = r23sq - r12sq - r13sq minori(1) = val234*val234 - 4.0d0*r23sq*r24sq minori(2) = val134*val134 - 4.0d0*r13sq*r14sq minori(3) = val124*val124 - 4.0d0*r12sq*r14sq minori(4) = val123*val123 - 4.0d0*r12sq*r13sq val4 = 1.0d0 / sqrt(-minori(1)) val3 = 1.0d0 / sqrt(-minori(2)) val2 = 1.0d0 / sqrt(-minori(3)) val1 = 1.0d0 / sqrt(-minori(4)) c c next compute all angles, as the cosine of the angle c c (-1)^(i+j) * det(Mij) c cos(i,j) = --------------------- c sqrt(M(i,i)*M(j,j)) c c where det(Mij) = M(i,j) is the determinant of the Cayley-Menger c matrix with row i and column j removed c det12 = -2.0d0*r12sq*val134 - val123*val124 det13 = -2.0d0*r13sq*val124 - val123*val134 val213 = r13sq - r12sq -r23sq val214 = r14sq - r12sq -r24sq det23 = -2.0d0*r23sq*val214 - val213*val234 cosine(1) = det12 * val1 * val2 cosine(2) = det13 * val1 * val3 cosine(3) = det23 * val1 * val4 return end c c c ################################################################# c ## ## c ## subroutine tetra_dihed_der -- tetrahedrn dihedral deriv ## c ## ## c ################################################################# c c c "tetra_dihed_der" finds the six dihedral angles of a tetrahedron c from its edge lengths as well as their derivatives with respect c to these edge lengths c c literature reference: c c L. Yang and Z. Zeng, "Constructing a Tetrahedron with Prescribed c Heights and Widths", in F. Botana and T. Recio, Proceedings of c ADG2006, 203-211 (2007) c c variables and parameters: c c angle dihedral angles as fraction of 2*pi c cosine cosine of the dihedral angles c sine sine of the dihedral angle c deriv derivatives of the dihedral angles with c respect to the edge lengths AB, AC and BC c c the tetrahedron is defined by its vertices A1, A2, A3 and A4, c the edge between vertex Ai and Aj has length Rij c c if T1=(A2,A3,A4), T2=(A1,A3,A4), T3=(A1,A2,A4), T4=(A1,A2,A3), c the dihedral angle "angij" is between the faces Ti and Tj c c if T1=(A2,A3,A4), T2=(A1,A3,A4), T3=(A1,A2,A4), T4=(A1,A2,A3), c the dihedral angle "angij" is between the faces Ti and Tj c c input is r12sq,r13sq,r14sq,r23sq,r24sq,r34sq, where r12sq is c the square of the distance between A1 and A2, etc. c c ang12 is the dihedral angle between (A2,A3,A4) and (A1,A3,A4), c and alpha12 is the dihedral angle around the edge A1A2, then c ang12=alpha34, ang13=alpha24, ang14=alpha23, ang23=alpha14, c ang24=alpha13 and ang34=alpha12 c c upon output the angles are in order: alpha12, alpha13, alpha14, c alpha23, alpha24, alpha34; the derivatives form a 6x6 matrix c c subroutine tetra_dihed_der (r12sq,r13sq,r14sq,r23sq,r24sq,r34sq, & angle,cosine,sine,deriv) use math implicit none integer i,j,k,m,jj real*8 r12sq,r13sq,r14sq real*8 r23sq,r24sq,r34sq real*8 val123,val124,val134 real*8 val234,val213,val214 real*8 val314,val324,val312 real*8 vala,val1,val2,val3 real*8 tetvol,teteps real*8 minori(4),val(4) real*8 cosine(6),sine(6),angle(6) real*8 det(6),deriv(6,6),dnum(6,6) real*8 dminori(4,6) c c c the Cayley Menger matrix is defined as: c c M = ( 0 r12^2 r13^2 r14^2 1 ) c ( r12^2 0 r23^2 r24^2 1 ) c ( r13^2 r23^2 0 r34^2 1 ) c ( r14^2 r24^2 r34^2 0 1 ) c ( 1 1 1 1 0 ) c c find all minors M(i,i) as determinants of the Cayley-Menger c matrix with row i and column j removed c c these determinants are of the form: c c det = | 0 a b 1 | c | a 0 c 1 | c | b c 0 1 | c | 1 1 1 0 | c c then det = (c - a - b )^2 - 4ab c val234 = r34sq - r23sq - r24sq val134 = r34sq - r14sq - r13sq val124 = r24sq - r12sq - r14sq val123 = r23sq - r12sq - r13sq minori(1) = val234*val234 - 4.0d0*r23sq*r24sq minori(2) = val134*val134 - 4.0d0*r13sq*r14sq minori(3) = val124*val124 - 4.0d0*r12sq*r14sq minori(4) = val123*val123 - 4.0d0*r12sq*r13sq val(1) = 1.0d0 / sqrt(-minori(1)) val(2) = 1.0d0 / sqrt(-minori(2)) val(3) = 1.0d0 / sqrt(-minori(3)) val(4) = 1.0d0 / sqrt(-minori(4)) c c next compute all angles, as the cosine of the angle c c (-1)^(i+j) * det(Mij) c cos(i,j) = --------------------- c sqrt(M(i,i)*M(j,j)) c c where det(Mij) = M(i,j) is the determinant of the Cayley-Menger c matrix with row i and column j removed c det(6) = -2.0d0*r12sq*val134 - val123*val124 det(5) = -2.0d0*r13sq*val124 - val123*val134 det(4) = -2.0d0*r14sq*val123 - val124*val134 val213 = r13sq -r12sq -r23sq val214 = r14sq -r12sq -r24sq val312 = r12sq -r13sq -r23sq val314 = r14sq -r13sq -r34sq val324 = r24sq -r23sq -r34sq det(3) = -2.0d0*r23sq*val214 - val213*val234 det(2) = -2.0d0*r24sq*val213 - val214*val234 det(1) = -2.0d0*r34sq*val312 - val314*val324 cosine(1) = det(6) * val(3) * val(4) cosine(2) = det(5) * val(2) * val(4) cosine(3) = det(4) * val(2) * val(3) cosine(4) = det(3) * val(1) * val(4) cosine(5) = det(2) * val(1) * val(3) cosine(6) = det(1) * val(1) * val(2) do i = 1, 6 if (cosine(i) > 1.0d0) then cosine(i) = 1.0d0 else if (cosine(i) .lt. -1.0d0) then cosine(i) = -1.0d0 end if end do do i = 1, 6 angle(i) = acos(cosine(i)) sine(i) = sin(angle(i)) angle(i) = angle(i) / twopi end do do i = 1, 6 do j = 1, 6 deriv(i,j) = 0.0d0 end do end do teteps = 1.0d-5 call tetra_volume (r12sq,r13sq,r14sq,r23sq,r24sq,r34sq,tetvol) if (tetvol .lt. teteps) return c c compute derivatives of angles with respect to edge lengths c c num(i,j) c cos(ang(i,j)) = ------------------- c sqrt(M(i,i)*M(j,j)) c c d(ang(i,j)) dnum(i,j) c ----------- sin(ang(i,j)) = -------------------------- c dr(a,b) sqrt(M(i,i)M(j,j)) dr(a,b) c c M(i,i)dM(j,j) + M(j,j)*dM(i,i) c - 0.5*num(i,j) ------------------------------- c M(i,i)M(j,j) sqrt(M(i,i)M(j,j)) c c which we can rewrite as: c c d(ang(i,j)) cosine(i,j) dnum(i,j) c ----------- sin(ang(i,j)) = ----------- --------- c dr(a,b) num(i,j) dr(a,b) c c dM(j,j) + dM(i,i)) c - 0.5*cosine(i,j) (-------- + --------) c M(j,j) M(i,i) c do i = 1, 6 do j = 1, 4 dminori(j,i) = 0.0d0 end do end do dminori(1,4) = -val234 - 2.0d0*r24sq dminori(1,5) = -val234 - 2.0d0*r23sq dminori(1,6) = val234 dminori(2,2) = -val134 - 2.0d0*r14sq dminori(2,3) = -val134 - 2.0d0*r13sq dminori(2,6) = val134 dminori(3,1) = -val124 - 2.0d0*r14sq dminori(3,3) = -val124 - 2.0d0*r12sq dminori(3,5) = val124 dminori(4,1) = -val123 - 2.0d0*r13sq dminori(4,2) = -val123 - 2.0d0*r12sq dminori(4,4) = val123 dnum(6,1) = -2.0d0*val134 + val123+val124 dnum(6,2) = 2.0d0*r12sq + val124 dnum(6,3) = 2.0d0*r12sq + val123 dnum(6,4) = -val124 dnum(6,5) = -val123 dnum(6,6) = -2.0d0 * r12sq dnum(5,1) = 2.0d0*r13sq + val134 dnum(5,2) = -2.0d0*val124 + val123 + val134 dnum(5,3) = 2.0d0*r13sq + val123 dnum(5,4) = -val134 dnum(5,5) = -2.0d0 * r13sq dnum(5,6) = -val123 dnum(4,1) = 2.0d0*r14sq + val134 dnum(4,2) = 2.0d0*r14sq + val124 dnum(4,3) = -2.0d0*val123 + val124 + val134 dnum(4,4) = -2.0d0 * r14sq dnum(4,5) = -val134 dnum(4,6) = -val124 dnum(3,1) = 2.0d0*r23sq + val234 dnum(3,2) = -val234 dnum(3,3) = -2.0d0 * r23sq dnum(3,4) = -2.0d0*val214 + val213 + val234 dnum(3,5) = 2.0d0*r23sq + val213 dnum(3,6) = -val213 dnum(2,1) = 2.0d0*r24sq + val234 dnum(2,2) = -2.0d0 * r24sq dnum(2,3) = -val234 dnum(2,4) = 2.0d0*r24sq + val214 dnum(2,5) = -2.0d0*val213 + val214 + val234 dnum(2,6) = -val214 dnum(1,1) = -2.0d0 * r34sq dnum(1,2) = 2.0d0*r34sq + val324 dnum(1,3) = -val324 dnum(1,4) = 2.0d0*r34sq + val314 dnum(1,5) = -val314 dnum(1,6) = -2.0d0*val312 + val314 + val324 k = 0 do i = 1, 3 do j = i+1, 4 k = k + 1 jj = 7 - k if (det(k) .ne. 0) then vala = cosine(jj) / sine(jj) val1 = -vala / det(k) val2 = vala / minori(j) val3 = vala / minori(i) do m = 1, 6 deriv(jj,m) = val1*dnum(k,m) + val2*dminori(j,m) & + val3*dminori(i,m) end do else vala = -val(i) * val(j) / sine(jj) do m = 1, 6 deriv(jj,m) = vala * dnum(k,m) end do end if end do end do return end c c c ################################################################# c ## ## c ## subroutine tetra_dihed_der3 -- tetrahedron angle derivs ## c ## ## c ################################################################# c c c "tetra_dihed_der3" computes the six dihedral angles of the c tetrahedron (A, B, C, D) from its edge lengths as well as the c derivatives with respect to the edge lengths AB, AC and BC c c literature reference: c c L. Yang and Z. Zeng, "Constructing a Tetrahedron with Prescribed c Heights and Widths", in F. Botana and T. Recio, Proceedings of c ADG2006, 203-211 (2007) c c variables and parameters: c c angle dihedral angles as fraction of 2*pi c cosine cosine of the dihedral angles c sine sine of the dihedral angle c deriv derivatives of the dihedral angles with c respect to the edge lengths AB, AC and BC c c the tetrahedron is defined by its vertices A1, A2, A3 and A4, c the edge between vertex Ai and Aj has length Rij c c if T1=(A2,A3,A4), T2=(A1,A3,A4), T3=(A1,A2,A4), T4=(A1,A2,A3), c the dihedral angle "angij" is between the faces Ti and Tj c c input is r12sq,r13sq,r14sq,r23sq,r24sq,r34sq, where r12sq is c the square of the distance between A1 and A2, etc. c c ang12 is the dihedral angle between (A2,A3,A4) and (A1,A3,A4), c and alpha12 is the dihedral angle around the edge A1A2, then c ang12=alpha34, ang13=alpha24, ang14=alpha23, ang23=alpha14, c ang24=alpha13 and ang34=alpha12 c c upon output the angles are in the order: alpha12, alpha13, c alpha14, alpha23, alpha24, alpha34 c c subroutine tetra_dihed_der3 (r12sq,r13sq,r14sq,r23sq,r24sq,r34sq, & angle,cosine,sine,deriv,option) use math implicit none integer i,j,k,m,jj,option real*8 r12sq,r13sq,r14sq real*8 r23sq,r24sq,r34sq real*8 val123,val124,val134 real*8 val234,val213,val214 real*8 val314,val324,val312 real*8 vala,val1,val2,val3 real*8 tetvol, teteps real*8 minori(4),val(4) real*8 cosine(6),sine(6),angle(6) real*8 det(6),deriv(6,3),dnum(6,3) real*8 dminori(4,3) c c c the Cayley Menger matrix is defined as: c c M = ( 0 r12^2 r13^2 r14^2 1 ) c ( r12^2 0 r23^2 r24^2 1 ) c ( r13^2 r23^2 0 r34^2 1 ) c ( r14^2 r24^2 r34^2 0 1 ) c ( 1 1 1 1 0 ) c c find all minors M(i,i) as determinants of the Cayley-Menger c matrix with row i and column j removed c c these determinants are of the form: c c det = | 0 a b 1 | c | a 0 c 1 | c | b c 0 1 | c | 1 1 1 0 | c c then det = (c - a - b )^2 - 4ab c val234 = r34sq - r23sq - r24sq val134 = r34sq - r14sq - r13sq val124 = r24sq - r12sq - r14sq val123 = r23sq - r12sq - r13sq minori(1) = val234*val234 - 4.0d0*r23sq*r24sq minori(2) = val134*val134 - 4.0d0*r13sq*r14sq minori(3) = val124*val124 - 4.0d0*r12sq*r14sq minori(4) = val123*val123 - 4.0d0*r12sq*r13sq val(1) = 1.0d0 / sqrt(-minori(1)) val(2) = 1.0d0 / sqrt(-minori(2)) val(3) = 1.0d0 / sqrt(-minori(3)) val(4) = 1.0d0 / sqrt(-minori(4)) c c next compute all angles, as the cosine of the angle c c (-1)^(i+j) * det(Mij) c cos(i,j) = --------------------- c sqrt(M(i,i)*M(j,j)) c c where det(Mij) = M(i,j) is the determinant of the Cayley-Menger c matrix with row i and column j removed c det(6) = -2.0d0*r12sq*val134 - val123*val124 det(5) = -2.0d0*r13sq*val124 - val123*val134 det(4) = -2.0d0*r14sq*val123 - val124*val134 val213 = r13sq - r12sq - r23sq val214 = r14sq - r12sq - r24sq val312 = r12sq - r13sq - r23sq val314 = r14sq - r13sq - r34sq val324 = r24sq - r23sq - r34sq det(3) = -2.0d0*r23sq*val214 - val213*val234 det(2) = -2.0d0*r24sq*val213 - val214*val234 det(1) = -2.0d0*r34sq*val312 - val314*val324 cosine(1) = det(6) * val(3) * val(4) cosine(2) = det(5) * val(2) * val(4) cosine(3) = det(4) * val(2) * val(3) cosine(4) = det(3) * val(1) * val(4) cosine(5) = det(2) * val(1) * val(3) cosine(6) = det(1) * val(1) * val(2) do i = 1, 6 if (cosine(i) > 1.0d0) then cosine(i) = 1.0d0 else if (cosine(i) .lt. -1.0d0) then cosine(i) = -1.0d0 end if end do do i = 1, 6 angle(i) = acos(cosine(i)) sine(i) = sin(angle(i)) angle(i) = angle(i) / twopi end do if (option .eq. 0) return do i = 1, 6 do j = 1, 3 deriv(i,j) = 0.0d0 end do end do teteps = 1.0d-5 call tetra_volume (r12sq,r13sq,r14sq,r23sq,r24sq,r34sq,tetvol) if (tetvol .lt. teteps) return c c compute derivatives of angles with respect to edge lengths c c num(i,j) c cos(ang(i,j)) = ------------------- c sqrt(M(i,i)*M(j,j)) c c d(ang(i,j)) dnum(i,j) c ----------- sin(ang(i,j)) = -------------------------- c dr(a,b) sqrt(M(i,i)M(j,j)) dr(a,b) c c M(i,i)dM(j,j) + M(j,j)*dM(i,i) c - 0.5*num(i,j) ------------------------------- c M(i,i)M(j,j) sqrt(M(i,i)M(j,j)) c c which we can rewrite as: c c d(ang(i,j)) cosine(i,j) dnum(i,j) c ----------- sin(ang(i,j)) = ----------- --------- c dr(a,b) num(i,j) dr(a,b) c c dM(j,j) + dM(i,i)) c - 0.5*cosine(i,j) (-------- + --------) c M(j,j) M(i,i) c do i = 1, 3 do j = 1, 4 dminori(j,i) = 0.0d0 end do end do dminori(1,3) = -val234 - 2.0d0*r24sq dminori(2,2) = -val134 - 2.0d0*r14sq dminori(3,1) = -val124 - 2.0d0*r14sq dminori(4,1) = -val123 - 2.0d0*r13sq dminori(4,2) = -val123 - 2.0d0*r12sq dminori(4,3) = val123 dnum(6,1) = -2.0d0*val134 + val123+val124 dnum(6,2) = 2.0d0*r12sq + val124 dnum(6,3) = -val124 dnum(5,1) = 2.0d0*r13sq + val134 dnum(5,2) = -2.0d0*val124 + val123 + val134 dnum(5,3) = -val134 dnum(4,1) = 2.0d0*r14sq + val134 dnum(4,2) = 2.0d0*r14sq + val124 dnum(4,3) = -2.0d0 * r14sq dnum(3,1) = 2.0d0*r23sq + val234 dnum(3,2) = -val234 dnum(3,3) = -2.0d0*val214 + val213 + val234 dnum(2,1) = 2.0d0*r24sq + val234 dnum(2,2) = -2.0d0 * r24sq dnum(2,3) = 2.0d0*r24sq + val214 dnum(1,1) = -2.0d0 * r34sq dnum(1,2) = 2.0d0*r34sq + val324 dnum(1,3) = 2.0d0*r34sq + val314 k = 0 do i = 1, 3 do j = i+1, 4 k = k + 1 jj = 7 - k if (det(k) .ne. 0) then vala = cosine(jj) / sine(jj) val1 = -vala / det(k) val2 = vala / minori(j) val3 = vala / minori(i) do m = 1, 3 deriv(jj,m) = val1*dnum(k,m) + val2*dminori(j,m) & + val3*dminori(i,m) end do else vala = -val(i) * val(j) / sine(jj) do m = 1, 3 deriv(jj,m) = vala * dnum(k,m) end do end if end do end do return end c c c ################################################################# c ## ## c ## subroutine tetra_3dihed_dcos -- tetrahedrn cosine deriv ## c ## ## c ################################################################# c c c "tetra_3dihed_dcos" computes three of the six dihedral angles c of a tetrahedron from its edge lengths, and outputs the cosines c c literature reference: c c L. Yang and Z. Zeng, "Constructing a Tetrahedron with Prescribed c Heights and Widths", in F. Botana and T. Recio, Proceedings of c ADG2006, 203-211 (2007) c c the tetrahedron is defined by its vertices A1, A2, A3 and A4, c the edge between vertex Ai and Aj has length Rij c c only need dihedral angles around A1A2, A1A3 and A2A3 c c variables and parameters: c c r12sq,r13sq,r14sq, distance squared between pairs of balls c r23sq,r24sq,r34sq c cosine cosine of the three dihedral angles c deriv derivatives of the cosines over the c AB, AC and BC distances c c subroutine tetra_3dihed_dcos (r12sq,r13sq,r14sq,r23sq,r24sq, & r34sq,cosine,deriv,option) implicit none integer i,j,option real*8 r12sq,r13sq,r14sq real*8 r23sq,r24sq,r34sq real*8 val1,val2,val3,val4 real*8 val123,val124,val134 real*8 val234,val213,val214 real*8 det12,det13,det23 real*8 cosine(3) real*8 minori(4) real*8 deriv(3,3) real*8 dminori(4,3) real*8 dnum(3,3) c c c the Cayley Menger matrix is defined as: c c M = ( 0 r12^2 r13^2 r14^2 1 ) c ( r12^2 0 r23^2 r24^2 1 ) c ( r13^2 r23^2 0 r34^2 1 ) c ( r14^2 r24^2 r34^2 0 1 ) c ( 1 1 1 1 0 ) c c find all minors M(i,i) as determinants of the Cayley-Menger c matrix with row i and column j removed c c these determinants are of the form: c c det = | 0 a b 1 | c | a 0 c 1 | c | b c 0 1 | c | 1 1 1 0 | c c then det = (c - a - b )^2 - 4ab c val234 = r34sq - r23sq - r24sq val134 = r34sq - r14sq - r13sq val124 = r24sq - r12sq - r14sq val123 = r23sq - r12sq - r13sq minori(1) = val234*val234 - 4.0d0*r23sq*r24sq minori(2) = val134*val134 - 4.0d0*r13sq*r14sq minori(3) = val124*val124 - 4.0d0*r12sq*r14sq minori(4) = val123*val123 - 4.0d0*r12sq*r13sq val4 = 1.0d0 / sqrt(-minori(1)) val3 = 1.0d0 / sqrt(-minori(2)) val2 = 1.0d0 / sqrt(-minori(3)) val1 = 1.0d0 / sqrt(-minori(4)) c c next compute all angles, as the cosine of the angle c c (-1)^(i+j) * det(Mij) c cos(i,j) = --------------------- c sqrt(M(i,i)*M(j,j)) c c where det(Mij) = M(i,j) is the determinant of the Cayley-Menger c matrix with row i and column j removed c det12 = -2.0d0*r12sq*val134 - val123*val124 det13 = -2.0d0*r13sq*val124 - val123*val134 val213 = r13sq -r12sq -r23sq val214 = r14sq -r12sq -r24sq det23 = -2.0d0*r23sq*val214 - val213*val234 cosine(1) = det12 * val1 * val2 cosine(2) = det13 * val1 * val3 cosine(3) = det23 * val1 * val4 if (option .eq. 0) return do i = 1, 3 do j = 1, 4 dminori(j,i) = 0.0d0 end do end do dminori(1,3) = -val234 - 2.0d0*r24sq dminori(2,2) = -val134 - 2.0d0*r14sq dminori(3,1) = -val124 - 2.0d0*r14sq dminori(4,1) = -val123 - 2.0d0*r13sq dminori(4,2) = -val123 - 2.0d0*r12sq dminori(4,3) = val123 dnum(1,1) = -2.0d0*val134 + val123+val124 dnum(1,2) = 2.0d0*r12sq + val124 dnum(1,3) = -val124 dnum(2,1) = 2.0d0*r13sq + val134 dnum(2,2) = -2.0d0*val124 + val123 + val134 dnum(2,3) = -val134 dnum(3,1) = 2.0d0*r23sq + val234 dnum(3,2) = -val234 dnum(3,3) = -2.0d0*val214 + val213 + val234 do i = 1, 3 deriv(1,i) = dnum(1,i)*val1*val2 - cosine(1)* & (dminori(3,i)/minori(3)+dminori(4,i)/minori(4)) deriv(2,i) = dnum(2,i)*val1*val3 - cosine(2)* & (dminori(2,i)/minori(2)+dminori(4,i)/minori(4)) deriv(3,i) = dnum(3,i)*val1*val4 - cosine(3)* & (dminori(1,i)/minori(1)+dminori(4,i)/minori(4)) end do return end c c c ################################################################ c ## ## c ## subroutine truncate_real -- truncate precision of real ## c ## ## c ################################################################ c c c "truncate_real" converts a real number to a given accuracy c with a specified number of digits after the decimal point) c c subroutine truncate_real(x_in,x_out,ndigit) implicit none integer i,mantissa integer ndigit integer digit(16) real*8 x_in,x_out,y real*8 fact c c mantissa = int(x_in) y = x_in - mantissa x_out = mantissa fact = 1 do i = 1, ndigit fact = fact * 10.0d0 digit(i) = nint(y*10.0d0) y = 10.0d0 * (y-digit(i)/10.0d0) x_out = x_out + digit(i)/fact end do return end c c c ############################################################## c ## ## c ## subroutine crossvect -- cross product of two vectors ## c ## ## c ############################################################## c c c "crossvect" computes the cross product of two vectors c c subroutine crossvect (u1,u2,u3) implicit none real*8 u1(3),u2(3),u3(3) c c u3(1) = u1(2)*u2(3) - u1(3)*u2(2) u3(2) = -u1(1)*u2(3) + u1(3)*u2(1) u3(3) = u1(1)*u2(2) - u1(2)*u2(1) return end c c c ########################################################## c ## ## c ## subroutine dotvect -- dot product of two vectors ## c ## ## c ########################################################## c c c dotvect" computes the dot product of two vectors c c subroutine dotvect (u1,u2,dot) implicit none integer i real*8 u1(3),u2(3),dot c c dot = 0.0d0 do i = 1, 3 dot = dot + u1(i)*u2(i) end do return end c c c ######################################################### c ## ## c ## subroutine normvect -- compute norm of a vector ## c ## ## c ######################################################### c c c "normvect" compute the norm length of a vector c c subroutine normvect (u1,norm) implicit none real*8 u1(3),norm c c call dotvect (u1,u1,norm) norm = sqrt(norm) return end c c c ############################################################### c ## ## c ## subroutine diffvect -- difference between two vectors ## c ## ## c ############################################################### c c c "diffvect" computes the difference between two vectors c c subroutine diffvect (u1,u2,u3) implicit none integer i real*8 u1(3),u2(3),u3(3) c c do i = 1, 3 u3(i) = u2(i) - u1(i) end do return end c c c ############################################################### c ## ## c ## subroutine minor5 -- find the sign of 5x5 determinant ## c ## ## c ############################################################### c c c "minor5" computes the value of a 5x5 determinant built from c coordinates of specified balls; if the determinant is zero, c then checks minors until a nonzero value is found c c subroutine minor5 (crdball,radball,a,b,c,d,e,result) implicit none integer a,b,c,d,e integer result integer isign integer ida1,ida2,ida3 integer idb1,idb2,idb3 integer idc1,idc2,idc3 integer idd1,idd2,idd3 integer ide1,ide2,ide3 real*8 det,psub,padd,t1,t2 real*8 r11,r21,r31,r41,r51 real*8 r12,r22,r32,r42,r52 real*8 r13,r23,r33,r43,r53 real*8 r14,r24,r34,r44,r54 real*8 rr1,rr2,rr3,rr4,rr5 real*8 crdball(*) real*8 radball(*) c c c get the value of the determinant and find its sign c ida1 = 3*a - 2 ida2 = ida1 + 1 ida3 = ida2 + 1 idb1 = 3*b - 2 idb2 = idb1 + 1 idb3 = idb2 + 1 idc1 = 3*c - 2 idc2 = idc1 + 1 idc3 = idc2 + 1 idd1 = 3*d - 2 idd2 = idd1 + 1 idd3 = idd2 + 1 ide1 = 3*e - 2 ide2 = ide1 + 1 ide3 = ide2 + 1 r11 = crdball(ida1) r12 = crdball(ida2) r13 = crdball(ida3) r21 = crdball(idb1) r22 = crdball(idb2) r23 = crdball(idb3) r31 = crdball(idc1) r32 = crdball(idc2) r33 = crdball(idc3) r41 = crdball(idd1) r42 = crdball(idd2) r43 = crdball(idd3) r51 = crdball(ide1) r52 = crdball(ide2) r53 = crdball(ide3) rr1 = radball(a) rr2 = radball(b) rr3 = radball(c) rr4 = radball(d) rr5 = radball(e) t1 = rr1 * rr1 t2 = r11 * r11 t1 = psub (t2,t1) t2 = r12 * r12 t1 = padd (t2,t1) t2 = r13 * r13 r14 = padd (t2,t1) t1 = rr2 * rr2 t2 = r21 * r21 t1 = psub (t2,t1) t2 = r22 * r22 t1 = padd (t2,t1) t2 = r23 * r23 r24 = padd (t2,t1) t1 = rr3 * rr3 t2 = r31 * r31 t1 = psub (t2,t1) t2 = r32 * r32 t1 = padd (t2,t1) t2 = r33 * r33 r34 = padd (t2,t1) t1 = rr4 * rr4 t2 = r41 * r41 t1 = psub (t2,t1) t2 = r42 * r42 t1 = padd (t2,t1) t2 = r43 * r43 r44 = padd (t2,t1) t1 = rr5 * rr5 t2 = r51 * r51 t1 = psub (t2,t1) t2 = r52 * r52 t1 = padd (t2,t1) t2 = r53 * r53 r54 = padd (t2,t1) result = 1 call deter5 (det,r11,r12,r13,r14,r21,r22,r23,r24,r31,r32, & r33,r34,r41,r42,r43,r44,r51,r52,r53,r54,isign) if (isign .ne. 0) then result = isign return end if c c check signs of minors if full determinant is zero c call deter4 (det,r21,r22,r23,r31,r32,r33, & r41,r42,r43,r51,r52,r53,isign) if (isign .ne. 0) then result = -isign return end if call deter4 (det,r21,r22,r24,r31,r32,r34, & r41,r42,r44,r51,r52,r54,isign) if (isign .ne. 0) then result = isign return end if call deter4 (det,r21,r23,r24,r31,r33,r34, & r41,r43,r44,r51,r53,r54,isign) if (isign .ne. 0) then result = -isign return end if call deter4 (det,r22,r23,r24,r32,r33,r34, & r42,r43,r44,r52,r53,r54,isign) if (isign .ne. 0) then result = isign return end if call deter4 (det,r11,r12,r13,r31,r32,r33, & r41,r42,r43,r51,r52,r53,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r31,r32,r41,r42,r51,r52,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r31,r33,r41,r43,r51,r53,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r32,r33,r42,r43,r52,r53,isign) if (isign .ne. 0) then result = isign return end if call deter4 (det,r11,r12,r14,r31,r32,r34, & r41,r42,r44,r51,r52,r54,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r31,r34,r41,r44,r51,r54,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r32,r34,r42,r44,r52,r54,isign) if (isign .ne. 0) then result = -isign return end if call deter4 (det,r11,r13,r14,r31,r33,r34, & r41,r43,r44,r51,r53,r54,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r33,r34,r43,r44,r53,r54,isign) if (isign .ne. 0) then result = isign return end if call deter4 (det,r12,r13,r14,r32,r33,r34, & r42,r43,r44,r52,r53,r54,isign) if (isign .ne. 0) then result = -isign return end if call deter4 (det,r11,r12,r13,r21,r22,r23, & r41,r42,r43,r51,r52,r53,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r21,r22,r41,r42,r51,r52,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r21,r23,r41,r43,r51,r53,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r22,r23,r42,r43,r52,r53,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r11,r12,r41,r42,r51,r52,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r41,r51,isign) if (isign .ne. 0) then result = -isign return end if call deter2 (det,r42,r52,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r11,r13,r41,r43,r51,r53,isign) if (isign .ne. 0) then result = -isign return end if call deter2 (det,r43,r53,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r12,r13,r42,r43,r52,r53,isign) if (isign .ne. 0) then result = isign return end if call deter4 (det,r11,r12,r14,r21,r22,r24, & r41,r42,r44,r51,r52,r54,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r21,r24,r41,r44,r51,r54,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r22,r24,r42,r44,r52,r54,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r11,r14,r41,r44,r51,r54,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r44,r54,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r12,r14,r42,r44,r52,r54,isign) if (isign .ne. 0) then result = -isign return end if call deter4 (det,r11,r13,r14,r21,r23,r24, & r41,r43,r44,r51,r53,r54,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r23,r24,r43,r44,r53,r54,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r13,r14,r43,r44,r53,r54,isign) if (isign .ne. 0) then result = isign return end if call deter4 (det,r12,r13,r14,r22,r23,r24, & r42,r43,r44,r52,r53,r54,isign) if (isign .ne. 0) then result = isign return end if call deter4 (det,r11,r12,r13,r21,r22,r23, & r31,r32,r33,r51,r52,r53,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r21,r22,r31,r32,r51,r52,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r21,r23,r31,r33,r51,r53,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r22,r23,r32,r33,r52,r53,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r11,r12,r31,r32,r51,r52,isign) if (isign .ne. 0) then result = -isign return end if call deter2 (det,r31,r51,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r32,r52,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r11,r13,r31,r33,r51,r53,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r33,r53,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r12,r13,r32,r33,r52,r53,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r11,r12,r21,r22,r51,r52,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r21,r51,isign) if (isign .ne. 0) then result = -isign return end if call deter2 (det,r22,r52,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r11,r51,isign) if (isign .ne. 0) then result = isign return end if return end c c c ############################################################### c ## ## c ## subroutine deter5 -- get the value of 5x5 determinant ## c ## ## c ############################################################### c c c "deter5" finds a 5x5 determinant value where the rightmost c column is all ones and other elements are given as arguments c c subroutine deter5 (det,r11,r12,r13,r14,r21,r22,r23,r24,r31,r32, & r33,r34,r41,r42,r43,r44,r51,r52,r53,r54,isign) implicit none integer isign real*8 det,psub,padd real*8 r11,r21,r31,r41,r51 real*8 r12,r22,r32,r42,r52 real*8 r13,r23,r33,r43,r53 real*8 r14,r24,r34,r44,r54 real*8 s11,s21,s31,s41 real*8 s12,s22,s32,s42 real*8 s13,s23,s33,s43 real*8 s14,s24,s34,s44 real*8 t1,t2,t3 real*8 u1,u2,u3 real*8 v1,v2,v3 real*8 w1,w2,w3 real*8 x1,x2,x3 real*8 eps c c c compute the numerical value of the determinant c s11 = psub (r21,r11) s12 = psub (r22,r12) s13 = psub (r23,r13) s14 = psub (r24,r14) s21 = psub (r31,r11) s22 = psub (r32,r12) s23 = psub (r33,r13) s24 = psub (r34,r14) s31 = psub (r41,r11) s32 = psub (r42,r12) s33 = psub (r43,r13) s34 = psub (r44,r14) s41 = psub (r51,r11) s42 = psub (r52,r12) s43 = psub (r53,r13) s44 = psub (r54,r14) t1 = s32 * s43 t2 = s42 * s33 u1 = psub (t1,t2) t1 = s32 * s44 t2 = s42 * s34 u2 = psub (t1,t2) t1 = s33 * s44 t2 = s43 * s34 u3 = psub (t1,t2) t1 = s12 * s23 t2 = s22 * s13 v1 = psub (t1,t2) t1 = s12 * s24 t2 = s22 * s14 v2 = psub (t1,t2) t1 = s13 * s24 t2 = s23 * s14 v3 = psub (t1,t2) t1 = s11 * s24 t2 = s21 * s14 w1 = psub (t1,t2) t1 = s11 * s23 t2 = s21 * s13 w2 = psub (t1,t2) t1 = s11 * s22 t2 = s21 * s12 w3 = psub (t1,t2) t1 = s31 * s44 t2 = s41 * s34 x1 = psub (t1,t2) t1 = s31 * s43 t2 = s41 * s33 x2 = psub (t1,t2) t1 = s31 * s42 t2 = s41 * s32 x3 = psub (t1,t2) t1 = v3 * x3 t2 = v2 * x2 t3 = psub (t1,t2) t1 = v1 * x1 t3 = padd (t3,t1) t1 = u3 * w3 t3 = padd (t3,t1) t1 = u2 * w2 t3 = psub (t3,t1) t1 = u1 * w1 det = padd (t3,t1) eps = 1.0d-10 if (abs(det) .lt. eps) det = 0.0d0 c c return value based on sign of the determinant c isign = 0 if (det .gt. 0.0d0) then isign = 1 else if (det .lt. 0.0d0) then isign = -1 end if return end c c c ############################################################### c ## ## c ## subroutine minor4 -- find the sign of 4x4 determinant ## c ## ## c ############################################################### c c c "minor4" computes the value of a 4x4 determinant built from c coordinates of specified balls; if the determinant is zero, c then checks minors until a nonzero value is found c c subroutine minor4 (crdball,a,b,c,d,result) implicit none integer a,b,c,d integer result integer isign integer ida1,ida2,ida3 integer idb1,idb2,idb3 integer idc1,idc2,idc3 integer idd1,idd2,idd3 real*8 det real*8 r11,r21,r31,r41 real*8 r12,r22,r32,r42 real*8 r13,r23,r33,r43 real*8 crdball(*) c c c get the value of the determinant and find its sign c ida1 = 3*a - 2 ida2 = ida1 + 1 ida3 = ida2 + 1 idb1 = 3*b - 2 idb2 = idb1 + 1 idb3 = idb2 + 1 idc1 = 3*c - 2 idc2 = idc1 + 1 idc3 = idc2 + 1 idd1 = 3*d - 2 idd2 = idd1 + 1 idd3 = idd2 + 1 r11 = crdball(ida1) r12 = crdball(ida2) r13 = crdball(ida3) r21 = crdball(idb1) r22 = crdball(idb2) r23 = crdball(idb3) r31 = crdball(idc1) r32 = crdball(idc2) r33 = crdball(idc3) r41 = crdball(idd1) r42 = crdball(idd2) r43 = crdball(idd3) result = 1 call deter4 (det,r11,r12,r13,r21,r22,r23, & r31,r32,r33,r41,r42,r43,isign) if (isign .ne. 0) then result = isign return end if c c check signs of minors if full determinant is zero c call deter3 (det,r21,r22,r31,r32,r41,r42,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r21,r23,r31,r33,r41,r43,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r22,r23,r32,r33,r42,r43,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r11,r12,r31,r32,r41,r42,isign) if (isign .ne. 0) then result = -isign return end if call deter2 (det,r31,r41,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r32,r42,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r11,r13,r31,r33,r41,r43,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r33,r43,isign) if (isign .ne. 0) then result = isign return end if call deter3 (det,r12,r13,r32,r33,r42,r43,isign) if (isign .ne. 0) then result = -isign return end if call deter3 (det,r11,r12,r21,r22,r41,r42,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r21,r41,isign) if (isign .ne. 0) then result = -isign return end if call deter2 (det,r22,r42,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r11,r41,isign) if (isign .ne. 0) then result = isign return end if return end c c c ################################################################# c ## ## c ## subroutine minor4x -- find 4x4 determinant sign; no SOS ## c ## ## c ################################################################# c c c "minor4x" computes the value of a 4x4 determinant built from c coordinates of specified balls and also finds the sign c c subroutine minor4x (crdball,a,b,c,d,result) implicit none integer a,b,c,d integer result integer isign integer ida1,ida2,ida3 integer idb1,idb2,idb3 integer idc1,idc2,idc3 integer idd1,idd2,idd3 real*8 det real*8 r11,r21,r31,r41 real*8 r12,r22,r32,r42 real*8 r13,r23,r33,r43 real*8 crdball(*) c c c get the value of the determinant and find its sign c ida1 = 3*a - 2 ida2 = ida1 + 1 ida3 = ida2 + 1 idb1 = 3*b - 2 idb2 = idb1 + 1 idb3 = idb2 + 1 idc1 = 3*c - 2 idc2 = idc1 + 1 idc3 = idc2 + 1 idd1 = 3*d - 2 idd2 = idd1 + 1 idd3 = idd2 + 1 r11 = crdball(ida1) r12 = crdball(ida2) r13 = crdball(ida3) r21 = crdball(idb1) r22 = crdball(idb2) r23 = crdball(idb3) r31 = crdball(idc1) r32 = crdball(idc2) r33 = crdball(idc3) r41 = crdball(idd1) r42 = crdball(idd2) r43 = crdball(idd3) call deter4 (det,r11,r12,r13,r21,r22,r23, & r31,r32,r33,r41,r42,r43,isign) result = isign return end c c c ############################################################### c ## ## c ## subroutine deter4 -- get the value of 4x4 determinant ## c ## ## c ############################################################### c c c "deter4" finds a 4x4 determinant value where the rightmost c column is all ones and other elements are given as arguments c c subroutine deter4 (det,r11,r12,r13,r21,r22,r23, & r31,r32,r33,r41,r42,r43,isign) implicit none integer isign real*8 det,psub,padd real*8 r11,r21,r31,r41 real*8 r12,r22,r32,r42 real*8 r13,r23,r33,r43 real*8 s11,s21,s31 real*8 s12,s22,s32 real*8 s13,s23,s33 real*8 t1,t2,t3 real*8 u1,u2,u3 real*8 eps c c c compute the numerical value of the determinant c s11 = psub (r21,r11) s12 = psub (r22,r12) s13 = psub (r23,r13) s21 = psub (r31,r11) s22 = psub (r32,r12) s23 = psub (r33,r13) s31 = psub (r41,r11) s32 = psub (r42,r12) s33 = psub (r43,r13) t1 = s22 * s33 t2 = s32 * s23 u1 = psub (t1,t2) t1 = s12 * s33 t2 = s32 * s13 u2 = psub (t1,t2) t1 = s12 * s23 t2 = s22 * s13 u3 = psub (t1,t2) t1 = s21 * u2 t2 = s11 * u1 t3 = s31 * u3 u1 = padd (t2,t3) det = psub (t1,u1) eps = 1.0d-10 if (abs(det) .lt. eps) det = 0.0d0 c c return value based on sign of the determinant c isign = 0 if (det .gt. 0.0d0) then isign = 1 else if (det .lt. 0.0d0) then isign = -1 end if return end c c c ############################################################### c ## ## c ## subroutine minor3 -- find the sign of 3x3 determinant ## c ## ## c ############################################################### c c c "minor3" computes the value of a 3x3 determinant built from c coordinates of specified balls; if the determinant is zero, c then checks minors until a nonzero value is found c c subroutine minor3 (crdball,a,b,c,i1,i2,result) implicit none integer a,b,c integer i1,i2 integer result integer isign integer ida1,ida2 integer idb1,idb2 integer idc1,idc2 real*8 det real*8 r11,r21,r31 real*8 r12,r22,r32 real*8 crdball(*) c c c get the value of the determinant and find its sign c ida1 = 3*a + i1 - 3 ida2 = 3*a + i2 - 3 idb1 = 3*b + i1 - 3 idb2 = 3*b + i2 - 3 idc1 = 3*c + i1 - 3 idc2 = 3*c + i2 - 3 r11 = crdball(ida1) r12 = crdball(ida2) r21 = crdball(idb1) r22 = crdball(idb2) r31 = crdball(idc1) r32 = crdball(idc2) result = 1 call deter3 (det,r11,r12,r21,r22,r31,r32,isign) if (isign .ne. 0) then result = isign return end if c c check signs of minors if full determinant is zero c call deter2 (det,r21,r31,isign) if (isign .ne. 0) then result = -isign return end if call deter2 (det,r22,r32,isign) if (isign .ne. 0) then result = isign return end if call deter2 (det,r11,r31,isign) if (isign .ne. 0) then result = isign return end if return end c c c ############################################################### c ## ## c ## subroutine deter3 -- get the value of 3x3 determinant ## c ## ## c ############################################################### c c c "deter3" finds a 3x3 determinant value where the rightmost c column is all ones and other elements are given as arguments c c subroutine deter3 (det,r11,r12,r21,r22,r31,r32,isign) implicit none integer isign real*8 det,psub real*8 r11,r21,r31 real*8 r12,r22,r32 real*8 t1,t2,t3,t4 real*8 t14,t23 real*8 eps c c c compute the numerical value of the determinant c t1 = psub (r21,r11) t2 = psub (r22,r12) t3 = psub (r31,r11) t4 = psub (r32,r12) t14 = t1 * t4 t23 = t2 * t3 det = psub (t14,t23) eps = 1.0d-10 if (abs(det) .lt. eps) det = 0.0d0 c c return value based on sign of the determinant c isign = 0 if (det .gt. 0.0d0) then isign = 1 else if (det .lt. 0.0d0) then isign = -1 end if return end c c c ############################################################### c ## ## c ## subroutine minor2 -- find the sign of 2x2 determinant ## c ## ## c ############################################################### c c c "minor2" computes the value of a 2x2 determinant built from c coordinates of specified balls, and also return the sign c c subroutine minor2 (crdball,a,b,ia,result) implicit none integer a,b,ia integer result integer isign integer ida,idb real*8 det,r11,r12 real*8 crdball(*) c c c get the value of the determinant and find its sign c ida = 3*a + ia - 3 idb = 3*b + ia - 3 r11 = crdball(ida) r12 = crdball(idb) result = 1 call deter2 (det,r11,r12,isign) if (isign .ne. 0) result = isign return end c c c ############################################################### c ## ## c ## subroutine deter2 -- get the value of 2x2 determinant ## c ## ## c ############################################################### c c c "deter2" finds a 2x2 determinant value where the rightmost c column is all ones and other elements are given as arguments c c subroutine deter2 (det,r11,r12,isign) implicit none integer isign real*8 det,psub real*8 r11,r12 real*8 eps c c c compute the numerical value of the determinant c det = psub (r11,r12) eps = 1.0d-10 if (abs(det) .lt. eps) det = 0.0d0 c c set return based on sign of the determinant c isign = 0 if (det .gt. 0.0d0) then isign = 1 else if (det .lt. 0.0d0) then isign = -1 end if return end c c c ########################################################## c ## ## c ## function padd -- addition with a precision check ## c ## ## c ########################################################## c c c "padd" computes the sum of the two input arguments, and c sets the result to zero if the absolute sum or relative c values are less than the machine precision c c function padd (r1,r2) implicit none real*8 padd real*8 r1,r2,eps real*8 val,valmax c c c get the sum of input values using standard math c val = r1 + r2 c c round small absolute sum or relative value to zero c eps = 1.0d-14 if (abs(val) .lt. eps) then val = 0.0d0 else valmax = max(abs(r1),abs(r2)) if (valmax .ne. 0.0d0) then if (abs(val/valmax) .lt. eps) val = 0.0d0 end if end if padd = val return end c c c ############################################################# c ## ## c ## function psub -- subtraction with a precision check ## c ## ## c ############################################################# c c c "psub" computes the difference of the two input arguments, c and sets the result to zero if the absolute difference or c relative values are less than the machine precision c c function psub (r1,r2) implicit none real*8 psub real*8 r1,r2,eps real*8 val,valmax c c c get difference of input values using standard math c val = r1 - r2 c c round small absolute or relative difference to zero c eps = 1.0d-14 if (abs(val) .lt. eps) then val = 0.0d0 else valmax = max(abs(r1),abs(r2)) if (valmax .ne. 0.0d0) then if (abs(val/valmax) .lt. eps) val = 0.0d0 end if end if psub = val return end c c c ############################################################## c ## ## c ## subroutine build_weight -- build weight for Delaunay ## c ## ## c ############################################################## c c c "build_weight" builds and returns the weight for the weighted c Delaunay triangulation procedure c c subroutine build_weight (x,y,z,r,w) implicit none integer*8 ival1,ival2 real*8 x,y,z,r,w c c c compute the weight for the Delaunay triangulation c ival1 = nint(10000.0d0*r) ival2 = -ival1 * ival1 ival1 = nint(10000.0d0*x) ival2 = ival2 + ival1*ival1 ival1 = nint(10000.0d0*y) ival2 = ival2 + ival1*ival1 ival1 = nint(10000.0d0*z) ival2 = ival2 + ival1*ival1 w = dble(ival2) / 100000000.0d0 return end c c c ################################################################ c ## ## c ## subroutine addbogus -- add artificial points if needed ## c ## ## c ################################################################ c c c "addbogus" adds artificial points to the system so the total c number of vertices is at least equal to four c c subroutine addbogus (bcoord,brad) use shapes implicit none integer np integer i real*8 brad(3),bcoord(9) real*8 cx,cy,cz real*8 c1x,c1y,c1z real*8 c2x,c2y,c2z real*8 c3x,c3y,c3z real*8 u1x,u1y,u1z real*8 v1x,v1y,v1z real*8 w1x,w1y,w1z real*8 c32x,c32y,c32z real*8 rmax,d,d1,d2,d3 c c c set number of points to be added c np = 4 - npoint c c initialize the artificial coordinates c do i = 1, 3*np bcoord(i) = 0.0d0 end do c c case for one atom c if (npoint .eq. 1) then rmax = radball(1) bcoord(1) = crdball(1) + 3.0d0*rmax bcoord(3*1+2) = crdball(2) + 3.0d0*rmax bcoord(3*2+3) = crdball(3) + 3.0d0*rmax do i = 1, np brad(i) = rmax / 20.0d0 end do c c case for two atoms c else if (npoint .eq. 2) then rmax = max(radball(1),radball(2)) c1x = crdball(1) c1y = crdball(2) c1z = crdball(3) c2x = crdball(4) c2y = crdball(5) c2z = crdball(6) cx = 0.5d0 * (c1x+c2x) cy = 0.5d0 * (c1y+c2y) cz = 0.5d0 * (c1z+c2z) u1x = c2x - c1x u1y = c2y - c1y u1z = c2z - c1z if (u1z.ne.0.0d0 .or. u1x.ne.-u1y) then v1x = u1z v1y = u1z v1z = -u1x - u1z else v1x = -u1y - u1z v1y = u1x v1z = u1x end if w1x = u1y*v1z - u1z*v1y w1y = u1z*v1x - u1x*v1z w1z = u1x*v1y - u1y*v1x d = sqrt(u1x*u1x + u1y*u1y + u1z*u1z) bcoord(1) = cx + (2.0d0*d+3.0d0*rmax)*v1x bcoord(1+3) = cx + (2.0d0*d+3.0d0*rmax)*w1x bcoord(2) = cy + (2.0d0*d+3.0d0*rmax)*v1y bcoord(2+3) = cy + (2.0d0*d+3.0d0*rmax)*w1y bcoord(3) = cz + (2.0d0*d+3.0d0*rmax)*v1z bcoord(3+3) = cz + (2.0d0*d+3.0d0*rmax)*w1z brad(1) = rmax / 20.0d0 brad(2) = rmax / 20.0d0 c c case for three atoms c else if (npoint .eq. 3) then rmax = max(max(radball(1),radball(2)),radball(3)) c1x = crdball(1) c1y = crdball(2) c1z = crdball(3) c2x = crdball(4) c2y = crdball(5) c2z = crdball(6) c3x = crdball(7) c3y = crdball(8) c3z = crdball(9) cx = (c1x+c2x+c3x) / 3.0d0 cy = (c1y+c2y+c3y) / 3.0d0 cz = (c1z+c2z+c3z) / 3.0d0 u1x = c2x - c1x u1y = c2y - c1y u1z = c2z - c1z v1x = c3x - c1x v1y = c3y - c1y v1z = c3z - c1z w1x = u1y*v1z - u1z*v1y w1y = u1z*v1x - u1x*v1z w1z = u1x*v1y - u1y*v1x d1 = sqrt(w1x*w1x + w1y*w1y + w1z*w1z) if (d1 .eq. 0.0d0) then if (u1x .ne. 0.0d0) then w1x = u1y w1y = -u1x w1z = 0.0d0 else if (u1y .ne. 0.0d0) then w1x = u1y w1y = -u1x w1z = 0.0d0 else w1x = u1z w1y = -u1z w1z = 0.0d0 end if end if d1 = sqrt(u1x*u1x + u1y*u1y + u1z*u1z) d2 = sqrt(v1x*v1x + v1y*v1y + v1z*v1z) c32x = c3x - c2x c32y = c3y - c2y c32z = c3z - c2z d3 = sqrt(c32x*c32x + c32y*c32y + c32z*c32z) d = max(d1,max(d2,d3)) bcoord(1) = cx + (2.0d0*d+3.0d0*rmax)*w1x bcoord(2) = cy + (2.0d0*d+3.0d0*rmax)*w1y bcoord(3) = cz + (2.0d0*d+3.0d0*rmax)*w1z brad(1) = rmax / 20.0d0 end if return end c c c ################################################################## c ## ## c ## subroutine tetra_volume -- compute volume of tetrahedron ## c ## ## c ################################################################## c c c "tetra_volume" computes the volume of the tetrahedron c c subroutine tetra_volume (r12sq,r13sq,r14sq,r23sq,r24sq,r34sq,vol) implicit none real*8 val1,val2,val3 real*8 r12sq,r13sq,r14sq real*8 r23sq,r24sq,r34sq real*8 det5,vol real*8 mat5(5,5) c c c set the values of the matrix elements c mat5(1,1) = 0.0d0 mat5(1,2) = r12sq mat5(1,3) = r13sq mat5(1,4) = r14sq mat5(1,5) = 1.0d0 mat5(2,1) = r12sq mat5(2,2) = 0.0d0 mat5(2,3) = r23sq mat5(2,4) = r24sq mat5(2,5) = 1.0d0 mat5(3,1) = r13sq mat5(3,2) = r23sq mat5(3,3) = 0.0d0 mat5(3,4) = r34sq mat5(3,5) = 1.0d0 mat5(4,1) = r14sq mat5(4,2) = r24sq mat5(4,3) = r34sq mat5(4,4) = 0.0d0 mat5(4,5) = 1.0d0 mat5(5,1) = 1.0d0 mat5(5,2) = 1.0d0 mat5(5,3) = 1.0d0 mat5(5,4) = 1.0d0 mat5(5,5) = 0.0d0 c c compute the value of the determinant c val1 = mat5(2,3) - mat5(1,2) - mat5(1,3) val2 = mat5(2,4) - mat5(1,2) - mat5(1,4) val3 = mat5(3,4) - mat5(1,3) - mat5(1,4) det5 = 8.0d0*mat5(1,2)*mat5(1,3)*mat5(1,4) & - 2.0d0*val1*val2*val3 - 2.0d0*mat5(1,2)*val3*val3 & - 2.0d0*mat5(1,3)*val2*val2 - 2.0d0*mat5(1,4)*val1*val1 if (det5 .lt. 0.0d0) det5 = 0.0d0 vol = sqrt(det5/288.0d0); return end c c c ################################################### c ## COPYRIGHT (C) 1993 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## subroutine unitcell -- get periodic boundary conditions ## c ## ## c ################################################################# c c c "unitcell" gets the periodic boundary box size and related c values from an external keyword file c c subroutine unitcell use bound use boxes use keys use math implicit none integer i,next real*8 boxmax character*20 keyword character*240 record character*240 string c c c set the default values for periodic boundary conditions c use_bounds = .false. use_replica = .false. c c set the default values for the unit cell variables c orthogonal = .false. monoclinic = .false. triclinic = .false. octahedron = .false. dodecadron = .false. nonprism = .false. nosymm = .false. spacegrp = ' ' c c get keywords containing crystal lattice dimensions c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:7) .eq. 'X-AXIS ') then if (xbox .eq. 0.0d0) read (string,*,err=10,end=10) xbox else if (keyword(1:7) .eq. 'Y-AXIS ') then if (ybox .eq. 0.0d0) read (string,*,err=10,end=10) ybox else if (keyword(1:7) .eq. 'Z-AXIS ') then if (zbox .eq. 0.0d0) read (string,*,err=10,end=10) zbox else if (keyword(1:7) .eq. 'A-AXIS ') then if (xbox .eq. 0.0d0) read (string,*,err=10,end=10) xbox else if (keyword(1:7) .eq. 'B-AXIS ') then if (ybox .eq. 0.0d0) read (string,*,err=10,end=10) ybox else if (keyword(1:7) .eq. 'C-AXIS ') then if (zbox .eq. 0.0d0) read (string,*,err=10,end=10) zbox else if (keyword(1:6) .eq. 'ALPHA ') then if (alpha .eq. 0.0d0) read (string,*,err=10,end=10) alpha else if (keyword(1:5) .eq. 'BETA ') then if (beta .eq. 0.0d0) read (string,*,err=10,end=10) beta else if (keyword(1:6) .eq. 'GAMMA ') then if (gamma .eq. 0.0d0) read (string,*,err=10,end=10) gamma else if (keyword(1:11) .eq. 'OCTAHEDRON ') then octahedron = .true. else if (keyword(1:13) .eq. 'DODECAHEDRON ') then dodecadron = .true. else if (keyword(1:11) .eq. 'NOSYMMETRY ') then nosymm = .true. else if (keyword(1:11) .eq. 'SPACEGROUP ') then call getword (record,spacegrp,next) end if 10 continue end do c c use periodic boundary conditions if a cell was defined c boxmax = max(xbox,ybox,zbox) if (boxmax .ne. 0.0d0) use_bounds = .true. c c set unspecified periodic boundary box lengths and angles c if (use_bounds) then if (xbox .eq. 0.0d0) xbox = boxmax if (ybox .eq. 0.0d0) ybox = boxmax if (zbox .eq. 0.0d0) zbox = boxmax if (alpha .eq. 0.0d0) alpha = 90.0d0 if (beta .eq. 0.0d0) beta = 90.0d0 if (gamma .eq. 0.0d0) gamma = 90.0d0 c c determine the general periodic boundary lattice type c if (nosymm) then triclinic = .true. else 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 if c c set lattice values for non-prism periodic boundaries c if (octahedron .or. dodecadron) then orthogonal = .false. monoclinic = .false. triclinic = .false. nonprism = .true. ybox = xbox if (octahedron) then zbox = xbox else if (dodecadron) then zbox = xbox * root2 end if alpha = 90.0d0 beta = 90.0d0 gamma = 90.0d0 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 units -- physical constants and unit conversions ## c ## ## c ################################################################# c c c literature references: c c M. Stock, R. Davis, E. de Mirandes and M. J. T. Milton, "The c Revision of the SI - The Result of Three Decades of Progress c in Metrology", Metrologia, 56, 022001 (2019) c c E. Teisinga, P. J. Mohr, D. B. Newell and B. N. Taylor, "CODATA c Recommended Values of the Fundamental Physical Constants: 2018", c Journal of Physical and Chemical Reference Data, 50, 033105 (2021) c c Where appropriate, values are from the November 2018 revision c of SI units to fixed values by the 26th General Conference on c Weights and Measures; other values are taken from 2018 CODATA c reference constants or are described below c c The conversion from calorie to Joule is the definition of the c thermochemical calorie as 1 cal = 4.1840 J from ISO 31-4 (1992) c c The "coulomb" energy conversion factor is found by dimensional c analysis of Coulomb's Law, that is by dividing the square of the c elementary charge in Coulombs by 4*pi*eps0*rij, where eps0 is c the permittivity of vacuum (the "electric constant"); note that c eps0 is typically given in F/m, equivalent to C**2/(J-m) c c The approximate value used for the Debye, 3.33564 x 10-30 C-m, c is from IUPAC Compendium of Chemical Technology, 2nd Ed. (1997) c c The value of "prescon" is based on definition of 1 atmosphere c as 101325 Pa set by the 10th Conference Generale des Poids et c Mesures (Paris, 1954), where a Pascal (Pa) is equal to a J/m**3 c c avogadro Avogadro's number (N) in particles/mole c lightspd speed of light in vacuum (c) in cm/ps c boltzmann Boltzmann constant (kB) in g*Ang**2/ps**2/mole/K c gasconst ideal gas constant (R) in kcal/mole/K c elemchg elementary charge of a proton in Coulombs c vacperm vacuum permittivity (electric constant, eps0) in F/m c emass mass of an electron in atomic mass units c planck Planck's constant (h) in J-s c joule conversion from calorie to joule c ekcal conversion from kcal to g*Ang**2/ps**2 c bohr conversion from Bohr to Angstrom c hartree conversion from Hartree to kcal/mole c evolt conversion from Hartree to electron-volt c efreq conversion from Hartree to cm-1 c coulomb conversion from electron**2/Ang to kcal/mole c elefield conversion from electron**2/Ang to megavolt/cm c debye conversion from electron-Ang to Debye c prescon conversion from kcal/mole/Ang**3 to Atm c c module units implicit none real*8 avogadro real*8 lightspd real*8 boltzmann real*8 gasconst real*8 elemchg real*8 vacperm real*8 emass,planck real*8 joule,ekcal real*8 bohr,hartree real*8 evolt,efreq real*8 coulomb real*8 elefield real*8 debye,prescon parameter (avogadro=6.02214076d+23) parameter (lightspd=2.99792458d-2) parameter (boltzmann=0.8314462618d0) parameter (gasconst=1.9872042586d-3) parameter (elemchg=1.602176634d-19) parameter (vacperm=8.8541878128d-12) parameter (emass=5.48579909065d-4) parameter (planck=6.62607015d-34) parameter (joule=4.1840d0) parameter (ekcal=4.1840d+2) parameter (bohr=0.529177210903d0) parameter (hartree=627.509474063d0) parameter (evolt=27.211386245988d0) parameter (efreq=2.194746314d+5) parameter (coulomb=332.0637133d0) parameter (elefield=1439.96455d0) parameter (debye=4.80321d0) parameter (prescon=6.85684112d+4) save end c c c ################################################### c ## COPYRIGHT (C) 2011 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## module uprior -- previous values of induced dipoles ## c ## ## c ############################################################# c c c maxpred maximum number of predictor induced dipoles to save c c nualt number of sets of prior induced dipoles in storage c maxualt number of sets of induced dipoles needed for predictor c gear coefficients for Gear predictor binomial method c aspc coefficients for always stable predictor-corrector c bpred coefficients for induced dipole predictor polynomial c bpredp coefficients for predictor polynomial in energy field c bpreds coefficients for predictor for PB/GK solvation c bpredps coefficients for predictor in PB/GK energy field c udalt prior values for induced dipoles at each site c upalt prior values for induced dipoles in energy field c usalt prior values for induced dipoles for PB/GK solvation c upsalt prior values for induced dipoles in PB/GK energy field c use_pred flag to control use of induced dipole prediction c polpred type of predictor polynomial (ASPC, GEAR or LSQR) c c module uprior implicit none integer maxpred parameter (maxpred=17) integer nualt integer maxualt real*8 gear(maxpred) real*8 aspc(maxpred) real*8 bpred(maxpred) real*8 bpredp(maxpred) real*8 bpreds(maxpred) real*8 bpredps(maxpred) real*8, allocatable :: udalt(:,:,:) real*8, allocatable :: upalt(:,:,:) real*8, allocatable :: usalt(:,:,:) real*8, allocatable :: upsalt(:,:,:) logical use_pred character*4 polpred save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module urey -- Urey-Bradley interactions in structure ## c ## ## c ############################################################### c c c nurey total number of Urey-Bradley terms in the system c iury numbers of the atoms in each Urey-Bradley interaction c uk Urey-Bradley force constants (kcal/mole/Ang**2) c ul ideal 1-3 distance values in Angstroms c c module urey implicit none integer nurey integer, allocatable :: iury(:,:) real*8, allocatable :: uk(:) real*8, allocatable :: ul(:) save end c c c ################################################### c ## COPYRIGHT (C) 2000 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module urypot -- Urey-Bradley functional form details ## c ## ## c ############################################################### c c c cury cubic coefficient in Urey-Bradley potential c qury quartic coefficient in Urey-Bradley potential c ureyunit convert Urey-Bradley energy to kcal/mole c c module urypot implicit none real*8 cury real*8 qury real*8 ureyunit save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module usage -- atoms active during energy computation ## c ## ## c ################################################################ c c c nuse total number of active atoms in energy calculation c iuse numbers of the atoms active in energy calculation c use true if an atom is active, false if inactive c c module usage implicit none integer nuse integer, allocatable :: iuse(:) logical, allocatable :: use(:) save end c c c ############################################################## c ## COPYRIGHT (C) 2009 by Chuanjie Wu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ################################################################## c ## ## c ## program valence -- derive valence force field parameters ## c ## ## c ################################################################## c c c "valence" refines force field parameters for valence terms based c on a quantum mechanical optimized structure and frequencies c c program valence use atoms use files use inform use iounit use keys use linmin use output use potent use qmstuf use valfit implicit none integer i,nvar,next integer mode,length real*8 minimum,grdmin real*8 valrms,value real*8 valfit1 real*8, allocatable :: xx(:) logical exist,query logical doguess logical dotarget logical dofit character*20 keyword character*240 record character*240 string character*240 xyzfile external valfit1 external optsave c c c initialization of the various modes of operation c call initial fit_bond = .true. fit_angle = .true. fit_strbnd = .false. fit_urey = .false. fit_opbend = .false. fit_tors = .false. fit_force = .false. fit_struct = .false. doguess = .false. dotarget = .false. dofit = .false. c c find out which valence term protocol is to be performed c 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 Valence Parameter Utility Can :', & //,4x,'(1) Set Initial Values for Valence Parameters', & /,4x,'(2) Compare QM and MM Vibrational Frequencies', & /,4x,'(3) Force Fit of Parameters to QM Results', & /,4x,'(4) Structure Fit of Parameters to QM Results') do while (mode.lt.1 .or. mode.gt.4) 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 if (mode .eq. 1) then doguess = .true. else if (mode .eq. 2) then dotarget = .true. else if (mode .eq. 3) then dotarget = .true. dofit = .true. fit_force = .true. else if (mode .eq. 4) then dotarget = .true. dofit = .true. fit_struct = .true. end if c c read the Cartesian coordinates and connectivity info c call getxyz xyzfile = filename length = leng c c read structure and vibrational data from Gaussian output c call readgau filename = xyzfile leng = length call getkey c c assign estimated values to the valence parameters c if (doguess) then call attach call bonds call angles call torsions call field call katom call valguess else call mechanic end if c c get control parameters and target values from keyfile c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:9) .eq. 'FIT-BOND ') then fit_bond = .true. else if (keyword(1:9) .eq. 'FIX-BOND ') then fit_bond = .false. else if (keyword(1:10) .eq. 'FIT-ANGLE ') then fit_angle = .true. else if (keyword(1:10) .eq. 'FIX-ANGLE ') then fit_angle = .false. else if (keyword(1:11) .eq. 'FIT-STRBND ') then fit_strbnd = .true. else if (keyword(1:11) .eq. 'FIX-STRBND ') then fit_strbnd = .false. else if (keyword(1:9) .eq. 'FIT-UREY ') then fit_urey = .true. else if (keyword(1:9) .eq. 'FIX-UREY ') then fit_urey = .false. else if (keyword(1:11) .eq. 'FIT-OPBEND ') then fit_opbend = .true. else if (keyword(1:11) .eq. 'FIX-OPBEND ') then fit_opbend = .false. else if (keyword(1:12) .eq. 'FIT-TORSION ') then fit_tors = .true. else if (keyword(1:12) .eq. 'FIX-TORSION ') then fit_tors = .false. end if end do c c try to increase robustness of polarization calculations c if (dofit .and. use_polar) stpmax = 1.0d0 c c perform dynamic allocation of some local arrays c allocate (xx(35*n)) c c comparison of QM and Tinker structure and frequencies c if (dotarget) then if (.not. dofit) then do i = 1, n x(i) = gx(i) y(i) = gy(i) z(i) = gz(i) end do value = valrms (1) c c optimize the valence term force field parameters c else call prmvar (nvar,xx) value = valrms (1) grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=60,end=60) grdmin 60 continue if (grdmin .le. 0.0d0) then write (iout,70) 70 format (/,' Enter RMS Gradient Termination Criterion', & ' [0.01] : ',$) read (input,80) grdmin 80 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.01d0 coordtype = 'NONE' call ocvm (nvar,xx,minimum,grdmin,valfit1,optsave) call varprm (nvar,xx,0,0.0d0) call prmvar (nvar,xx) value = valrms (1) call prtval end if end if c c perform deallocation of some local arrays c deallocate (xx) c c perform any final tasks before program exit c call final end c c c ################################################################## c ## ## c ## subroutine valguess -- estimate valence parameter values ## c ## ## c ################################################################## c c c "valguess" sets approximate valence parameter values based on c quantum mechanical structure and frequency data c c subroutine valguess use angbnd use atomid use atoms use bndstr use iounit use kangs use kbonds use kopbnd use kstbnd use ktorsn use kurybr use kvdws use math use opbend use qmstuf use strbnd use tors use urey use valfit use vdwpot implicit none integer i,j,k integer size,number integer ia,ib,ic,id integer iia,iib,isba,isbb integer ita,itb,itc,itd integer iva,ivb,ivc integer iita,iitb integer nv,nb,na integer nsb,nop,nt integer vnum(maxtyp) integer, allocatable :: nequiv(:) real*8 xab,yab,zab real*8 xcb,ycb,zcb real*8 xac,yac,zac real*8 rab2,rcb2 real*8 cosine,dot real*8 bndguess real*8 angguess real*8 uryguess real*8 opbguess logical done character*4 pa,pb character*4 pc,pd character*8 ptb character*12 pta character*16 ptt c c c check the number of atoms in QM output and Tinker xyz file c if (n .ne. ngatom) then write (iout,10) 10 format (/,' VALENCE -- The Number of Atoms is Not', & ' Consistent') call fatal end if c c perform dynamic allocation of some global arrays c if (.not. allocated(bl)) allocate (bl(nbond)) if (.not. allocated(anat)) allocate (anat(nangle)) c c assign initial values to van der Waals parameters c nv = 0 do i = 1, n ita = class(i) if (vdwindex .eq. 'TYPE') ita = type(i) done = .false. if (i .gt. 1) then do j = 1, nv if (ita .eq. vnum(j)) done = .true. end do end if if (.not. done) then nv = nv + 1 vnum(nv) = ita call vdwguess (i,rad(ita),eps(ita),reduct(ita)) end if end do c c print the initial van der Waals parameter values c if (nv .gt. 0) then write (iout,20) 20 format (/,' Estimated van der Waals Parameters :',/) end if do i = 1, nv ia = vnum(i) if (reduct(ia) .eq. 0) then write (iout,30) ia,rad(ia),eps(ia) 30 format (' vdw',7x,i5,10x,f10.3,f11.4) else write (iout,40) ia,rad(ia),eps(ia),reduct(ia) 40 format (' vdw',7x,i5,10x,f10.3,f11.4,f9.2) end if end do c c find and store the unique bond stretches in the system c nb = 0 do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) ita = class(ia) itb = class(ib) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then ptb = pa//pb else ptb = pb//pa end if done = .false. do j = 1, nb if (ptb .eq. kb(j)) done = .true. end do if (.not. done) then nb = nb + 1 kb(nb) = ptb end if end do c c perform dynamic allocation of some local arrays c allocate (nequiv(4*n)) c c assign initial values to bond stretch parameters c k = 0 do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) ita = class(ia) itb = class(ib) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then ptb = pa//pb else ptb = pb//pa end if xab = gx(ia) - gx(ib) yab = gy(ia) - gy(ib) zab = gz(ia) - gz(ib) bl(i) = sqrt(xab*xab + yab*yab + zab*zab) done = .false. do j = 1, k if (ptb .eq. kb(j)) then done = .true. blen(j) = blen(j) + bl(i) nequiv(j) = nequiv(j) + 1 end if end do if (.not. done) then k = k + 1 bcon(k) = bndguess (ia,ib) blen(k) = bl(i) nequiv(k) = 1 end if end do c c print the initial bond stretch parameter values c if (nb .gt. 0) then write (iout,50) 50 format (/,' Estimated Bond Stretching Parameters :',/) end if do i = 1, nb blen(i) = blen(i) / dble(nequiv(i)) ptb = kb(i) ia = number(ptb(1:4)) ib = number(ptb(5:8)) write (iout,60) ia,ib,bcon(i),blen(i) 60 format (' bond',6x,2i5,5x,f10.1,f11.4) end do c c find and store the unique angle bends in the system c na = 0 do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pta = pa//pb//pc else pta = pc//pb//pa end if done = .false. do j = 1, na if (pta .eq. ka(j)) done = .true. end do if (.not. done) then na = na + 1 ka(na) = pta end if end do c c assign initial values to angle bend parameters c k = 0 do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pta = pa//pb//pc else pta = pc//pb//pa end if xab = gx(ia) - gx(ib) yab = gy(ia) - gy(ib) zab = gz(ia) - gz(ib) xcb = gx(ic) - gx(ib) ycb = gy(ic) - gy(ib) zcb = gz(ic) - gz(ib) rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0) dot = xab*xcb + yab*ycb + zab*zcb cosine = dot / sqrt(rab2*rcb2) cosine = min(1.0d0,max(-1.0d0,cosine)) anat(i) = radian * acos(cosine) done = .false. do j = 1, k if (pta .eq. ka(j)) then done = .true. ang(1,j) = ang(1,j) + anat(i) nequiv(j) = nequiv(j) + 1 end if end do if (.not. done) then k = k + 1 acon(k) = angguess (ia,ib,ic) ang(1,k) = anat(i) nequiv(k) = 1 end if end do c c print the initial angle bend parameter values c if (na .gt. 0) then write(iout,70) 70 format(/,' Estimated Angle Bending Parameters :',/) end if do i = 1, na ang(1,i) = ang(1,i) / dble(nequiv(i)) pta = ka(i) ia = number(pta(1:4)) ib = number(pta(5:8)) ic = number(pta(9:12)) write (iout,80) ia,ib,ic,acon(i),ang(1,i) 80 format (' angle',5x,3i5,f10.2,f11.2) end do c c assign initial values to stretch-bend parameters c nsb = 0 do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) iva = valence(ia) ivb = valence(ib) ivc = valence(ic) if (iva.gt.1 .or. ivc.gt.1) then size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pta = pa//pb//pc else pta = pc//pb//pa end if done = .false. do j = 1, nsb if (pta .eq. ksb(j)) done = .true. end do if (.not. done) then nsb = nsb + 1 ksb(nsb) = pta if (ita .le. itc) then call sbguess (ia,ib,ic,stbn(1,nsb),stbn(2,nsb)) else call sbguess (ic,ib,ia,stbn(1,nsb),stbn(2,nsb)) end if end if end if end do c c print the initial stretch-bend parameter values c if (nsb .gt. 0) then write (iout,90) 90 format (/,' Estimated Stretch-Bend Parameters :',/) end if do i = 1, nsb pta = ksb(i) ia = number(pta(1:4)) ib = number(pta(5:8)) ic = number(pta(9:12)) write (iout,100) ia,ib,ic,stbn(1,i),stbn(2,i) 100 format (' strbnd',4x,3i5,f10.2,f11.2) end do c c assign initial values to Urey-Bradley parameters c k = 0 do i = 1, nurey ia = iury(1,i) ib = iury(2,i) ic = iury(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pta = pa//pb//pc else pta = pc//pb//pa end if xac = gx(ia) - gx(ic) yac = gy(ia) - gy(ic) zac = gz(ia) - gz(ic) ul(i) = sqrt(xac*xac + yac*yac + zac*zac) done = .false. do j = 1, k if (pta .eq. ku(j)) then done = .true. dst13(j) = dst13(j) + ul(i) nequiv(j) = nequiv(j) + 1 end if end do if (.not. done) then k = k + 1 ucon(k) = uryguess (ia,ib,ic) dst13(k) = ul(i) nequiv(k) = 1 end if end do c c print the initial Urey-Bradley parameter values c if (nurey .gt. 0) then write (iout,110) 110 format (/,' Estimated Urey-Bradley Parameters :',/) end if do i = 1, nsb dst13(i) = dst13(i) / dble(nequiv(i)) pta = ku(i) ia = number(pta(1:4)) ib = number(pta(5:8)) ic = number(pta(9:12)) write (iout,120) ia,ib,ic,ucon(i),dst13(i) 120 format (' ureybrad',2x,3i5,f10.1,f11.4) end do c c perform deallocation of some local arrays c deallocate (nequiv) c c assign initial values to out-of-plane bend parameters c nop = 0 do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) ic = 0 id = 0 iva = valence(ia) ivb = valence(ib) if (iva.eq.3 .or. ivb.eq.3) then ita = class(ia) itb = class(ib) itc = 0 itd = 0 size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (iva .eq. 3) then ptt = pb//pa//pc//pd isba = ia isbb = ib else ptt = pa//pb//pc//pd isba = ib isbb = ia end if if (atomic(isba) .eq. 6) then done = .false. do j = 1, nop if (ptt .eq. kopb(j)) done = .true. end do if (.not. done) then nop = nop + 1 kopb(nop) = ptt opbn(nop) = opbguess (isba,isbb,ic,id) do j = i+1, nbond iia = ibnd(1,j) iib = ibnd(2,j) if (iia.eq.isba .or. iib.eq.isba) then iita = class(iia) iitb = class(iib) size = 4 call numeral (iita,pa,size) call numeral (iitb,pb,size) if (iia .eq. isba) then ptt = pb//pa//pc//pd else if (iib .eq. isba) then ptt = pa//pb//pc//pd end if done = .false. do k = 1, nop if (ptt .eq. kopb(k)) done = .true. end do if (.not. done) then nop = nop + 1 kopb(nop) = ptt if (iia .eq. isba) then opbn(nop) = opbguess (iia,iib,ic,id) else if (iib .eq. isba) then opbn(nop) = opbguess (iib,iia,ic,id) end if end if end if end do end if else if (atomic(isba) .eq. 7) then if (valence(isbb).eq.3 .and. atomic(isbb).eq.6) then nop = nop + 1 kopb(nop) = ptt opbn(nop) = opbguess (isba,isbb,ic,id) do j = 1, nbond if (j.ne.i .and. (ibnd(1,j).eq.isba & .or. ibnd(2,j).eq.isba)) then if (ibnd(1,j) .eq. isba) then iia = ibnd(2,j) else iia = ibnd(1,j) end if size = 4 call numeral (class(isba),pa,size) call numeral (class(iia),pb,size) ptt = pb//pa//pc//pd done = .false. do k = 1, nop if (ptt .eq. ksb(k)) done = .true. end do if (.not. done) then nop = nop + 1 kopb(nop) = ptt opbn(nop) = opbguess (isba,iia,ic,id) end if end if end do end if end if end if end do c c print the initial out-of-plane bend parameter values c if (nop .gt .0) then write (iout,130) 130 format (/,' Estimated Out-of-Plane Parameters :',/) end if do i = 1, nop ptt = kopb(i) ia = number(ptt(1:4)) ib = number(ptt(5:8)) ic = number(ptt(9:12)) id = number(ptt(13:16)) write (iout,140) ia,ib,ic,id,opbn(i) 140 format (' opbend',4x,4i5,6x,f10.2) end do c c assign initial values to torsional parameters c nt = 0 do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb .le. itc) then ptt = pa//pb//pc//pd else ptt = pd//pc//pb//pa end if done = .false. do j = 1, nt if (ptt .eq. kt(j)) done = .true. end do if (.not. done) then nt = nt + 1 kt(nt) = ptt call torguess (ia,ib,ic,id,t1(1,nt),t2(1,nt),t3(1,nt)) end if end do c c print the initial torsional parameter values c if (nt .gt. 0) then write (iout,150) 150 format (/,' Estimated Torsional Parameters :'/) end if do i = 1, nt ptt = kt(i) ia = number(ptt(1:4)) ib = number(ptt(5:8)) ic = number(ptt(9:12)) id = number(ptt(13:16)) write (iout,160) ia,ib,ic,id,t1(1,i),t2(1,i),t3(1,i) 160 format (' torsion',3x,4i5,3x,f8.3,' 0.0 1',f8.3, & ' 180.0 2',f8.3,' 0.0 3') end do return end c c c ################################################################## c ## ## c ## subroutine vdwguess -- estimate van der Waals parameters ## c ## ## c ################################################################## c c c "vdwguess" sets initial VDW parameters based on atom type c and connected atoms c c subroutine vdwguess (ia,rad,eps,reduce) use atomid use couple use math use vdwpot implicit none integer i,j,k,ia integer ita,itb integer iva,ivb real*8 rad,eps,reduce c c c set default value for radius, well depth and reduction factor c rad = 1.0d0 eps = 0.1d0 reduce = 0.0d0 c c get atomic number and valence for the atom and its neighbor c ita = atomic(ia) iva = valence(ia) itb = 0 ivb = 0 do i = 1, n12(ia) j = i12(i,ia) k = atomic(j) if (k .gt. itb) then itb = k ivb = valence(j) end if end do c c assign specific values based on atom type and connectivity c if (ita .eq. 1) then if (itb .eq. 6) then if (ivb .eq. 3) then rad = 2.980d0 eps = 0.0260d0 reduce = 0.92d0 else if (ivb .eq. 4) then rad = 2.780d0 eps = 0.0260d0 reduce = 0.91d0 else rad = 2.780d0 eps = 0.0260d0 reduce = 0.91d0 end if else if (itb .eq. 7) then rad = 2.700d0 eps = 0.0200d0 reduce = 0.91d0 else if (itb .eq. 8) then rad = 2.655d0 eps = 0.0135d0 reduce = 0.91d0 else if (itb .eq. 16) then rad = 3.000d0 eps = 0.0265d0 reduce = 0.98d0 else rad = 2.980d0 eps = 0.0260d0 reduce = 0.92d0 end if else if (ita .eq. 6) then if (iva .eq. 3) then rad = 3.800d0 eps = 0.0890d0 else if (iva .eq. 4) then rad = 3.820d0 eps = 0.1010d0 else rad = 3.820d0 eps = 0.1010d0 end if else if (ita .eq. 7) then if (iva .eq. 3) then rad = 3.710d0 eps = 0.1050d0 else if (iva .eq. 2) then rad = 3.710d0 eps = 0.1100d0 else rad = 3.710d0 eps = 0.1050d0 end if else if (ita .eq. 8) then if (iva .eq. 1) then if (itb .eq. 6) then rad = 3.300d0 eps = 0.1120d0 else if (itb .eq. 7) then rad = 3.300d0 eps = 0.1120d0 else if (itb .eq. 15) then rad = 3.360d0 eps = 0.1120d0 else if (itb .eq. 16) then rad = 3.510d0 eps = 0.1120d0 else rad = 3.300d0 eps = 0.1120d0 end if else if (iva .eq. 2) then if (itb .eq. 15) then rad = 3.405d0 eps = 0.1120d0 else rad = 3.405d0 eps = 0.1100d0 end if else rad = 3.405d0 eps = 0.1100d0 end if else if (ita .eq. 9) then if (iva .eq. 0) then rad = 3.400d0 eps = 0.2500d0 else if (iva .eq. 1) then rad = 3.220d0 eps = 0.1200d0 else rad = 3.220d0 eps = 0.1200d0 end if else if (ita .eq. 11) then rad = 3.020d0 eps = 0.260d0 else if (ita .eq. 12) then rad = 2.550d0 eps = 0.850d0 else if (ita .eq. 15) then rad = 4.450d0 eps = 0.390d0 else if (ita .eq. 16) then if (iva .eq. 2) then rad = 3.910d0 eps = 0.3850d0 else if (iva .eq. 3) then rad = 3.910d0 eps = 0.3850d0 else if (iva .eq. 4) then rad = 3.910d0 eps = 0.3850d0 else rad = 3.910d0 eps = 0.3850d0 end if else if (ita .eq. 17) then if (iva .eq. 0) then rad = 4.130d0 eps = 0.340d0 else if (iva .eq. 1) then rad = 4.130d0 eps = 0.340d0 else rad = 4.130d0 eps = 0.340d0 end if else if (ita .eq. 19) then rad = 3.710d0 eps = 0.3500d0 else if (ita .eq. 20) then rad = 3.150d0 eps = 1.6000d0 else if (ita .eq. 35) then if (iva .eq. 0) then rad = 4.380d0 eps = 0.4300d0 else if (iva .eq. 1) then rad = 4.380d0 eps = 0.4300d0 else rad = 4.380d0 eps = 0.4300d0 end if else if (ita .eq. 53) then if (iva .eq. 0) then rad = 4.660d0 eps = 0.520d0 else if (iva .eq. 1) then rad = 4.660d0 eps = 0.520d0 else rad = 4.660d0 eps = 0.520d0 end if end if c c scale the vdw parameters to the desired units c if (radsiz .eq. 'RADIUS') rad = 0.5d0 * rad if (radsiz .eq. 'SIGMA') rad = rad / twosix return end c c c ############################################################### c ## ## c ## function bndguess -- estimate bond stretch parameters ## c ## ## c ############################################################### c c c "bndguess" sets approximate bond stretch force constants based c on atom type and connected atoms c c function bndguess (ia,ib) use atomid use bndpot implicit none integer ia,ib,tmp integer ita,itb integer iva,ivb real*8 bndguess c c c get the atomic number and valence of each atom c ita = atomic(ia) itb = atomic(ib) iva = valence(ia) ivb = valence(ib) c c reverse the atom order based on atomic number c if (ita .gt. itb) then tmp = ita ita = itb itb = tmp tmp = iva iva = ivb ivb = tmp end if c c assign estimated bond stretch force constants c if (ita .eq. 1) then if (itb .eq. 6) then if (ivb .eq. 3) then bndguess = 410.0d0 else if (ivb .eq. 4) then bndguess = 400.0d0 else bndguess = 400.0d0 end if else if (itb .eq. 7) then bndguess = 520.0d0 else if (itb .eq. 8) then bndguess = 560.0d0 else if (itb .eq. 9) then bndguess = 500.0d0 else if (itb .eq. 14) then bndguess = 200.0d0 else if (itb .eq. 15) then bndguess = 230.0d0 else if (itb .eq. 16) then bndguess = 260.0d0 else bndguess = 300.0d0 end if else if (ita .eq. 6) then if (itb .eq. 6) then if (iva.eq.3 .and. ivb.eq.3) then bndguess = 680.0d0 else if (iva.eq.4 .or. ivb.eq.4) then bndguess = 385.0d0 else bndguess = 350.0d0 end if else if (itb .eq. 7) then if (iva.eq.3 .and. ivb.eq.2) then bndguess = 435.0d0 else if (iva.eq.3 .and. ivb.eq.3) then bndguess = 250.0d0 else if (iva.eq.4) then bndguess = 400.0d0 else bndguess = 450.0d0 end if else if (itb .eq. 8) then if (ivb .eq. 1) then bndguess = 680.0d0 else if (ivb .eq. 2) then bndguess = 465.0d0 else bndguess = 465.0d0 end if else if (itb .eq. 9) then bndguess = 350.0d0 else if (itb .eq. 14) then bndguess = 350.0d0 else if (itb .eq. 15) then bndguess = 350.0d0 else if (itb .eq. 16) then bndguess = 216.0d0 else if (itb .eq. 17) then bndguess = 350.0d0 else bndguess = 450.0d0 end if else if (ita .eq. 7) then if (itb .eq. 7) then if (iva .eq. 1) then bndguess = 1613.0d0 else if (iva.eq.2 .and. ivb.eq.2) then bndguess = 950.0d0 else bndguess = 850.0d0 end if else if (itb .eq. 8) then if (ivb .eq. 1 ) then bndguess = 900.0d0 else bndguess = 750.0d0 end if else if (itb .eq. 14) then bndguess = 450.0d0 else if (itb .eq. 15) then bndguess = 500.0d0 else if (itb .eq. 16) then bndguess = 550.0d0 else bndguess = 600.0d0 end if else if (ita .eq. 8) then if (itb .eq. 8) then bndguess = 750.0d0 else if (itb .eq. 14) then bndguess = 500.0d0 else if (itb .eq. 15) then if (iva .eq. 2) then bndguess = 450.0d0 else if (iva .eq. 1) then bndguess = 775.0d0 else bndguess = 450.0d0 end if else if (itb .eq. 16) then bndguess = 606.0d0 else if (itb .eq. 17) then bndguess = 500.0d0 else bndguess = 600.0d0 end if else if (ita .eq. 14) then if (itb .eq. 14) then bndguess = 400.0d0 else if (itb .eq. 15) then bndguess = 450.0d0 else if (itb .eq. 16) then bndguess = 500.0d0 else if (itb .eq. 17) then bndguess = 650.0d0 else bndguess = 450.0d0 end if else if (ita .eq. 16) then if (itb .eq. 16) then bndguess = 188.0d0 else bndguess = 250.0d0 end if else if (ita .eq. 17) then bndguess = 300.0d0 else bndguess = 350.0d0 end if c c scale the force constant to the desired units c bndguess = bndguess / bndunit return end c c c ################################################################ c ## ## c ## function angguess -- estimate angle bending parameters ## c ## ## c ################################################################ c c c "angguess" sets approximate angle bend force constants based c on atom type and connected atoms c c function angguess (ia,ib,ic) use atomid use angpot use math implicit none integer ia,ib,ic,tmp integer ita,itb,itc integer iva,ivb,ivc real*8 angguess c c c get the atomic number and valence of each atom c ita = atomic(ia) itb = atomic(ib) itc = atomic(ic) iva = valence(ia) ivb = valence(ib) ivc = valence(ic) c c resort ja,jb,jc based on the atomic orders c if (ita .gt. itc) then tmp = ita ita = itc itc = tmp tmp = iva iva = ivc ivc = tmp end if c c assign estimated angle bend force constants c if (itb .eq. 6) then if (ita .eq. 1) then if (ivb .eq. 4) then if (itc .eq. 1) then angguess = 34.50d0 else if (itc .eq. 6) then angguess = 38.0d0 else if (itc .eq. 7) then angguess = 50.60d0 else if (itc .eq. 8) then angguess = 51.50d0 else if (itc .eq. 9) then angguess = 50.0d0 else angguess = 35.0d0 end if else if (ivb .eq. 3) then angguess = 32.00d0 else angguess = 32.00d0 end if else if (ita .eq. 6) then if (ivb .eq. 4) then if (itc .eq. 6) then angguess = 60.00d0 else if (itc .eq. 7) then angguess = 80.00d0 else if (itc .eq. 8) then angguess = 88.00d0 else if (itc .eq. 9) then angguess = 89.00d0 else if (itc .eq. 14) then angguess = 65.00d0 else if (itc .eq. 15) then angguess = 60.00d0 else if (itc .eq. 16) then angguess = 53.20d0 else if (itc .eq. 17) then angguess = 55.00d0 else angguess = 50.00d0 end if else if (ivb .eq. 3) then angguess = 60.00d0 else angguess = 60.00d0 end if else if (ita .eq. 8) then if (ivb .eq. 4) then if (itc .eq. 8) then angguess = 65.00d0 else if (itc .eq. 9) then angguess = 65.00d0 else if (itc .eq. 15) then angguess = 60.00d0 else if (itc .eq. 16) then angguess = 65.00d0 else angguess = 65.00d0 end if else if (ivb .eq. 3) then angguess = 50.00d0 else angguess = 60.00d0 end if else angguess = 60.00d0 end if else if (itb .eq. 8) then if (ita .eq. 1) then if (itc .eq. 1) then angguess = 34.05d0 else if (itc .eq. 6) then angguess = 65.00d0 else angguess = 60.00d0 end if else if (ita .eq. 6) then if (itc .eq. 6) then angguess = 88.50d0 else if (itc .eq. 8) then if (iva.eq.1 .or. ivc.eq.1) then angguess = 122.30d0 else angguess = 85.00d0 end if else if (itc .eq. 15) then angguess = 80.30d0 else angguess = 80.0d0 end if else angguess = 80.0d0 end if else if (itb .eq. 15) then if (ita .eq. 1) then angguess = 30.0d0 else if (ita .eq. 6) then if (itc .eq. 6) then angguess = 75.00d0 else if (itc .eq. 8) then angguess = 80.00d0 else angguess = 75.00d0 end if else if (ita .eq. 8) then if (itc .eq. 8) then if (iva.eq.1 .and. ivc.eq.1) then angguess = 89.88d0 else if (iva.eq.1 .or. ivc.eq.1) then angguess = 75.86d0 else angguess = 65.58d0 end if else angguess = 70.00d0 end if else angguess = 75.00d0 end if else if (itb .eq. 16) then if (ita .eq. 1) then angguess = 30.00d0 else if (ita .eq. 6) then if (itc .eq. 16) then angguess = 72.00d0 else angguess = 80.00d0 end if else if (ita .eq. 8) then if (itc .eq. 8) then if (iva.eq.1 .and. ivc.eq.1) then angguess = 168.00d0 else if (iva.eq.1 .or. ivc.eq.1) then angguess = 85.00d0 else angguess = 80.00d0 end if else if (itc .eq. 16) then angguess = 75.00d0 else angguess = 75.00d0 end if else angguess = 75.00d0 end if else if (ita .eq. 1) then angguess = 35.00d0 else angguess = 65.00d0 end if c c scale the force constant to the desired units c angguess = angguess / (angunit*radian**2) return end c c c ################################################################ c ## ## c ## subroutine sbguess -- estimate stretch-bend parameters ## c ## ## c ################################################################ c c c "sbguess" sets approximate stretch-bend force constants based c on atom type and connected atoms c c subroutine sbguess (ia,ib,ic,sb1,sb2) use angpot use atomid use math implicit none integer ia,ib,ic integer ita,itb,itc integer iva,ivb,ivc real*8 sb1,sb2 c c c get the atomic number and valence of each atom c ita = atomic(ia) itb = atomic(ib) itc = atomic(ic) iva = valence(ia) ivb = valence(ib) ivc = valence(ic) c c set initial stretch-bend parameters c if (ita.eq.1 .and. itc.eq.1) then sb1 = 0.0d0 sb2 = 0.0d0 else if (itb .eq. 6) then if (ita .eq. 1 ) then sb1 = 11.50d0 sb2 = 18.70d0 else if (itc .eq. 1) then sb1 = 18.70d0 sb2 = 11.50d0 else sb1 = 18.70d0 sb2 = 18.70d0 end if else if (itb .eq. 6) then if (ita .eq. 1) then sb1 = 4.50d0 sb2 = 12.95d0 else if (itc .eq. 1) then sb1 = 12.95d0 sb2 = 4.50d0 else sb1 = 14.40d0 sb2 = 14.40d0 end if else if (itb .eq. 7) then if (ivb .ge. 3) then if (ita .eq. 1) then sb1 = 4.30d0 sb2 = 7.20d0 else if (itc .eq. 1) then sb1 = 7.20d0 sb2 = 4.30d0 else sb1 = 7.20d0 sb2 = 7.20d0 end if else if (ita .eq. 1) then sb1 = 4.30d0 sb2 = 14.40d0 else if (itc .eq. 1) then sb1 = 14.40d0 sb2 = 4.30d0 else sb1 = 14.40d0 sb2 = 14.40d0 end if end if else if (itb .eq. 14) then if (ita .eq. 1) then sb1 = 8.60d0 sb2 = 14.40d0 else if (itc .eq. 1) then sb1 = 14.40d0 sb2 = 8.60d0 else sb1 = 14.40d0 sb2 = 14.40d0 end if else if (itb .eq. 15) then if (ivb .eq. 4) then if (ita .eq. 1) then sb1 = 14.40d0 sb2 = 14.40d0 else if (itc .eq. 1) then sb1 = 14.40d0 sb2 = 14.40d0 else sb1 = 14.40d0 sb2 = 14.40d0 end if else if (ita .eq. 1) then sb1 = 8.60d0 sb2 = 8.60d0 else if (itc .eq. 1) then sb1 = 8.60d0 sb2 = 8.60d0 else sb1 = 8.60d0 sb2 = 8.60d0 end if end if else if (itb .eq. 16) then if (ita .eq. 1) then sb1 = 1.45d0 sb2 = -5.75d0 else if (itc .eq. 1) then sb1 = -5.75d0 sb2 = 1.45d0 else sb1 = -5.75d0 sb2 = -5.75d0 end if else if (ita.eq.1 .and. itc.gt.1) then sb1 = -4.50d0 sb2 = 38.00d0 else if (ita.gt.1 .and. itc.eq.1) then sb1 = 38.00d0 sb2 = -4.50d0 else if (ita.gt.1 .and. itc.gt.1) then sb1 = 38.00d0 sb2 = 38.00d0 else sb1 = 38.00d0 sb2 = 38.00d0 end if c c scale the force constant to the desired units c sb1 = sb1 / (stbnunit*radian) sb2 = sb2 / (stbnunit*radian) return end c c c ############################################################### c ## ## c ## function uryguess -- estimate Urey-Bradley parameters ## c ## ## c ############################################################### c c c "uryguess" sets approximate Urey-Bradley force constants c based on atom type and connected atoms c c function uryguess (ia,ib,ic) use atomid use urypot implicit none integer ia,ib,ic integer ita,itb,itc integer iva,ivb,ivc real*8 uryguess c c c get the atomic number and valence of each atom c ita = atomic(ia) itb = atomic(ib) itc = atomic(ic) iva = valence(ia) ivb = valence(ib) ivc = valence(ic) c c assign estimated out-of-plane parameter values c uryguess = 10.0d0 c c scale the force constant to the desired units c uryguess = uryguess / ureyunit return end c c c ################################################################ c ## ## c ## function opbguess -- estimate out-of-plane bend values ## c ## ## c ################################################################ c c c "opbguess" sets approximate out-of-plane bend force constants c based on atom type and connected atoms c c function opbguess (ia,ib,ic,id) use angpot use atomid use math implicit none integer ia,ib,ic,id integer ita,itb integer iva,ivb real*8 opbguess c c c get the atomic number and valence of each atom c ita = atomic(ia) itb = atomic(ib) iva = valence(ia) ivb = valence(ib) c c assign estimated out-of-plane parameter values c opbguess = 14.40d0 c c scale the force constant to the desired units c opbguess = opbguess / (opbunit*radian**2) return end c c c ############################################################## c ## ## c ## subroutine torguess -- estimate torsional parameters ## c ## ## c ############################################################## c c c "torguess" set approximate torsion amplitude parameters based c on atom type and connected atoms c c subroutine torguess (ia,ib,ic,id,tf1,tf2,tf3) use atomid use torpot implicit none integer ia,ib,ic,id,tmp integer ita,itb,itc,itd integer iva,ivb,ivc,ivd real*8 tf1,tf2,tf3 c c c get the atomic number and valence of each atom c ita = atomic(ia) itb = atomic(ib) itc = atomic(ic) itd = atomic(id) iva = valence(ia) ivb = valence(ib) ivc = valence(ic) ivd = valence(id) c c reorder the atoms based on the atomic numbers c if (itb.gt.itc .or. (itb.eq.itc.and.ita.gt.itd)) then tmp = itb itb = itc itc = tmp tmp = ivb ivb = ivc ivc = tmp tmp = ita ita = itd itd = tmp tmp = iva iva = ivd ivd = tmp end if c c assign estimated torsional parameter values c tf1 = 0.0d0 tf2 = 0.0d0 tf3 = 0.0d0 if (itb.eq.6 .and. itc.eq.6) then if (ita.eq.6 .and. itd.eq.6) then if (ivb.eq.3 .and. ivc.eq.3) then if (iva.eq.3 .and. ivd.eq.3) then tf1 = -0.335d0 tf2 = 2.00d0 tf3 = 0.00d0 else if (iva.eq.3 .and. ivd.eq.4) then tf1 = -0.305d0 tf2 = 2.105d0 tf3 = 0.00d0 else if (iva.eq.4 .and. ivd.eq.4 ) then tf1 = 0.00d0 tf2 = 4.00d0 tf3 = 0.00d0 end if else if (ivb.eq.3 .and. ivc.eq.4) then tf1 = -0.40d0 tf2 = -0.05d0 tf3 = -0.275d0 else if (ivb.eq.4 .and. ivc.eq.4) then tf1 = 0.09d0 tf2 = 0.085d0 tf3 = 0.26d0 end if else if (ita.eq.1 .and. itd.eq.1) then if (ivb.eq.3 .and. ivc.eq.3) then tf1 = 0.00d0 tf2 = 2.035d0 tf3 = 0.00d0 else tf1 = 0.00d0 tf2 = 0.00d0 tf3 = 0.15d0 end if else if (ita.eq.1 .and. itd.eq.6) then if (ivb.eq.4 .and. ivc.eq.4) then tf1 = 0.00d0 tf2 = 0.00d0 tf3 = 0.17d0 else if (ivb.eq.3 .and. ivc.eq.3 .and. ivd.eq.3) then tf1 = 0.00d0 tf2 = 3.05d0 tf3 = 0.00d0 else if (ivb.eq.3 .and. ivc.eq.3 .and. ivd.eq.4) then tf1 = 0.00d0 tf2 = 3.05d0 tf3 = 0.00d0 else if (ivb.eq.4 .and. ivc.eq.3) then tf1 = 0.00d0 tf2 = 0.00d0 tf3 = -0.045d0 end if else if (ita.eq.1 .and. itd.eq.7) then if (ivb.eq.3 .and. ivc.eq.3) then tf1 = -1.575d0 tf2 = 1.50d0 tf3 = 0.00d0 else tf1 = 0.00d0 tf2 = 0.00d0 tf3 = 0.25d0 end if else if (ita.eq.1 .and. itd.eq.8) then tf1 = 0.00d0 tf2 = 0.00d0 tf3 = 0.15d0 else if (ita.eq.6 .and. itd.eq.8) then if (ivb.eq.3 .and. ivc.eq.3) then tf1 = 0.00d0 tf2 = 2.235d0 tf3 = 0.00d0 else tf1 = -0.575d0 tf2 = 0.00d0 tf3 = 0.64d0 end if else if (ita.eq.8 .and. itd.eq.8) then tf1 = 1.11d0 tf2 = -0.69d0 tf3 = -0.59d0 else if (ivb.eq.3 .and. ivc.eq.3) then tf1 = 0.00d0 tf2 = 1.25d0 tf3 = 0.00d0 else tf1 = 0.00d0 tf2 = 0.00d0 tf3 = 0.15d0 end if else if (itb.eq.6 .and. itc.eq.8) then if(ita.eq.1 .and. itd.eq.1) then tf1 = 0.00d0 tf2 = 0.00d0 tf3 = 0.135d0 else if (ita.eq.1 .and. itd.eq.6) then if (ivc.eq.3 .and. ivd.eq.3) then tf1 = 0.00d0 tf2 = 2.235d0 tf3 = 0.00d0 else tf1 = 0.00d0 tf2 = 0.00d0 tf3 = 0.355d0 end if else if (ita .eq. 1) then tf1 = 0.00d0 tf2 = 0.00d0 tf3 = 0.375d0 else if (ita.eq.6 .and. itd.eq.1 .and. ivb.eq.4) then tf1 = -0.885d0 tf2 = 0.115d0 tf3 = 0.38d0 else if (ita.eq.6 .and. itd.eq.6) then tf1 = 1.00d0 tf2 = -0.75d0 tf3 = 0.445d0 else if (ita.eq.6 .and. itd.eq.1 .and. ivb.eq.3) then tf1 = 0.00d0 tf2 = 1.175d0 tf3 = 0.00d0 else if (ivb .eq. 3) then tf1 = 0.00d0 tf2 = 1.25d0 tf3 = 0.00d0 else if (ivb .eq. 4) then tf1 = 1.00d0 tf2 = -0.75d0 tf3 = 0.445d0 end if else if (itb.eq.6 .and. itc.eq.15) then tf1 = 0.00d0 tf2 = 1.25d0 tf3 = 0.25d0 else if (itb.eq.6 .and. itc.eq.16) then tf1 = 0.00d0 tf2 = 0.00d0 tf3 = 0.25d0 else if (itb.eq.8 .and. itc.eq.15) then tf1 = -1.00d0 tf2 = -0.84d0 tf3 = -0.40d0 else if (itb.eq.8 .and. itc.eq.16) then tf1 = -0.75d0 tf2 = -1.00d0 tf3 = -0.40d0 else tf1 = 0.00d0 tf2 = 0.50d0 tf3 = 0.25d0 end if c c scale the amplitude values to the desired units c tf1 = tf1 / torsunit tf2 = tf2 / torsunit tf3 = tf3 / torsunit return end c c c ############################################################### c ## ## c ## function valrms -- compute structure & vibration RMSD ## c ## ## c ############################################################### c c c "valrms" evaluates a valence parameter goodness-of-fit error c function based on comparison of forces, frequencies, bond c lengths and angles to QM results c c function valrms (prtflg) use angbnd use atoms use atomid use bndstr use hescut use iounit use inform use kangs use kbonds use kopbnd use kstbnd use ktorsn use kvdws use linmin use math use minima use opbend use output use qmstuf use scales use strbnd use tors use units use valfit implicit none integer i,j,k integer m,m1,m2 integer ia,ib,ic,id integer olditer integer oldprt,oldwrt integer prtflg,ihess integer nvar,nfreq integer, allocatable :: hindex(:) integer, allocatable :: hinit(:,:) integer, allocatable :: hstop(:,:) real*8 xab,yab,zab real*8 xba,yba,zba real*8 xcb,ycb,zcb real*8 xdc,ydc,zdc real*8 bond,gbond real*8 angle,gangle real*8 factor,grdmin real*8 oldstep real*8 delta,cosine,sine real*8 rab2,rcb,rcb2,rabc real*8 xt,yt,zt,xu,yu,zu real*8 xtu,ytu,ztu real*8 rt2,ru2,rtru real*8 valmin1,minimum real*8 valrms,energy real*8 bave,brms,bfac real*8 aave,arms,afac real*8 tave,trms,tfac real*8 gave,grms,gfac real*8 have,hrms,hfac real*8 fave,frms,ffac,fcut real*8, allocatable :: xx(:) real*8, allocatable :: mass2(:) real*8, allocatable :: eigen(:) real*8, allocatable :: h(:) real*8, allocatable :: matrix(:) real*8, allocatable :: derivs(:,:) real*8, allocatable :: hdiag(:,:) real*8, allocatable :: vects(:,:) character*1 axis(3) external valmin1 external optsave data axis / 'X','Y','Z' / c c c perform dynamic allocation of some global arrays c if (.not. allocated(scale)) allocate (scale(3*n)) c c scale the coordinates of each active atom; use the c square root of median eigenvalue of typical Hessian c if (fit_struct) then allocate (xx(3*n)) set_scale = .true. nvar = 0 do i = 1, n nvar = nvar + 1 scale(nvar) = 12.0d0 xx(nvar) = gx(i) * scale(nvar) nvar = nvar + 1 scale(nvar) = 12.0d0 xx(nvar) = gy(i) * scale(nvar) nvar = nvar + 1 scale(nvar) = 12.0d0 xx(nvar) = gz(i) * scale(nvar) end do c c make the call to the optimization routine c oldstep = stpmax olditer = maxiter oldprt = iprint oldwrt = iwrite stpmax = 0.0d0 maxiter = 0 iprint = 0 iwrite = 0 grdmin = 0.0001d0 coordtype = 'CARTESIAN' call lbfgs (nvar,xx,minimum,grdmin,valmin1,optsave) coordtype = 'NONE' stpmax = oldstep maxiter = olditer iprint = oldprt iwrite = oldwrt c c unscale the final coordinates for active atoms c nvar = 0 do i = 1, n nvar = nvar + 1 x(i) = xx(nvar) / scale(nvar) scale(nvar) = 1.0d0 nvar = nvar + 1 y(i) = xx(nvar) / scale(nvar) scale(nvar) = 1.0d0 nvar = nvar + 1 z(i) = xx(nvar) / scale(nvar) scale(nvar) = 1.0d0 end do deallocate (xx) end if c c compute the RMS between QM and Tinker bond lengths c bave = 0.0d0 brms = 0.0d0 if (fit_struct) then if (prtflg.eq.1 .and. nbond.ne.0) then write (iout,10) 10 format (/,' Comparison of Bond Lengths :', & //,6x,'Bond',8x,'Atoms',19x,'QM Bond', & 6x,'MM Bond',8x,'Delta',/) end if do i = 1, nbond ia = ibnd(1,i) ib = ibnd(2,i) xab = x(ia) - x(ib) yab = y(ia) - y(ib) zab = z(ia) - z(ib) bond = sqrt(xab*xab + yab*yab + zab*zab) xab = gx(ia) - gx(ib) yab = gy(ia) - gy(ib) zab = gz(ia) - gz(ib) gbond = sqrt(xab*xab + yab*yab + zab*zab) delta = bond - gbond bave = bave + abs(delta) brms = brms + delta*delta if (prtflg .eq. 1) then write (iout,20) i,ia,ib,gbond,bond,delta 20 format (4x,i5,4x,2i5,13x,3f13.4) end if end do if (nbond .ne. 0) bave = bave / (dble(nbond)) if (nbond .ne. 0) brms = sqrt(brms/dble(nbond)) if (prtflg.eq.1 .and. nbond.ne.0) then write (iout,30) bave,brms 30 format (/,4x,'Average Unsigned Difference :',30x,f12.4, & /,4x,'Root Mean Square Deviation :',31x,f12.4) end if end if c c compute the RMS between QM and Tinker bond angles c aave = 0.0d0 arms = 0.0d0 if (fit_struct) then if (prtflg.eq.1 .and. nangle.ne.0) then write (iout,40) 40 format (/,' Comparison of Bond Angles :', & //,5x,'Angle',10x,'Atoms',16x,'QM Angle', & 5x,'MM Angle',8x,'Delta',/) end if do i = 1, nangle ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) xab = x(ia) - x(ib) yab = y(ia) - y(ib) zab = z(ia) - z(ib) xcb = x(ic) - x(ib) ycb = y(ic) - y(ib) zcb = z(ic) - z(ib) rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0) rabc = sqrt(rab2*rcb2) cosine = (xab*xcb + yab*ycb + zab*zcb) / rabc cosine = min(1.0d0,max(-1.0d0,cosine)) angle = radian * acos(cosine) xab = gx(ia) - gx(ib) yab = gy(ia) - gy(ib) zab = gz(ia) - gz(ib) xcb = gx(ic) - gx(ib) ycb = gy(ic) - gy(ib) zcb = gz(ic) - gz(ib) rab2 = max(xab*xab+yab*yab+zab*zab,0.0001d0) rcb2 = max(xcb*xcb+ycb*ycb+zcb*zcb,0.0001d0) rabc = sqrt(rab2*rcb2) cosine = (xab*xcb + yab*ycb + zab*zcb) / rabc cosine = min(1.0d0,max(-1.0d0,cosine)) gangle = radian * acos(cosine) delta = angle - gangle aave = aave + abs(delta) arms = arms + delta*delta if (prtflg .eq. 1) then write (iout,50) i,ia,ib,ic,gangle,angle,delta 50 format (4x,i5,4x,3i5,8x,2f13.2,f13.4) end if end do if (nangle .ne. 0) aave = aave / (dble(nangle)) if (nangle .ne. 0) arms = sqrt(arms/dble(nangle)) if (prtflg.eq.1 .and. nangle.ne.0) then write (iout,60) aave,arms 60 format (/,4x,'Average Unsigned Difference :',30x,f12.4, & /,4x,'Root Mean Square Deviation :',31x,f12.4) end if end if c c compute the RMS between QM and Tinker torsion angles c tave = 0.0d0 trms = 0.0d0 if (fit_struct) then if (prtflg.eq.1 .and. ntors.ne.0) then write (iout,70) 70 format (/,' Comparison of Torsion Angles :', & //,4x,'Torsion',12x,'Atoms',13x,'QM Angle', & 5x,'MM Angle',8x,'Delta',/) end if do i = 1, ntors ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) xba = x(ib) - x(ia) yba = y(ib) - y(ia) zba = z(ib) - z(ia) xcb = x(ic) - x(ib) ycb = y(ic) - y(ib) zcb = z(ic) - z(ib) xdc = x(id) - x(ic) ydc = y(id) - y(ic) zdc = z(id) - z(ic) 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 = xt*xt + yt*yt + zt*zt ru2 = xu*xu + yu*yu + zu*zu rtru = sqrt(rt2 * ru2) if (rtru .ne. 0.0d0) then rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb) 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 end if xba = gx(ib) - gx(ia) yba = gy(ib) - gy(ia) zba = gz(ib) - gz(ia) xcb = gx(ic) - gx(ib) ycb = gy(ic) - gy(ib) zcb = gz(ic) - gz(ib) xdc = gx(id) - gx(ic) ydc = gy(id) - gy(ic) zdc = gz(id) - gz(ic) 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 = xt*xt + yt*yt + zt*zt ru2 = xu*xu + yu*yu + zu*zu rtru = sqrt(rt2 * ru2) if (rtru .ne. 0.0d0) then rcb = sqrt(xcb*xcb + ycb*ycb + zcb*zcb) 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)) gangle = radian * acos(cosine) if (sine .lt. 0.0d0) gangle = -gangle end if delta = angle - gangle if (delta .gt. 180.0d0) delta = delta - 360.0d0 if (delta .lt. -180.0d0) delta = delta + 360.0d0 tave = tave + abs(delta) trms = trms + delta*delta if (prtflg .eq. 1) then write (iout,80) i,ia,ib,ic,id,gangle,angle,delta 80 format (4x,i5,4x,4i5,3x,2f13.2,f13.4) end if end do if (ntors .ne. 0) tave = tave / (dble(ntors)) if (ntors .ne. 0) trms = sqrt(trms/dble(ntors)) if (prtflg.eq.1 .and. ntors.ne.0) then write (iout,90) tave,trms 90 format (/,4x,'Average Unsigned Difference :',30x,f12.4, & /,4x,'Root Mean Square Deviation :',31x,f12.4) end if end if c c compute the RMS between QM and Tinker gradient components c gave = 0.0d0 grms = 0.0d0 if (fit_force) then allocate (derivs(3,n)) call gradient (energy,derivs) if (prtflg .eq. 1) then write (iout,100) 100 format (/,' Comparison of Gradient Components :', & //,7x,'Atom',14x,'QM Grad',8x,'MM Grad', & 10x,'Delta',/) end if do i = 1, n do j = 1, 3 delta = gforce(j,i) - derivs(j,i) gave = gave + abs(delta) grms = grms + delta*delta if (prtflg .eq. 1) then write (iout,110) i,axis(j),gforce(j,i), & derivs(j,i),delta 110 format (4x,i5,1x,a1,8x,f13.4,2x,f13.4,2x,f13.4) end if end do end do gave = gave / dble(3*n) grms = sqrt(grms/dble(3*n)) if (prtflg .eq. 1) then write (iout,120) gave,grms 120 format (/,4x,'Average Unsigned Difference :',17x,f12.4, & /,4x,'Root Mean Square Deviation :',18x,f12.4) end if deallocate (derivs) end if c c perform dynamic allocation of some local arrays c nfreq = 3 * n allocate (mass2(n)) allocate (hinit(3,n)) allocate (hstop(3,n)) allocate (hdiag(3,n)) allocate (hindex((nfreq*(nfreq-1))/2)) allocate (h((nfreq*(nfreq-1))/2)) allocate (matrix((nfreq*(nfreq+1))/2)) c c calculate the full Hessian matrix of second derivatives c hesscut = 0.0d0 call hessian (h,hinit,hstop,hindex,hdiag) c c compute the RMS between QM and Tinker Hessian elements c have = 0.0d0 hrms = 0.0d0 if (fit_force) then if (prtflg .eq. 1) then write (iout,130) 130 format (/,' Comparison of Hessian Elements :', & //,7x,'Atom',14x,'QM Hess',8x,'MM Hess', & 10x,'Delta',/) end if do i = 1, n do j = 1, 3 m1 = 3*(i-1) + j m = m1*(m1+1) / 2 delta = gh(m) - hdiag(j,i) have = have + abs(delta) hrms = hrms + delta*delta if (prtflg .eq. 1) then write (iout,140) i,axis(j),gh(m),hdiag(j,i),delta 140 format (4x,i5,1x,a1,8x,f13.2,2x,f13.2,2x,f13.4) end if m1 = 3*(i-1) + j m2 = m1 do k = hinit(j,i), hstop(j,i) m2 = m2 + 1 m = m1 + m2*(m2-1)/2 delta = gh(m) - h(k) have = have + abs(delta) hrms = hrms + delta* delta end do end do end do have = have / dble((9*n*n+3*n)/2) hrms = sqrt(hrms/dble((9*n*n+3*n)/2)) if (prtflg .eq. 1) then write (iout,150) have,hrms 150 format (/,4x,'Average Unsigned Difference :',17x,f12.4, & /,4x,'Root Mean Square Deviation :',18x,f12.4) end if end if c c set atomic mass roots needed for vibrational analysis c do i = 1, n mass2(i) = sqrt(mass(i)) end do c c store upper triangle of the mass-weighted Hessian matrix c ihess = 0 do i = 1, n do j = 1, 3 ihess = ihess + 1 matrix(ihess) = hdiag(j,i) / mass(i) do k = hinit(j,i), hstop(j,i) m = (hindex(k)+2) / 3 ihess = ihess + 1 matrix(ihess) = h(k) / (mass2(i)*mass2(m)) end do end do end do c c perform dynamic allocation of some local arrays c allocate (eigen(nfreq)) allocate (vects(nfreq,nfreq)) c c diagonalize to get vibrational frequencies and normal modes c call diagq (nfreq,nfreq,matrix,eigen,vects) factor = sqrt(ekcal) / (2.0d0*pi*lightspd) do i = 1, nfreq eigen(i) = factor * sign(1.0d0,eigen(i)) * sqrt(abs(eigen(i))) end do c c compute the RMS between QM and Tinker vibrational frequencies c fcut = 800.0d0 if (fit_tors) fcut = 200.0d0 fave = 0.0d0 frms = 0.0d0 if (prtflg .eq. 1) then write (iout,160) 160 format (/,' Comparison of Vibrational Frequencies :', & //,6x,'Mode',15x,'QM Freq',8x,'MM Freq',10x,'Delta',/) end if k = 0 do i = nfreq, 7, -1 if (gfreq(i-6) .gt. fcut) then k = k + 1 delta = eigen(i) - gfreq(i-6) fave = fave + abs(delta) frms = frms + delta*delta if (prtflg .eq. 1) then write (iout,170) k,gfreq(i-6),eigen(i),delta 170 format (4x,i5,10x,f13.2,2x,f13.2,2x,f13.4) end if end if end do fave = fave / (dble(k)) frms = sqrt(frms/dble(k)) if (prtflg .eq. 1) then write (iout,180) fave,frms 180 format (/,4x,'Average Unsigned Difference :',17x,f12.4, & /,4x,'Root Mean Square Deviation :',18x,f12.4) end if c c perform deallocation of some local arrays c deallocate (mass2) deallocate (hinit) deallocate (hstop) deallocate (hdiag) deallocate (hindex) deallocate (h) deallocate (matrix) deallocate (eigen) deallocate (vects) c c sum weighted RMS values to get overall error function c bfac = 100.0d0 afac = 10.0d0 tfac = 1.0d0 gfac = 10.0d0 hfac = 0.1d0 ffac = 0.1d0 valrms = bfac*brms + afac*arms + tfac*trms & + gfac*grms + hfac*hrms + ffac*frms return end c c c ############################################################## c ## ## c ## function valmin1 -- energy and gradient for minimize ## c ## ## c ############################################################## c c c "valmin1" is a service routine that computes the molecular c energy and gradient during valence parameter optimization c c function valmin1 (xx,g) use atoms use scales use usage implicit none integer i,nvar real*8 valmin1,e real*8 energy,eps real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) logical analytic external energy c c c use either analytical or numerical gradients c analytic = .true. eps = 0.00001d0 c c convert optimization parameters to atomic coordinates c nvar = 0 do i = 1, n if (use(i)) then nvar = nvar + 1 x(i) = xx(nvar) / scale(nvar) nvar = nvar + 1 y(i) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(i) = xx(nvar) / scale(nvar) end if end do c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute and store the energy and gradient c if (analytic) then call gradient (e,derivs) else e = energy () call numgrad (energy,derivs,eps) end if valmin1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, n if (use(i)) then nvar = nvar + 1 g(nvar) = derivs(1,i) / scale(nvar) nvar = nvar + 1 g(nvar) = derivs(2,i) / scale(nvar) nvar = nvar + 1 g(nvar) = derivs(3,i) / scale(nvar) end if end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ############################################################ c ## ## c ## subroutine prmvar -- valence terms to optimization ## c ## ## c ############################################################ c c c "prmvar" determines the optimization values from the c corresponding valence potential energy parameters c c subroutine prmvar (nvar,xx) use angbnd use atomid use atoms use bndstr use iounit use opbend use strbnd use tors use units use urey use valfit implicit none integer i,k,ii,kk integer ia,ib,ic,id integer ka,kb,kc,kd integer ita,itb,itc,itd integer kta,ktb,ktc,ktd integer nvar,size real*8 xx(*) logical done character*4 pa,pb,pc,pd character*8 pitb,pktb character*12 pita,pkta character*16 pitt,pktt c c c zero out the total number of optimization parameters c nvar = 0 c c print a header for the parameters used in fitting c if (fit_struct) then write (iout,10) 10 format (/,' Valence Parameters Used in Structure Fitting :') else if (fit_force) then write (iout,20) 20 format (/,' Valence Parameters Used in Force Fitting :') end if write (iout,30) 30 format (/,' Parameter',10x,'Atom Classes',10x,'Category', & 12x,'Value',5x,'Fixed',/) c c find bond stretch force constants and target lengths c do i = 1, nbond done = .false. ia = ibnd(1,i) ib = ibnd(2,i) ita = class(ia) itb = class(ib) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pitb = pa//pb else pitb = pb//pa end if do k = 1, i-1 ka = ibnd(1,k) kb = ibnd(2,k) kta = class(ka) ktb = class(kb) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) if (kta .le. ktb) then pktb = pa//pb else pktb = pb//pa end if if (pktb .eq. pitb) done = .true. end do if (.not. done) then if (fit_bond .and. bk(i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = bk(i) write (iout,40) nvar,ita,itb,'Bond Force',bk(i) 40 format (i6,5x,2i6,19x,a10,3x,f12.4) nvar = nvar + 1 xx(nvar) = bl(i) xx(nvar) = 100.0d0 * xx(nvar) write (iout,50) nvar,ita,itb,'Bond Length',bl(i) 50 format (i6,5x,2i6,19x,a11,2x,f12.4) else write (iout,60) ita,itb,'Bond Force',bk(i) 60 format (4x,'--',5x,2i6,19x,a10,3x,f12.4,7x,'X') write (iout,70) ita,itb,'Bond Length',bl(i) 70 format (4x,'--',5x,2i6,19x,a11,2x,f12.4,7x,'X') end if end if end do c c find angle bend force constants and target angles c do i = 1, nangle done = .false. ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pita = pa//pb//pc else pita = pc//pb//pa end if do k = 1, i-1 ka = iang(1,k) kb = iang(2,k) kc = iang(3,k) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) done = .true. end do if (.not. done) then if (fit_angle .and. ak(i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = ak(i) write (iout,80) nvar,ita,itb,itc,'Angle Force',ak(i) 80 format (i6,5x,3i6,13x,a11,2x,f12.4) nvar = nvar + 1 xx(nvar) = anat(i) write (iout,90) nvar,ita,itb,itc,'Angle Value',anat(i) 90 format (i6,5x,3i6,13x,a11,2x,f12.4) else write (iout,100) ita,itb,itc,'Angle Force',ak(i) 100 format (4x,'--',5x,3i6,13x,a11,2x,f12.4,7x,'X') write (iout,110) ita,itb,itc,'Angle Value',anat(i) 110 format (4x,'--',5x,3i6,13x,a11,2x,f12.4,7x,'X') end if end if end do c c find stretch-bend force constant parameter values c do i = 1, nstrbnd done = .false. ii = isb(1,i) ia = iang(1,ii) ib = iang(2,ii) ic = iang(3,ii) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pita = pa//pb//pc else pita = pc//pb//pa end if do k = 1, i-1 kk = isb(1,k) ka = iang(1,kk) kb = iang(2,kk) kc = iang(3,kk) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) done = .true. end do if (.not. done) then if (fit_strbnd .and. sbk(1,i).ne.0.0d0 & .and. sbk(2,i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = sbk(1,i) write (iout,120) nvar,ita,itb,itc,'StrBnd-1',sbk(1,i) 120 format (i6,5x,3i6,13x,a8,5x,f12.4) nvar = nvar + 1 xx(nvar) = sbk(2,i) write (iout,130) nvar,ita,itb,itc,'StrBnd-2',sbk(2,i) 130 format (i6,5x,3i6,13x,a8,5x,f12.4) else write (iout,140) ita,itb,itc,'StrBnd-1',sbk(1,i) 140 format (4x,'--',5x,3i6,13x,a8,5x,f12.4,7x,'X') write (iout,150) ita,itb,itc,'StrBnd-2',sbk(2,i) 150 format (4x,'--',5x,3i6,13x,a8,5x,f12.4,7x,'X') end if end if end do c c find Urey-Bradley force constant parameter values c do i = 1, nurey done = .false. ia = iury(1,i) ib = iury(2,i) ic = iury(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pita = pa//pb//pc else pita = pc//pb//pa end if do k = 1, i-1 ka = iury(1,k) kb = iury(2,k) kc = iury(3,k) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) done = .true. end do if (.not. done) then if (fit_urey .and. uk(i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = uk(i) write (iout,160) nvar,ita,itb,itc,'Urey Force',uk(i) 160 format (i6,5x,3i6,13x,a10,3x,f12.4) nvar = nvar + 1 xx(nvar) = ul(i) write (iout,170) nvar,ita,itb,itc,'Urey Dist',ul(i) 170 format (i6,5x,3i6,13x,a9,4x,f12.4) else write (iout,180) ita,itb,itc,'Urey Force',uk(i) 180 format (4x,'--',5x,3i6,13x,a10,3x,f12.4,7x,'X') write (iout,190) ita,itb,itc,'Urey Dist',ul(i) 190 format (4x,'--',5x,3i6,13x,a9,4x,f12.4,7x,'X') end if end if end do c c find out-of-plane bend force constant parameter values c do i = 1, nopbend done = .false. ii = iopb(i) ia = iang(1,ii) ib = iang(2,ii) ic = iang(3,ii) id = iang(4,ii) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (ita .le. itc) then pitt = pd//pb//pa//pc else pitt = pd//pb//pc//pa end if do k = 1, i-1 kk = iopb(k) ka = iang(1,kk) kb = iang(2,kk) kc = iang(3,kk) kd = iang(4,kk) kta = class(ka) ktb = class(kb) ktc = class(kc) ktd = class(kd) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) call numeral (ktd,pd,size) if (kta .le. ktc) then pktt = pd//pb//pa//pc else pktt = pd//pb//pc//pa end if if (pktt .eq. pitt) done = .true. end do if (.not. done) then if (fit_opbend .and. opbk(i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = opbk(i) write (iout,200) nvar,itd,itb,min(ita,itc), & max(ita,itc),'O-P-Bend',opbk(i) 200 format (i6,5x,4i6,7x,a8,5x,f12.4) else write (iout,210) itd,itb,min(ita,itc),max(ita,itc), & 'O-P-Bend',opbk(i) 210 format (4x,'--',5x,4i6,7x,a8,5x,f12.4,7x,'X') end if end if end do c c find torsional angle amplitude parameter values c do i = 1, ntors done = .false. ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb.lt.itc .or. (itb.eq.itc.and.ita.le.itd)) then pitt = pa//pb//pc//pd else pitt = pd//pc//pb//pa end if do k = 1, i-1 ka = itors(1,k) kb = itors(2,k) kc = itors(3,k) kd = itors(4,k) kta = class(ka) ktb = class(kb) ktc = class(kc) ktd = class(kd) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) call numeral (ktd,pd,size) if (ktb.lt.ktc .or. (ktb.eq.ktc.and.kta.le.ktd)) then pktt = pa//pb//pc//pd else pktt = pd//pc//pb//pa end if if (pktt .eq. pitt) done = .true. end do if (.not. done) then if (fit_tors .and. tors1(1,i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = tors1(1,i) write (iout,220) nvar,ita,itb,itc,itd, & 'Torsion-1',tors1(1,i) 220 format (i6,5x,4i6,7x,a9,4x,f12.4) else write (iout,230) ita,itb,itc,itd,'Torsion-1',tors1(1,i) 230 format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X') end if if (fit_tors .and. tors2(1,i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = tors2(1,i) write (iout,240) nvar,ita,itb,itc,itd, & 'Torsion-2',tors2(1,i) 240 format (i6,5x,4i6,7x,a9,4x,f12.4) else write (iout,250) ita,itb,itc,itd,'Torsion-2',tors2(1,i) 250 format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X') end if if (fit_tors .and. tors3(1,i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = tors3(1,i) write (iout,260) nvar,ita,itb,itc,itd, & 'Torsion-3',tors3(1,i) 260 format (i6,5x,4i6,7x,a9,4x,f12.4) else write (iout,270) ita,itb,itc,itd,'Torsion-3',tors3(1,i) 270 format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X') end if if (fit_tors .and. tors4(1,i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = tors4(1,i) write (iout,280) nvar,ita,itb,itc,itd, & 'Torsion-4',tors4(1,i) 280 format (i6,5x,4i6,7x,a9,4x,f12.4) else if (tors4(1,i) .ne. 0.0d0) then write (iout,290) ita,itb,itc,itd,'Torsion-4',tors4(1,i) 290 format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X') end if if (fit_tors .and. tors5(1,i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = tors5(1,i) write (iout,300) nvar,ita,itb,itc,itd, & 'Torsion-5',tors5(1,i) 300 format (i6,5x,4i6,7x,a9,4x,f12.4) else if (tors5(1,i) .ne. 0.0d0) then write (iout,310) ita,itb,itc,itd,'Torsion-5',tors5(1,i) 310 format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X') end if if (fit_tors .and. tors6(1,i).ne.0.0d0) then nvar = nvar + 1 xx(nvar) = tors6(1,i) write (iout,320) nvar,ita,itb,itc,itd, & 'Torsion-6',tors6(1,i) 320 format (i6,5x,4i6,7x,a9,4x,f12.4) else if (tors6(1,i) .ne. 0.0d0) then write (iout,330) ita,itb,itc,itd,'Torsion-6',tors6(1,i) 330 format (4x,'--',5x,4i6,7x,a9,4x,f12.4,7x,'X') end if end if end do return end c c c ############################################################ c ## ## c ## subroutine varprm -- optimization to valence terms ## c ## ## c ############################################################ c c c "varprm" copies the current optimization values into the c corresponding valence potential energy parameters c c subroutine varprm (nvar,xx,ivar,eps) use angbnd use atoms use atomid use bndstr use opbend use potent use strbnd use tors use urey use valfit implicit none integer i,k,ii,kk integer nvar,ivar,size integer ia,ib,ic,id integer ka,kb,kc,kd integer ita,itb,itc,itd integer kta,ktb,ktc,ktd real*8 eps real*8 xx(*) logical done character*4 pa,pb,pc,pd character*8 pitb,pktb character*12 pita,pkta character*16 pitt,pktt c c c zero out the total number of optimization parameters c nvar = 0 c c translate optimization values to bond stretch parameters c do i = 1, nbond done = .false. ia = ibnd(1,i) ib = ibnd(2,i) ita = class(ia) itb = class(ib) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pitb = pa//pb else pitb = pb//pa end if do k = 1, i-1 ka = ibnd(1,k) kb = ibnd(2,k) kta = class(ka) ktb = class(kb) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) if (kta .le. ktb) then pktb = pa//pb else pktb = pb//pa end if if (pktb .eq. pitb) done = .true. end do if (.not. done) then if (fit_bond .and. bk(i).ne.0.0d0) then nvar = nvar + 1 bk(i) = xx(nvar) if (ivar .eq. nvar) bk(i) = bk(i) + eps nvar = nvar + 1 bl(i) = xx(nvar) if (ivar .eq. nvar) bl(i) = bl(i) + eps bl(i) = 0.01d0 * bl(i) do k = i+1, nbond ka = ibnd(1,k) kb = ibnd(2,k) kta = class(ka) ktb = class(kb) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) if (kta .le. ktb) then pktb = pa//pb else pktb = pb//pa end if if (pktb .eq. pitb) then bk(k) = bk(i) bl(k) = bl(i) end if end do end if end if end do c c translate optimization values to angle bend parameters c do i = 1, nangle done = .false. ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pita = pa//pb//pc else pita = pc//pb//pa end if do k = 1, i-1 ka = iang(1,k) kb = iang(2,k) kc = iang(3,k) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) done = .true. end do if (.not. done) then if (fit_angle .and. ak(i).ne.0.0d0) then nvar = nvar + 1 ak(i) = xx(nvar) if (ivar .eq. nvar) ak(i) = ak(i) + eps nvar = nvar + 1 anat(i) = xx(nvar) if (ivar .eq. nvar) anat(i) = anat(i) + eps do k = i+1, nangle ka = iang(1,k) kb = iang(2,k) kc = iang(3,k) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) then ak(k) = ak(i) anat(k) = anat(i) end if end do end if end if end do c c translate optimization values to stretch-bend parameters c do i = 1, nstrbnd done = .false. ii = isb(1,i) ia = iang(1,ii) ib = iang(2,ii) ic = iang(3,ii) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pita = pa//pb//pc else pita = pc//pb//pa end if do k = 1, i-1 kk = isb(1,k) ka = iang(1,kk) kb = iang(2,kk) kc = iang(3,kk) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) done = .true. end do if (.not.done .and. fit_strbnd) then if (sbk(1,i) .ne. 0.0d0) then nvar = nvar + 1 sbk(1,i) = xx(nvar) if (ivar .eq. nvar) sbk(1,i) = sbk(1,i) + eps end if if (sbk(2,i) .ne. 0.0d0) then nvar = nvar + 1 sbk(2,i) = xx(nvar) if (ivar .eq. nvar) sbk(2,i) = sbk(2,i) + eps end if do k = i+1, nstrbnd kk = isb(1,k) ka = iang(1,kk) kb = iang(2,kk) kc = iang(3,kk) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) then if (kta .eq. ita) then sbk(1,k) = sbk(1,i) sbk(2,k) = sbk(2,i) else sbk(2,k) = sbk(1,i) sbk(1,k) = sbk(2,i) end if end if end do end if end do c c translate optimization values to Urey-Bradley parameters c do i = 1, nurey done = .false. ia = iury(1,i) ib = iury(2,i) ic = iury(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pita = pa//pb//pc else pita = pc//pb//pa end if do k = 1, i-1 ka = iury(1,k) kb = iury(2,k) kc = iury(3,k) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) done = .true. end do if (.not. done) then if (fit_urey .and. uk(i).ne.0.0d0) then nvar = nvar + 1 uk(i) = xx(nvar) if (ivar .eq. nvar) uk(i) = uk(i) + eps nvar = nvar + 1 ul(i) = xx(nvar) if (ivar .eq. nvar) ul(i) = ul(i) + eps do k = i+1, nurey ka = iury(1,k) kb = iury(2,k) kc = iury(3,k) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) then uk(k) = uk(i) ul(k) = ul(i) end if end do end if end if end do c c translate optimization values to out-of-plane bend parameters c do i = 1, nopbend done = .false. ii = iopb(i) ia = iang(1,ii) ib = iang(2,ii) ic = iang(3,ii) id = iang(4,ii) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (ita .le. itc) then pitt = pd//pb//pa//pc else pitt = pd//pb//pc//pa end if do k = 1, i-1 kk = iopb(k) ka = iang(1,kk) kb = iang(2,kk) kc = iang(3,kk) kd = iang(4,kk) kta = class(ka) ktb = class(kb) ktc = class(kc) ktd = class(kd) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) call numeral (ktd,pd,size) if (kta .le. ktc) then pktt = pd//pb//pa//pc else pktt = pd//pb//pc//pa end if if (pktt .eq. pitt) done = .true. end do if (.not. done) then if (fit_opbend .and. opbk(i).ne.0.0d0) then nvar = nvar + 1 opbk(i) = xx(nvar) if (ivar .eq. nvar) opbk(i) = opbk(i) + eps do k = i+1, nopbend kk = iopb(k) ka = iang(1,kk) kb = iang(2,kk) kc = iang(3,kk) kd = iang(4,kk) kta = class(ka) ktb = class(kb) ktc = class(kc) ktd = class(kd) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) call numeral (ktd,pd,size) if (kta .le. ktc) then pktt = pd//pb//pa//pc else pktt = pd//pb//pc//pa end if if (pktt.eq.pitt) opbk(k) = opbk(i) end do end if end if end do c c translate optimization values to torsional parameters c do i = 1, ntors done = .false. ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb.lt.itc .or. (itb.eq.itc.and.ita.le.itd)) then pitt = pa//pb//pc//pd else pitt = pd//pc//pb//pa end if do k = 1, i-1 ka = itors(1,k) kb = itors(2,k) kc = itors(3,k) kd = itors(4,k) kta = class(ka) ktb = class(kb) ktc = class(kc) ktd = class(kd) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) call numeral (ktd,pd,size) if (ktb.lt.ktc .or. (ktb.eq.ktc.and.kta.le.ktd)) then pktt = pa//pb//pc//pd else pktt = pd//pc//pb//pa end if if (pktt .eq. pitt) done = .true. end do if (.not.done .and. fit_tors) then if (tors1(1,i) .ne. 0.0d0) then nvar = nvar + 1 tors1(1,i) = xx(nvar) if (ivar .eq. nvar) tors1(1,i) = tors1(1,i) + eps end if if (tors2(1,i) .ne. 0.0d0) then nvar = nvar + 1 tors2(1,i) = xx(nvar) if (ivar .eq. nvar) tors2(1,i) = tors2(1,i) + eps end if if (tors3(1,i) .ne. 0.0d0) then nvar = nvar + 1 tors3(1,i) = xx(nvar) if (ivar .eq. nvar) tors3(1,i) = tors3(1,i) + eps end if if (tors4(1,i) .ne. 0.0d0) then nvar = nvar + 1 tors4(1,i) = xx(nvar) if (ivar .eq. nvar) tors4(1,i) = tors4(1,i) + eps end if if (tors5(1,i) .ne. 0.0d0) then nvar = nvar + 1 tors5(1,i) = xx(nvar) if (ivar .eq. nvar) tors5(1,i) = tors5(1,i) + eps end if if (tors6(1,i) .ne. 0.0d0) then nvar = nvar + 1 tors6(1,i) = xx(nvar) if (ivar .eq. nvar) tors6(1,i) = tors6(1,i) + eps end if do k = i+1, ntors ka = itors(1,k) kb = itors(2,k) kc = itors(3,k) kd = itors(4,k) kta = class(ka) ktb = class(kb) ktc = class(kc) ktd = class(kd) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) call numeral (ktd,pd,size) if (ktb.lt.ktc .or. (ktb.eq.ktc.and.kta.le.ktd)) then pktt = pa//pb//pc//pd else pktt = pd//pc//pb//pa end if if (pktt .eq. pitt) then tors1(1,k) = tors1(1,i) tors2(1,k) = tors2(1,i) tors3(1,k) = tors3(1,i) tors4(1,k) = tors4(1,i) tors5(1,k) = tors5(1,i) tors6(1,k) = tors6(1,i) end if end do end if end do return end c c c ############################################################ c ## ## c ## function valfit1 -- valence fit error and gradient ## c ## ## c ############################################################ c c c "valfit1" is a service routine that computes the RMS error c and gradient for valence parameters fit to QM results c c function valfit1 (xx,g) use atoms use potent use valfit implicit none integer i,k integer nvar real*8 e,e0 real*8 delta real*8 valrms real*8 valfit1 real*8 xx(*) real*8 g(*) real*8, allocatable :: eps(:) c c c copy optimization values to valence parameters c call varprm (nvar,xx,0,0.0d0) c c perform dynamic allocation of some local arrays c allocate (eps(nvar)) c c set the numerical gradient step size for each parameter c delta = 0.0000001d0 do i = 1, nvar eps(i) = delta * xx(i) end do c c get the RMS of frequencies c valfit1 = valrms(0) c c compute numerical gradient for valence parameters c k = nvar do i = 1, k call varprm (nvar,xx,i,-0.5d0*eps(i)) e0 = valrms(0) call varprm (nvar,xx,i,0.5d0*eps(i)) e = valrms(0) g(i) = (e-e0) / eps(i) end do c c perform deallocation of some local arrays c deallocate (eps) return end c c c ################################################################# c ## ## c ## subroutine prtval -- print final valence parameter fit ## c ## ## c ################################################################# c c c "prtval" writes the final valence parameter results to the c standard output and appends the values to a key file c c subroutine prtval use angbnd use atomid use atoms use bndstr use files use iounit use keys use opbend use strbnd use tors use units use urey use valfit implicit none integer i,k,ii,kk integer ia,ib,ic,id integer ka,kb,kc,kd integer ita,itb,itc,itd integer kta,ktb,ktc,ktd integer ikey,size integer freeunit integer trimtext logical done character*4 pa,pb,pc,pd character*8 pitb,pktb character*12 pita,pkta character*16 pitt,pktt character*240 keyfile character*240 record c c c output some definitions and parameters to a keyfile c ikey = freeunit () keyfile = filename(1:leng)//'.key' call version (keyfile,'new') open (unit=ikey,file=keyfile,status='new') c c copy the contents of any previously existing keyfile c do i = 1, nkey record = keyline(i) size = trimtext (record) write (ikey,10) record(1:size) 10 format (a) end do c c print a header for the fitted valence parameters c if (fit_bond .or. fit_angle .or. fit_tors & .or. fit_strbnd .or. fit_opbend) then write (ikey,20) 20 format (/,'#',/,'# Results of Valence Parameter Fitting', & /,'#',/) end if c c output any fitted bond stretch parameter values c do i = 1, nbond done = .false. ia = ibnd(1,i) ib = ibnd(2,i) ita = class(ia) itb = class(ib) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then pitb = pa//pb else pitb = pb//pa end if do k = 1, i-1 ka = ibnd(1,k) kb = ibnd(2,k) kta = class(ka) ktb = class(kb) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) if (kta .le. ktb) then pktb = pa//pb else pktb = pb//pa end if if (pktb .eq. pitb) done = .true. end do if (.not. done) then if (fit_bond) then write (ikey,30) ita,itb,bk(i),bl(i) 30 format ('bond',6x,2i5,5x,f11.2,f11.4) end if end if end do c c output any fitted angle bend parameter values c do i = 1, nangle done = .false. ia = iang(1,i) ib = iang(2,i) ic = iang(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pita = pa//pb//pc else pita = pc//pb//pa end if do k = 1, i-1 ka = iang(1,k) kb = iang(2,k) kc = iang(3,k) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) done = .true. end do if (.not. done) then if (fit_angle) then write (ikey,40) ita,itb,itc,ak(i),anat(i) 40 format ('angle',5x,3i5,f11.2,f11.2) end if end if end do c c output any fitted stretch-bend parameter values c do i = 1, nstrbnd done = .false. ii = isb(1,i) ia = iang(1,ii) ib = iang(2,ii) ic = iang(3,ii) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pita = pa//pb//pc else pita = pc//pb//pa end if do k = 1, i-1 kk = isb(1,k) ka = iang(1,kk) kb = iang(2,kk) kc = iang(3,kk) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) done = .true. end do if (.not. done) then if (fit_strbnd) then write (ikey,50) ita,itb,itc,sbk(1,i),sbk(2,i) 50 format ('strbnd',4x,3i5,2f11.3) end if end if end do c c output any fitted Urey-Bradley parameter values c do i = 1, nurey done = .false. ia = iury(1,i) ib = iury(2,i) ic = iury(3,i) ita = class(ia) itb = class(ib) itc = class(ic) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pita = pa//pb//pc else pita = pc//pb//pa end if do k = 1, i-1 ka = iury(1,k) kb = iury(2,k) kc = iury(3,k) kta = class(ka) ktb = class(kb) ktc = class(kc) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) if (kta .le. ktc) then pkta = pa//pb//pc else pkta = pc//pb//pa end if if (pkta .eq. pita) done = .true. end do if (.not. done) then if (fit_urey) then write (ikey,60) ita,itb,itc,uk(i),ul(i) 60 format ('ureybrad',2x,3i5,f11.3,f11.4) end if end if end do c c output any fitted out-of-plane bend parameter values c do i = 1, nopbend done = .false. ii = iopb(i) ia = iang(1,ii) ib = iang(2,ii) ic = iang(3,ii) id = iang(4,ii) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (ita .le. itc) then pitt = pd//pb//pa//pc else pitt = pd//pb//pc//pa end if do k = 1, i-1 kk = iopb(k) ka = iang(1,kk) kb = iang(2,kk) kc = iang(3,kk) kd = iang(4,kk) kta = class(ka) ktb = class(kb) ktc = class(kc) ktd = class(kd) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) call numeral (ktd,pd,size) if (kta .le. ktc) then pktt = pd//pb//pa//pc else pktt = pd//pb//pc//pa end if if (pktt .eq. pitt) done = .true. end do if (.not. done) then if (fit_opbend) then write (ikey,70) itd,itb,min(ita,itc), & max(ita,itc),opbk(i) 70 format ('opbend',4x,4i5,6x,f11.2) end if end if end do c c output any fitted torsional parameter values c do i = 1, ntors done = .false. ia = itors(1,i) ib = itors(2,i) ic = itors(3,i) id = itors(4,i) ita = class(ia) itb = class(ib) itc = class(ic) itd = class(id) size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) call numeral (itd,pd,size) if (itb.lt.itc .or. (itb.eq.itc.and.ita.le.itd)) then pitt = pa//pb//pc//pd else pitt = pd//pc//pb//pa end if do k = 1, i-1 ka = itors(1,k) kb = itors(2,k) kc = itors(3,k) kd = itors(4,k) kta = class(ka) ktb = class(kb) ktc = class(kc) ktd = class(kd) size = 4 call numeral (kta,pa,size) call numeral (ktb,pb,size) call numeral (ktc,pc,size) call numeral (ktd,pd,size) if (ktb.lt.ktc .or. (ktb.eq.ktc.and.kta.le.ktd)) then pktt = pa//pb//pc//pd else pktt = pd//pc//pb//pa end if if (pktt .eq. pitt) done = .true. end do if (.not. done) then if (fit_tors) then write (ikey,80) ita,itb,itc,itd,tors1(1,i), & tors2(1,i),tors3(1,i) 80 format ('torsion',3x,4i5,3x,f8.3,' 0.0 1',f8.3, & ' 180.0 2',f8.3,' 0.0 3') end if end if end do return end c c c ############################################################## c ## COPYRIGHT (C) 2008 by Chuanjie Wu & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################## c c ################################################################ c ## ## c ## module valfit -- valence term parameter fitting values ## c ## ## c ################################################################ c c c fit_bond logical flag to fit bond stretch parameters c fit_angle logical flag to fit angle bend parameters c fit_strbnd logical flag to fit stretch-bend parameters c fit_urey logical flag to fit Urey-Bradley parameters c fit_opbend logical flag to fit out-of-plane bend parameters c fit_tors logical flag to fit torsional parameters c fit_struct logical flag to structure-fit valence parameters c fit_force logical flag to force-fit valence parameters c c module valfit implicit none logical fit_bond,fit_angle logical fit_strbnd,fit_urey logical fit_opbend,fit_tors logical fit_struct,fit_force save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module vdw -- van der Waals terms in current structure ## c ## ## c ################################################################ c c c nvdw total number van der Waals sites in the system c ivdw number of the atom for each van der Waals site c jvdw index into the vdw parameter matrix for each atom c mvdw index into the vdw parameter matrix for each class c ired attached atom from which reduction factor is applied c kred value of reduction factor parameter for each atom c xred reduced x-coordinate for each atom in the system c yred reduced y-coordinate for each atom in the system c zred reduced z-coordinate for each atom in the system c radmin minimum energy distance for each atom class pair c epsilon well depth parameter for each atom class pair c radmin4 minimum energy distance for 1-4 interaction pairs c epsilon4 well depth parameter for 1-4 interaction pairs c radhbnd minimum energy distance for hydrogen bonding pairs c epshbnd well depth parameter for hydrogen bonding pairs c c module vdw implicit none integer nvdw integer, allocatable :: ivdw(:) integer, allocatable :: jvdw(:) integer, allocatable :: mvdw(:) integer, allocatable :: ired(:) real*8, allocatable :: kred(:) real*8, allocatable :: xred(:) real*8, allocatable :: yred(:) real*8, allocatable :: zred(:) real*8, allocatable :: radmin(:,:) real*8, allocatable :: epsilon(:,:) real*8, allocatable :: radmin4(:,:) real*8, allocatable :: epsilon4(:,:) real*8, allocatable :: radhbnd(:,:) real*8, allocatable :: epshbnd(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## module vdwpot -- van der Waals functional form details ## c ## ## c ################################################################ c c c igauss coefficients of Gaussian fit to vdw potential c ngauss number of Gaussians used in fit to vdw potential c abuck value of "A" constant in Buckingham vdw potential c bbuck value of "B" constant in Buckingham vdw potential c cbuck value of "C" constant in Buckingham vdw potential c ghal value of "gamma" in buffered 14-7 vdw potential c dhal value of "delta" in buffered 14-7 vdw potential c v2scale factor by which 1-2 vdw interactions are scaled c v3scale factor by which 1-3 vdw interactions are scaled c v4scale factor by which 1-4 vdw interactions are scaled c v5scale factor by which 1-5 vdw interactions are scaled c use_vcorr flag to use long range van der Waals correction c vdwindex indexing mode (atom type or class) for vdw parameters c vdwtyp type of van der Waals potential energy function c radtyp type of parameter (sigma or R-min) for atomic size c radsiz atomic size provided as radius or diameter c radrule combining rule for atomic size parameters c epsrule combining rule for vdw well depth parameters c gausstyp type of Gaussian fit to van der Waals potential c c module vdwpot implicit none integer maxgauss parameter (maxgauss=10) integer ngauss real*8 igauss(2,maxgauss) real*8 abuck,bbuck,cbuck real*8 ghal,dhal real*8 v2scale,v3scale real*8 v4scale,v5scale logical use_vcorr character*5 vdwindex character*5 radtyp character*8 radsiz,gausstyp character*10 radrule,epsrule character*13 vdwtyp save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## subroutine verlet -- Verlet molecular dynamics step ## c ## ## c ############################################################# c c c "verlet" performs a single molecular dynamics time step c via the velocity Verlet multistep recursion formula c c subroutine verlet (istep,dt) use atomid use atoms use freeze use ielscf use moldyn use polar use units use usage implicit none integer i,j,k integer istep real*8 dt,dt_2 real*8 etot,epot real*8 eksum real*8 temp,pres real*8 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 for the dynamics integration c dt_2 = 0.5d0 * dt 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 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 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 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 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 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) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## subroutine version -- create version number for file ## c ## ## c ############################################################## c c c "version" checks the name of a file about to be opened; if c if "old" status is passed, the name of the highest current c version is returned; if "new" status is passed the filename c of the next available unused version is generated c c subroutine version (string,status) use iounit use output implicit none integer i,leng,trimtext integer thousand,hundred integer tens,ones logical exist character*1 digit(0:9) character*3 status character*240 oldfile character*240 newfile character*(*) string data digit / '0','1','2','3','4','5','6','7','8','9' / c c c process the filename and status variables c call lowcase (status) leng = trimtext (string) c c no change is needed if the file doesn't exist c exist = .false. if (leng .ne. 0) inquire (file=string,exist=exist) if (.not. exist) return c c set initial values for the current and next versions c newfile = string oldfile = string c c append an artificial version number to the filename; c currently handles up to 10000 versions of a file c if (.not. noversion) then i = 1 do while (exist) i = i + 1 oldfile = newfile thousand = i / 1000 hundred = (i - 1000*thousand) / 100 tens = (i - 1000*thousand - 100*hundred) / 10 ones = i - 1000*thousand - 100*hundred - 10*tens if (thousand .ne. 0) then newfile = string(1:leng)//'_'//digit(thousand) & //digit(hundred)//digit(tens)//digit(ones) else if (hundred .ne. 0) then newfile = string(1:leng)//'_'//digit(hundred) & //digit(tens)//digit(ones) else if (tens .ne. 0) then newfile = string(1:leng)//'_'//digit(tens)//digit(ones) else newfile = string(1:leng)//'_'//digit(ones) end if inquire (file=newfile,exist=exist) end do end if c c set the file name based on the requested status c if (status .eq. 'old') then string = oldfile else if (status .eq. 'new') then string = newfile inquire (file=string,exist=exist) if (exist) then call nextarg (string,exist) if (exist) then inquire (file=string,exist=exist) else exist = .true. end if do while (exist) write (iout,10) 10 format (/,' Enter File Name for Coordinate Output : ',$) read (input,20) string 20 format (a240) inquire (file=string,exist=exist) end do end if end if return end c c c ################################################################# c ## COPYRIGHT (C) 2007 by Alexey Kaledin & Jay William Ponder ## c ## All Rights Reserved ## c ################################################################# c c ################################################################ c ## ## c ## program vibbig -- block iterative vibrational analysis ## c ## ## c ################################################################ c c c "vibbig" performs large-scale vibrational mode analysis using c only vector storage and gradient evaluations; preconditioning c is via an approximate inverse from a block diagonal Hessian, c and a sliding block method is used to converge any number of c eigenvectors starting from either lowest or highest frequency c c literature references: c c C. Murray, S. C. Racine and E. R. Davidson, "Improved Algorithms c for the Lowest Few Eigenvalues and Associated Eigenvectors of c Large Matrices", Journal of Computational Physics, 103, 382-389 c (1992) c c A. L. Kaledin, "Gradient-Based Direct Normal-Mode Analysis", c Journal of Chemical Physics, 122, 184106 (2005) c c A. L. Kaledin, M. Kaledin and J. M. Bowman, "All-Atom Calculation c of the Normal Modes of Bacteriorhodopsin Using a Sliding Block c Iterative Diagonalization Method", Journal of Chemical Theory c and Computation, 2, 166-174 (2006) c c program vibbig use atomid use atoms use files use inform use iounit use keys use units use vibs implicit none integer i,j,k,ii,next integer i1,i2,k0,k1,k2 integer ivib,ivb1,ivb2 integer iblock,iconv integer iter,isave integer nvar,nblk integer nroot,nbasis integer nr,npair integer nlock,nconv integer irange,ifactor integer maxroot,maxiter integer maxhess integer freeunit integer, allocatable :: iblk(:) real*8 fmax,funit real*8 wtol,factor real*8 size,sizmax real*8 space,sum real*8 dfreq,rnorm,rcomp real*8 ratio,shift real*8 uku_min,uku_max real*8, allocatable :: xe(:) real*8, allocatable :: xm(:) real*8, allocatable :: r(:) real*8, allocatable :: rk(:) real*8, allocatable :: hmin(:) real*8, allocatable :: uku(:) real*8, allocatable :: uku0(:) real*8, allocatable :: uu(:) real*8, allocatable :: freq(:) real*8, allocatable :: freqold(:) real*8, allocatable :: tmp1(:) real*8, allocatable :: tmp2(:) real*8, allocatable :: u(:,:) real*8, allocatable :: ur(:,:) real*8, allocatable :: h(:,:) real*8, allocatable :: c(:,:) character*1 answer character*20 keyword character*240 record character*240 string character*240 datafile character*240 blockfile logical exist,restart logical header,done c c c set up the structure and mechanics calculation c call initial call getxyz call mechanic c c set default parameters for the normal mode computation c nvar = 3 * n maxroot = 50 nr = 6 iter = 0 isave = 10 maxhess = nvar * (nvar-1) / 2 maxiter = 100000 wtol = 0.00001d0 sizmax = 500.0d0 header = .true. c c search the keywords for normal mode parameters c do i = 1, nkey next = 1 record = keyline(i) call gettext (record,keyword,next) call upcase (keyword) string = record(next:240) if (keyword(1:8) .eq. 'MAXITER ') then read (string,*,err=10,end=10) maxiter else if (keyword(1:11) .eq. 'SAVE-VECTS ') then read (string,*,err=10,end=10) isave else if (keyword(1:10) .eq. 'VIB-ROOTS ') then read (string,*,err=10,end=10) nroot nroot = min(nroot,maxroot) else if (keyword(1:14) .eq. 'VIB-TOLERANCE ') then read (string,*,err=10,end=10) wtol end if 10 continue end do c c find either the lowest or highest normal modes c factor = 1.0d0 call nextarg (answer,exist) if (.not. exist) then answer = 'L' write (iout,20) answer 20 format (/,' Start at Lowest or Highest Frequency', & ' Normal Mode [',a1,'] : ',$) read (input,30) record 30 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) if (answer .eq. 'H') factor = -1.0d0 c c find cutoff value for desired extreme frequency c fmax = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=40,end=40) fmax 40 continue if (fmax .le. 0.0d0) then write (iout,50) 50 format (/,' Enter Desired Frequency Cutoff in cm-1', & ' [0.0] : ',$) read (input,60) fmax 60 format (f20.0) end if if (fmax .le. 0.0d0) fmax = 0.0d0 c c set default values for some additional parameters c funit = factor * efreq * emass ifactor = int(factor) irange = (nvar-nr+1) * max((1-ifactor)/2,0) npair = 2 * nroot nbasis = 3 * nroot c c open or create eigenvector file for use during restarts c ivb1 = freeunit () datafile = filename(1:leng)//'.vb1' call version (datafile,'old') inquire (file=datafile,exist=exist) if (exist) then open (unit=ivb1,file=datafile,status='old',form='unformatted') else open (unit=ivb1,file=datafile,status='new',form='unformatted') end if c c open or create basis vector file for use during restarts c ivb2 = freeunit () datafile = filename(1:leng)//'.vb2' call version (datafile,'old') inquire (file=datafile,exist=exist) if (exist) then restart = .true. open (unit=ivb2,file=datafile,status='old',form='unformatted') else restart = .false. open (unit=ivb2,file=datafile,status='new',form='unformatted') end if c c perform dynamic allocation of some local arrays c allocate (iblk(n)) allocate (xe(nvar)) allocate (xm(nvar)) allocate (r(nvar)) allocate (rk(nvar)) allocate (hmin(nvar)) allocate (uku(nvar)) allocate (uku0(nvar)) allocate (uu(maxhess)) allocate (u(nvar,6)) allocate (ur(nvar,3)) c c perform dynamic allocation of some global arrays c allocate (rho(nvar,nbasis)) allocate (rhok(nvar,nbasis)) allocate (rwork(nvar,nbasis)) c c store a coordinate vector for each atom c do i = 1, n xe(3*i-2) = x(i) / bohr xe(3*i-1) = y(i) / bohr xe(3*i) = z(i) / bohr end do c c store atomic mass for each coordinate component c k = 0 do i = 1, n mass(i) = mass(i) * emass do j = 1, 3 k = k + 1 xm(k) = mass(i) end do end do c c remove pure translational and rotational modes c call trbasis (nvar,nr,xe,u,ur) c c set number and size of blocks based on storage space c space = 0.9d0 * dble(maxhess) do i = 1, n size = 9.0d0 * (dble(n))**2 / dble(i) if (size .lt. space) then nblk = i goto 70 end if end do 70 continue nblk = max(3,nblk) size = dble(n) / dble(nblk) size = min(size,sizmax) do i = 1, nblk iblk(i) = nint(dble(i)*size) end do do i = nblk, 2, -1 iblk(i) = iblk(i) - iblk(i-1) end do c c get number and size of blocks from an external file c iblock = freeunit () blockfile = filename(1:leng)//'.blk' call version (blockfile,'old') inquire (file=blockfile,exist=exist) if (exist) then open (unit=iblock,file=blockfile,status='old') i = 0 do while (.true.) i = i + 1 read (iblock,*,err=80,end=80) iblk(i) end do 80 continue nblk = i - 1 close (unit=iblock) end if c c print info about the atom blocks and preconditioning c write (iout,90) 90 format (/,' Atom Blocks Used to Subdivide the System :',/) k = 0 do i = 1, nblk write (iout,100) i,iblk(i),k+1,k+iblk(i) 100 format (' Block :',i7,9x,'Size :',i7,9x,'Atoms :',i7,' to',i7) k = k + iblk(i) end do k = 0 do i = 1, nblk k = k + 9*iblk(i)**2 end do write (iout,110) k 110 format (/,' Storage for Preconditioning Array :',5x,i12) c c determine number of prior modes available at restart c nlock = 0 do while (.true.) read (ivb1,err=120,end=120) (r(k),k=1,nvar) nlock = nlock + 1 end do 120 continue rewind (unit=ivb1) if (nlock .ne. 0) then write (iout,130) nlock 130 format (/,' Prior Normal Modes Available at Restart :',i11) end if nconv = nlock c c compute and diagonalize the Hessian for each block c k0 = 0 i1 = 1 do i = 1, nblk if (i .gt. 1) then k0 = k0 + 9*iblk(i-1)**2 i1 = i1 + iblk(i-1) end if i2 = i1 + iblk(i) - 1 k1 = 3*i1 - 2 k2 = 3*i2 call hessblk (mass,k0,i1,i2,uu) call diagblk (k0,k1,3*iblk(i),uu,uku) end do c c use negative of eigenvalues if doing high frequencies c do k = 1, nvar uku(k) = factor * uku(k) uku0(k) = uku(k) end do uku_max = uku(1) uku_min = uku(1) do k = 2, nvar if (uku(k) .gt. uku_max) uku_max = uku(k) if (uku(k) .lt. uku_min) uku_min = uku(k) end do c c perform dynamic allocation of some local arrays c allocate (freq(nbasis)) allocate (freqold(nbasis)) allocate (tmp1(nbasis)) allocate (tmp2(nbasis)) allocate (h(nbasis,nbasis)) allocate (c(nbasis,nbasis)) c c if restarting, read trial vectors and estimate eigenvalues c if (restart) then do i = 1, npair read (ivb2) (rho(k,i),k=1,nvar) read (ivb2) (rhok(k,i),k=1,nvar) end do do i = 1, nroot h(i,i) = 0.0d0 do k = 1, nvar h(i,i) = h(i,i) + rhok(k,i)*rho(k,i) end do freqold(i) = sign(1.0d0,h(i,i)) * sqrt(abs(h(i,i))) end do goto 140 end if c c if not restarting, generate initial guess eigenvectors c do i = 1, nroot call trigger (nvar,nbasis,nr,ifactor,nblk,iblk,u,uu,r) do k = 1, nvar rho(k,i) = r(k) end do end do c c project out locked roots from components of rho c call project (nvar,nconv,ivb1,nroot,0) call projectk (nvar,nconv,ivb1,nroot,0) c c reload and make vector orthonormal to existing basis c do i = 1, nroot do k = 1, nvar r(k) = rho(k,i) end do if (i .eq. 1) then sum = 0.0d0 do k = 1, nvar sum = sum + r(k)*r(k) end do sum = sqrt(sum) do k = 1, nvar r(k) = r(k) / sum end do else call gsort (nvar,i-1,r) end if do k = 1, nvar rho(k,i) = r(k) end do end do c c store K on rho c do i = 1, nroot do k = 1, nvar r(k) = rho(k,i) end do call konvec (nvar,xm,xe,r,rk) do k = 1, nvar rhok(k,i) = factor * rk(k) end do end do c c make nroot-by-nroot CI matrix c do i = 1, nroot do j = i, nroot h(i,j) = 0.0d0 do k = 1, nvar h(i,j) = h(i,j) + rhok(k,i)*rho(k,j) end do h(j,i) = h(i,j) end do end do c c diagonalize and use first nroot solutions as starting basis c call transform (nroot,nbasis,h,c) c c fill up arrays c do k = 1, nvar do j = 1, nroot tmp1(j) = 0.0d0 tmp2(j) = 0.0d0 do i = 1, nroot tmp1(j) = tmp1(j) + c(i,j)*rho(k,i) tmp2(j) = tmp2(j) + c(i,j)*rhok(k,i) end do end do do j = 1, nroot rho(k,j) = tmp1(j) rhok(k,j) = tmp2(j) end do end do c c residues of guesses c do i = 1, nroot freq(i) = funit * sign(1.0d0,h(i,i)) * sqrt(abs(h(i,i))) freqold(i) = freq(i) do k = 1, nvar rk(k) = rhok(k,i) - h(i,i)*rho(k,i) end do c c use Davidson preconditioner if finding low frequencies c if (factor .gt. 0.0d0) then call preconblk (nvar,nblk,iblk,uku,uu,h(i,i),hmin(i),rk) end if c c project residual onto P-space c call qonvec (nvar,nr,u,rk,r) do k = 1, nvar rho(k,i+nroot) = r(k) end do end do c c project out locked roots from components of rho c call project (nvar,nconv,ivb1,nroot,nroot) call projectk (nvar,nconv,ivb1,nroot,nroot) c c reload and make vector orthonormal to existing basis c do i = 1, nroot do k = 1, nvar r(k) = rho(k,i+nroot) end do call gsort (nvar,nroot+i-1,r) do k = 1, nvar rho(k,i+nroot) = r(k) end do end do c c store K on rho c do i = 1, nroot do k = 1, nvar r(k) = rho(k,i+nroot) end do call konvec (nvar,xm,xe,r,rk) do k = 1, nvar rhok(k,i+nroot) = factor * rk(k) end do end do c c make npair-by-npair CI matrix c do i = 1, npair do j = i, npair h(i,j) = 0.0d0 do k = 1, nvar h(i,j) = h(i,j) + rhok(k,i)*rho(k,j) end do h(j,i) = h(i,j) end do end do c c diagonalize and use first nroot solutions as new guess c call transform (npair,nbasis,h,c) do k = 1, nvar do j = 1, nroot tmp1(j) = 0.0d0 tmp2(j) = 0.0d0 do i = 1, npair tmp1(j) = tmp1(j) + c(i,j)*rho(k,i) tmp2(j) = tmp2(j) + c(i,j)*rhok(k,i) end do end do c c old solution fills up 2nd block c do j = 1, nroot rho(k,j+nroot) = rho(k,j) rhok(k,j+nroot) = rhok(k,j) end do c c new solution fills up 1st block c do j = 1, nroot rho(k,j) = tmp1(j) rhok(k,j) = tmp2(j) end do c c orthogonalize 2nd block to 1st c do j = 1, nroot do i = 1, nroot rho(k,j+nroot) = rho(k,j+nroot) - c(j,i)*rho(k,i) rhok(k,j+nroot) = rhok(k,j+nroot) - c(j,i)*rhok(k,i) end do end do end do c c orthogonalize 2nd block on itself c sum = 0.0d0 do k = 1, nvar sum = sum + rho(k,nroot+1)*rho(k,nroot+1) end do sum = sqrt(sum) c c normalize leading vector c do k = 1, nvar rho(k,nroot+1) = rho(k,nroot+1) / sum rhok(k,nroot+1) = rhok(k,nroot+1) / sum end do c c orthogonalize the rest one-by-one c if (nroot .gt. 1) then do i = 2, max(2,nroot) do j = 1, i-1 sum = 0.0d0 do k = 1, nvar sum = sum + rho(k,i+nroot)*rho(k,j+nroot) end do do k = 1, nvar rho(k,i+nroot) = rho(k,i+nroot)-sum*rho(k,j+nroot) rhok(k,i+nroot) = rhok(k,i+nroot)-sum*rhok(k,j+nroot) end do end do sum = 0.0d0 do k = 1, nvar sum = sum + rho(k,i+nroot)*rho(k,i+nroot) end do sum = sqrt(sum) do k = 1, nvar rho(k,i+nroot) = rho(k,i+nroot) / sum rhok(k,i+nroot) = rhok(k,i+nroot) / sum end do end do end if c c residue of new solution (if restarting, begin here) c 140 continue do i = 1, nroot freq(i) = funit * sign(1.0d0,h(i,i)) * sqrt(abs(h(i,i))) freq(i+nroot) = funit * sign(1.0d0,h(i+nroot,i+nroot)) & * sqrt(abs(h(i+nroot,i+nroot))) freq(i+npair) = funit * sign(1.0d0,h(i+npair,i+npair)) & * sqrt(abs(h(i+npair,i+npair))) do k = 1, nvar rk(k) = rhok(k,i) - h(i,i)*rho(k,i) end do c c use Davidson preconditioner if finding low frequencies c if (factor .gt. 0.0d0) then call preconblk (nvar,nblk,iblk,uku,uu,h(i,i),hmin(i),rk) end if c c project onto P-space c call qonvec (nvar,nr,u,rk,r) do k = 1, nvar rho(k,i+npair) = r(k) end do end do c c project out locked roots from components of rho c call project (nvar,nconv,ivb1,nroot,npair) call projectk (nvar,nconv,ivb1,nroot,npair) c c reload and orthogonalize to 1st + 2nd c do i = 1, nroot do k = 1, nvar r(k) = rho(k,i+npair) end do call gsort (nvar,npair+i-1,r) do k = 1, nvar rho(k,i+npair) = r(k) end do end do c c store K on rho c do i = 1, nroot do k = 1, nvar r(k) = rho(k,i+npair) end do call konvec (nvar,xm,xe,r,rk) do k = 1, nvar rhok(k,i+npair) = factor * rk(k) end do end do c c beginning of iterations c iconv = 0 150 continue done = .false. iter = iter + 1 c c make nbasis-by-nbasis CI matrix c do i = 1, nbasis do j = i, nbasis h(i,j) = 0.0d0 do k = 1, nvar h(i,j) = h(i,j) + rhok(k,i)*rho(k,j) end do h(j,i) = h(i,j) end do end do c c list of previous frequencies c do i = 1, npair freqold(i) = freq(i) end do c c diagonalize and use first nroot solutions as new guess c call transform (nbasis,nbasis,h,c) c c check for collapse based on leading component of ground state c if (iconv.eq.0 .and. nconv.gt.0) then sum = sqrt(1.0d0-c(1,1)**2) if (sum .gt. 0.9d0) then write (iout,160) nconv-nlock 160 format (/,' Number of Converged Normal Modes :',6x,i12) write (iout,170) 170 format (/,' VIBBIG -- Loss of Root Identity; Please', & ' Try to Restart') close (unit=ivb2,status='delete') goto 270 end if end if c c list of new frequencies c do i = 1, npair freq(i) = funit * sign(1.0d0,h(i,i)) * sqrt(abs(h(i,i))) end do c c check if first few have converged c iconv = 0 180 continue dfreq = freqold(iconv+1) - freq(iconv+1) if (dfreq*factor.gt.0.0d0 .and. dfreq*factor.lt.wtol) then iconv = iconv + 1 goto 180 end if c c shift levels of preconditioner matrix; since the Hessian c is gradually deflated, reduce effect of the preconditioner c based on a simple 1/x curve, the uku levels are squeezed c upwards to eventually lead to a unit operator c if (iconv .gt. 0) then ratio = dble(nconv+iconv) / dble(nvar) shift = uku_min / (1.0d0-ratio) shift = shift + h(iconv+nroot,iconv+nroot) c c do a regular shift, which also seems to work c do k = 1, nvar uku(k) = uku_max + (uku0(k)-uku_max)*(uku_max-shift) & / (uku_max-uku_min) end do c c move cursor to end of storage file c do i = 1, nconv read (ivb1) (rk(k),k=1,nvar) end do c c norm of residual c do j = 1, iconv rnorm = 0.0d0 do k = 1, nvar r(k) = 0.0d0 rk(k) = 0.0d0 do i = 1, nbasis r(k) = r(k)+c(i,j)*rho(k,i) rk(k) = rk(k)+c(i,j)*rhok(k,i) end do rnorm = rnorm + (rk(k)-h(j,j)*r(k))**2 end do rnorm = sqrt(rnorm) c c component of root in R-space c do i = 1, 3 tmp1(i) = 0.0d0 do k = 1, nvar tmp1(i) = tmp1(i) + ur(k,i)*r(k) end do end do rcomp = 0.0d0 do k = 1, nvar sum = 0.0d0 do i = 1, 3 sum = sum + ur(k,i)*tmp1(i) end do rcomp = rcomp + sum*sum end do rcomp = sqrt(rcomp) c c write the converged mode to formatted and binary files c ivib = irange + ifactor*(nconv+j) if ((header.or.verbose) .and. j.eq.1) then header = .false. write (iout,190) 190 format (/,' Converged Normal Modes from Iterative', & ' Vibrational Analysis :') write (iout,200) 200 format (/,4x,'Mode',7x,'Frequency',8x,'Delta',10x, & 'R Norm',10x,'Orthog') if (.not. verbose) then write (iout,210) 210 format () end if end if dfreq = freqold(j) - freq(j) write (iout,220) ivib,freq(j),dfreq,rnorm,rcomp 220 format (i8,f15.3,3d16.4) call prtvib (ivib,r) write (ivb1) (r(k),k=1,nvar) end do rewind (unit=ivb1) c c update total number of vectors locked on disk c nconv = nconv + iconv if (freq(iconv)*factor .ge. fmax*factor) then done = .true. close (unit=ivb1) end if end if c c shift frequency arrays by iconv c do i = 1, npair freq(i) = freq(i+iconv) freqold(i) = freqold(i+iconv) end do do k = 1, nvar do j = 1, nroot+iconv tmp1(j) = 0.0d0 tmp2(j) = 0.0d0 do i = 1, nbasis tmp1(j) = tmp1(j) + c(i,j)*rho(k,i) tmp2(j) = tmp2(j) + c(i,j)*rhok(k,i) end do end do c c old solution fills up 2nd block c do j = 1, nroot rho(k,j+nroot+iconv) = rho(k,j+iconv) rhok(k,j+nroot+iconv) = rhok(k,j+iconv) end do c c new solution fills up 1st block c do j = 1, nroot rho(k,j+iconv) = tmp1(j+iconv) rhok(k,j+iconv) = tmp2(j+iconv) end do c c shift index down by iconv c do j = 1, npair rho(k,j) = rho(k,j+iconv) rhok(k,j) = rhok(k,j+iconv) end do c c orthogonalize 2nd block to 1st + iconv roots c do j = 1, nroot do i = 1, nroot rho(k,j+nroot) = rho(k,j+nroot) & - c(j+iconv,i+iconv)*rho(k,i) rhok(k,j+nroot) = rhok(k,j+nroot) & - c(j+iconv,i+iconv)*rhok(k,i) end do do i = 1, iconv rho(k,j+nroot) = rho(k,j+nroot) - c(j+iconv,i)*tmp1(i) rhok(k,j+nroot) = rhok(k,j+nroot) - c(j+iconv,i)*tmp2(i) end do end do end do c c orthogonalize 2nd block on itself c sum = 0.0d0 do k = 1, nvar sum = sum + rho(k,nroot+1)*rho(k,nroot+1) end do sum = sqrt(sum) c c normalize leading vector c do k = 1, nvar rho(k,nroot+1) = rho(k,nroot+1) / sum rhok(k,nroot+1) = rhok(k,nroot+1) / sum end do c c orthogonalize the rest one-by-one c if (nroot .gt. 1) then do i = 2, max(2,nroot) do j = 1, i-1 sum = 0.0d0 do k = 1, nvar sum = sum + rho(k,i+nroot)*rho(k,j+nroot) end do do k = 1, nvar rho(k,i+nroot) = rho(k,i+nroot)-sum*rho(k,j+nroot) rhok(k,i+nroot) = rhok(k,i+nroot)-sum*rhok(k,j+nroot) end do end do sum = 0.0d0 do k = 1, nvar sum = sum + rho(k,i+nroot)*rho(k,i+nroot) end do sum = sqrt(sum) do k = 1, nvar rho(k,i+nroot) = rho(k,i+nroot) / sum rhok(k,i+nroot) = rhok(k,i+nroot) / sum end do end do end if c c print a header for the current iteration c if (verbose) then write (iout,230) iter,iconv,nconv 230 format (/,' Iteration',i7,11x,'New Modes',i6,10x, & ' Total Modes',i6,/) write (iout,240) 240 format (4x,'Mode',7x,'Frequency',8x,'Delta',10x, & 'R Norm',10x,'Orthog') end if c c norm of residual c do i = 1, nroot rnorm = 0.0d0 do k = 1, nvar rnorm = rnorm + (rhok(k,i)-h(i+iconv,i+iconv)*rho(k,i))**2 end do rnorm = sqrt(rnorm) c c calculate root's component in R-space c do j = 1, 3 tmp1(j) = 0.0d0 do k = 1, nvar tmp1(j) = tmp1(j) + ur(k,j)*rho(k,i) end do end do rcomp = 0.0d0 do k = 1, nvar sum = 0.0d0 do j = 1, 3 sum = sum + ur(k,j)*tmp1(j) end do rcomp = rcomp + sum*sum end do rcomp = sqrt(rcomp) dfreq = freqold(i) - freq(i) if (verbose) then write (iout,250) irange+ifactor*(i+nconv), & freq(i),dfreq,rnorm,rcomp 250 format (i8,f15.3,3d16.4) end if end do c c save vectors needed to restart a calculation c if (mod(iter,isave) .eq. 0) then rewind (unit=ivb2) do i = 1, npair write (ivb2) (rho(k,i),k=1,nvar) write (ivb2) (rhok(k,i),k=1,nvar) end do end if c c prepare restart if finished or iterations exhausted c if (done .or. iter.eq.maxiter) then write (iout,260) nconv-nlock 260 format (/,' Number of Converged Normal Modes :',6x,i12) rewind (ivb2) do i = 1, npair write (ivb2) (rho(k,i),k=1,nvar) write (ivb2) (rhok(k,i),k=1,nvar) end do close (unit=ivb2) goto 270 end if c c as above, make sure no prior roots are mixed in the basis c do i = 1, npair do k = 1, nvar r(k) = rho(k,i) end do call qonvec (nvar,nr,u,r,rk) do k = 1, nvar rho(k,i) = rk(k) end do do k = 1, nvar r(k) = rhok(k,i) end do call qonvec (nvar,nr,u,r,rk) do k = 1, nvar rhok(k,i) = rk(k) end do end do c c project out locked roots from components of rho c call project (nvar,nconv,ivb1,npair,0) call projectk (nvar,nconv,ivb1,npair,0) c c setup next iteration; solution residue, Davidson weight c do i = 1, nroot do k = 1, nvar rk(k) = rhok(k,i) - h(i+iconv,i+iconv)*rho(k,i) end do c c use Davidson preconditioner if finding low frequencies c ii = i + iconv if (factor .gt. 0.0d0) then call preconblk (nvar,nblk,iblk,uku,uu,h(ii,ii),hmin(i),rk) end if c c project residual onto R-space c call qonvec (nvar,nr,u,rk,r) do k = 1, nvar rho(k,i+npair) = r(k) end do end do c c project out locked roots from components of rho c call project (nvar,nconv,ivb1,nroot,npair) c c reload and orthogonalize to 1st + 2nd c do i = 1, nroot do k = 1, nvar r(k) = rho(k,i+npair) end do call gsort (nvar,npair+i-1,r) do k = 1, nvar rho(k,i+npair) = r(k) end do end do c c store K on rho c do i= 1, nroot do k = 1, nvar r(k) = rho(k,i+npair) end do call konvec (nvar,xm,xe,r,rk) call qonvec(nvar,nr,u,rk,r) do k = 1, nvar rhok(k,i+npair) = factor * r(k) end do end do c c project out locked roots from components of rhok c call projectk (nvar,nconv,ivb1,nroot,npair) goto 150 270 continue c c perform deallocation of some local arrays c deallocate (iblk) deallocate (xe) deallocate (xm) deallocate (r) deallocate (rk) deallocate (hmin) deallocate (uku) deallocate (uku0) deallocate (uu) deallocate (u) deallocate (ur) deallocate (freq) deallocate (freqold) deallocate (tmp1) deallocate (tmp2) deallocate (h) deallocate (c) c c perform any final tasks before program exit c call final end c c c ############################################################## c ## ## c ## subroutine trigger -- get initial trial eigenvectors ## c ## ## c ############################################################## c c c "trigger" constructs a set of initial trial vectors for c use during sliding block iterative matrix diagonalization c c subroutine trigger (nvar,nbasis,nr,ifactor,nblk,iblk,u,uu,r) implicit none integer i,j,k,m integer k0,k1,k2 integer nvar,nbasis integer nr,ifactor integer nblk,nguess integer iblk(*) real*8 w,sum real*8 random real*8 r(*) real*8 uu(*) real*8 u(nvar,*) real*8, allocatable :: tmp(:) external random c c c set the number of random guesses c nguess = 1 + int(dble(nbasis)/dble(nblk)) c c zero out the trial vector c do k = 1, nvar r(k) = 0.0d0 end do c c create overlap with the entire P-space c k0 = 0 k1 = 1 do i = 1, nblk if (i .gt. 1) then k0 = k0 + 9*iblk(i-1)**2 k1 = k1 + 3*iblk(i-1) end if k2 = k1 + 3*iblk(i) - 1 c c scan over rows of the Hessian c m = 0 do j = 1, 3*iblk(i) if (ifactor .eq. 1) then if (j .gt. min(nguess,3*iblk(i))) then w = 0.0d0 else w = random() - 0.5d0 end if else if (j .lt. (3*iblk(i)-min(nguess,3*iblk(i))+1)) then w = 0.0d0 else w = random() - 0.5d0 end if end if do k = k1, k2 m = m + 1 r(k) = r(k) + w*uu(k0+m) end do end do end do c c perform dynamic allocation of some local arrays c allocate (tmp(nvar)) c c project the vector onto P-space c call qonvec (nvar,nr,u,r,tmp) c c perform a normalization c sum = 0.0d0 do i = 1, nvar sum = sum + tmp(i)**2 end do sum = sqrt(sum) do i = 1, nvar r(i) = tmp(i) / sum end do c c perform deallocation of some local arrays c deallocate (tmp) return end c c c ################################################################ c ## ## c ## subroutine trbasis -- set translation/rotation vectors ## c ## ## c ################################################################ c c c "trbasis" forms translation and rotation basis vectors used c during vibrational analysis via block iterative diagonalization c c subroutine trbasis (nvar,nr,xe,u,ur) use atomid use atoms implicit none integer i,j,k integer nvar,nr real*8 tmass,sum real*8 ra,rha,pr real*8 cm(3) real*8 r(3) real*8 e(3,3) real*8 c(3,3) real*8 xe(*) real*8 u(nvar,*) real*8 ur(nvar,*) c c c zero out the translation and rotation vectors c do i = 1, 6 do j = 1, nvar u(j,i) = 0.0d0 end do end do c c get the total mass of the system c tmass = 0.0d0 do i = 1, n tmass = tmass + mass(i) end do c c set basis vectors for translations c do i = 1, n u(3*i-2,1) = sqrt(mass(i)/tmass) u(3*i-1,1) = 0.0d0 u(3*i,1) = 0.0d0 u(3*i-2,2) = 0.0d0 u(3*i-1,2) = sqrt(mass(i)/tmass) u(3*i,2) = 0.0d0 u(3*i-2,3) = 0.0d0 u(3*i-1,3) = 0.0d0 u(3*i,3) = sqrt(mass(i)/tmass) end do c c move center of mass to origin c do i = 1, 3 cm(i) = 0.0d0 end do do i = 1, n do j = 1, 3 cm(j) = cm(j) + xe(3*(i-1)+j)*mass(i) end do end do do i = 1, n do j = 1, 3 xe(3*(i-1)+j) = xe(3*(i-1)+j) - cm(j)/tmass end do end do c c get the moments of inertia c do i = 1, 3 e(i,i) = 0.0d0 end do do i = 1, n e(1,1) = e(1,1) + ((xe(3*i-1)**2+xe(3*i)**2))*mass(i) e(2,2) = e(2,2) + ((xe(3*i-2)**2+xe(3*i)**2))*mass(i) e(3,3) = e(3,3) + ((xe(3*i-2)**2+xe(3*i-1)**2))*mass(i) end do do i = 1, 2 do j = i+1, 3 e(i,j) = 0.0d0 do k = 1, n e(i,j) = e(i,j) - xe(3*(k-1)+i)*xe(3*(k-1)+j)*mass(k) end do e(j,i) = e(i,j) end do end do c c diagonalize to get principal axes c call jacobi (3,e,cm,c) c c construction of principle rotations c do i = 1, 3 do j = 1, n ra = 0.0d0 pr = 0.0d0 do k = 1, 3 cm(k) = xe(3*(j-1)+k) ra = ra + cm(k)**2 pr = pr + cm(k)*c(k,i) end do rha = sqrt(ra-pr**2) r(1) = c(2,i)*cm(3) - c(3,i)*cm(2) r(2) = c(3,i)*cm(1) - c(1,i)*cm(3) r(3) = c(1,i)*cm(2) - c(2,i)*cm(1) sum = 0.0d0 do k = 1, 3 sum = sum + r(k)**2 end do sum = sqrt(sum) do k = 1, 3 ur(3*(j-1)+k,i) = sqrt(mass(j)) * rha*r(k)/sum end do end do sum = 0.0d0 do j = 1, nvar sum = sum + ur(j,i)**2 end do sum = sqrt(sum) do j = 1, nvar ur(j,i) = ur(j,i) / sum end do end do c c set basis vectors for rotation c if (nr .eq. 6) then do i = 1, 3 do j = 1, nvar u(j,i+3) = ur(j,i) end do end do end if return end c c c ################################################################# c ## ## c ## subroutine preconblk -- precondition atom block Hessian ## c ## ## c ################################################################# c c c "preconblk" applies a preconditioner to an atom block section c of the Hessian matrix c c subroutine preconblk (nvar,nblk,iblk,uku,uu,h,hmin,rk) implicit none integer i,j,k,l integer nvar,nblk integer k0,k1,k2,l2 integer iblk(*) real*8 h,hmin real*8 uku(*) real*8 rk(*) real*8 uu(*) real*8, allocatable :: d(:) real*8, allocatable :: work(:) c c c find smallest element of |h-uku| c hmin = abs(h-uku(1)) do k = 2, nvar if (abs(h-uku(k)) .lt. hmin) then hmin = abs(h-uku(k)) end if end do c c perform dynamic allocation of some local arrays c allocate (d(nvar)) allocate (work(nvar)) c c assign values to temporary array c do k = 1, nvar d(k) = h - uku(k) end do c c invert array via d=hmin/d, where hmin=min{|d(k)|} c do k = 1, nvar d(k) = hmin / d(k) end do c c create overlap with the entire rk array c k0 = 0 k1 = 1 do i = 1, nblk if (i .gt. 1) then k0 = k0 + 9*iblk(i-1)**2 k1 = k1 + 3*iblk(i-1) end if k2 = k1 + 3*iblk(i) - 1 c c scan over rows of the Hessian, first part c l = 0 do j = 1, 3*iblk(i) l2 = k1 + j - 1 work(l2) = 0.0d0 do k = k1, k2 l = l + 1 work(l2) = work(l2) + uu(k0+l)*rk(k) end do end do c c zero out the segment c do k = k1, k2 rk(k) = 0.0d0 end do c c scan over rows of the Hessian, second part c l = 0 do j = 1, 3*iblk(i) l2 = k1 + j - 1 do k = k1, k2 l = l + 1 rk(k) = rk(k) + uu(k0+l)*d(l2)*work(l2) end do end do end do c c perform deallocation of some local arrays c deallocate (d) deallocate (work) return end c c c ################################################################ c ## ## c ## subroutine gsort -- orthogonal vector via Gram-Schmidt ## c ## ## c ################################################################ c c c "gsort" uses the Gram-Schmidt algorithm to build orthogonal c vectors for sliding block interative matrix diagonalization c c subroutine gsort (nvar,nb,r0) use vibs implicit none integer i,j integer nvar,nb real*8 sum real*8 r0(*) real*8, allocatable :: s(:) real*8, allocatable :: proj(:) c c c perform dynamic allocation of some local arrays c allocate (s(nb)) allocate (proj(nvar)) c c make overlap between two basis sets c do i = 1, nb s(i) = 0.0d0 do j = 1, nvar s(i) = s(i) + r0(j)*rho(j,i) end do end do c c start the Gram-Schmidt procedure c do i = 1, nvar proj(i) = 0.0d0 end do c c construct projector c do i = 1, nb do j = 1, nvar proj(j) = proj(j) + s(i)*rho(j,i) end do end do c c apply projector and normalize new vector c sum = 0.0d0 do i = 1, nvar proj(i) = r0(i) - proj(i) sum = sum + proj(i)*proj(i) end do sum = sqrt(sum) do i = 1, nvar proj(i) = proj(i) / sum end do c c return original array updated c do i = 1, nvar r0(i) = proj(i) end do c c perform deallocation of some local arrays c deallocate (s) deallocate (proj) return end c c c ################################################################ c ## ## c ## subroutine qonvec -- block iterative vibration utility ## c ## ## c ################################################################ c c c "qonvec" is a vector utility routine used during sliding c block iterative matrix diagonalization c c subroutine qonvec (nvar,nr,u,rk,r) implicit none integer i,j,nvar,nr real*8 rku(6) real*8 rk(*) real*8 r(*) real*8 u(nvar,*) c c c operate on vector rk with u-transpose c do i = 1, nr rku(i) = 0.0d0 do j = 1, nvar rku(i) = rku(i) + u(j,i)*rk(j) end do end do c c operate with u on the resultant c do i = 1, nvar r(i) = 0.0d0 do j = 1, nr r(i) = r(i) + u(i,j)*rku(j) end do end do c c subtract new product from r c do i = 1, nvar r(i) = rk(i) - r(i) end do return end c c c ################################################################# c ## ## c ## subroutine project -- remove known vectors from current ## c ## ## c ################################################################# c c c "project" reads locked vectors from a binary file and projects c them out of the components of the set of trial eigenvectors c using the relation Y = X - U * U^T * X c c subroutine project (nvar,nconv,ivb1,ns,m) use vibs implicit none integer i,j,k integer nvar,nconv integer ivb1,ns,m real*8, allocatable :: temp(:) real*8, allocatable :: u(:) c c c zero the temporary storage array c do k = 1, nvar do i = 1, ns rwork(k,i+m) = 0.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (temp(ns)) allocate (u(nvar)) c c read and scan over the locked eigenvectors c do i = 1, nconv read (ivb1) (u(k),k=1,nvar) do j = 1, ns temp(j) = 0.0d0 do k = 1, nvar temp(j) = temp(j) + u(k)*rho(k,j+m) end do end do do j = 1, ns do k = 1, nvar rwork(k,j+m) = rwork(k,j+m) + u(k)*temp(j) end do end do end do c c perform deallocation of some local arrays c deallocate (temp) deallocate (u) c c project locked vectors out of the current set c do k = 1, nvar do i = 1, ns rho(k,i+m) = rho(k,i+m) - rwork(k,i+m) end do end do if (nconv .gt. 0) rewind (unit=ivb1) return end c c c ################################################################## c ## ## c ## subroutine projectk -- remove known vectors from current ## c ## ## c ################################################################## c c c "projectk" reads locked vectors from a binary file and projects c them out of the components of the set of trial eigenvectors c using the relation Y = X - U * U^T * X c c subroutine projectk (nvar,nconv,ivb1,ns,m) use vibs implicit none integer i,j,k integer nvar,nconv integer ivb1,ns,m real*8, allocatable :: temp(:) real*8, allocatable :: u(:) c c c zero the temporary storage array c do k = 1, nvar do i = 1, ns rwork(k,i+m) = 0.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (temp(ns)) allocate (u(nvar)) c c read and scan over the locked eigenvectors c do i = 1, nconv read (ivb1) (u(k),k=1,nvar) do j = 1, ns temp(j) = 0.0d0 do k = 1, nvar temp(j) = temp(j) + u(k)*rhok(k,j+m) end do end do do j = 1, ns do k = 1, nvar rwork(k,j+m) = rwork(k,j+m) + u(k)*temp(j) end do end do end do c c perform deallocation of some local arrays c deallocate (temp) deallocate (u) c c project locked vectors out of the current set c do k = 1, nvar do i = 1, ns rhok(k,i+m) = rhok(k,i+m) - rwork(k,i+m) end do end do if (nconv .gt. 0) rewind (unit=ivb1) return end c c c ############################################################## c ## ## c ## subroutine konvec -- evaluate Hessian-vector product ## c ## ## c ############################################################## c c c "konvec" finds a Hessian-vector product via finite-difference c evaluation of the gradient based on atomic displacements c c subroutine konvec (nvar,xm,qe,uvec,kuvec) use atomid use atoms use units implicit none integer i,j,k,nvar real*8 e,term real*8 sum,eps real*8 xm(*) real*8 qe(*) real*8 uvec(*) real*8 kuvec(*) real*8, allocatable :: delta(:) real*8, allocatable :: grd1(:,:) real*8, allocatable :: grd2(:,:) c c c estimate displacement based on total average c sum = 0.0d0 do i = 1, nvar sum = sum + uvec(i)*uvec(i)/xm(i) end do c c perform dynamic allocation of some local arrays c allocate (delta(nvar)) allocate (grd1(3,n)) allocate (grd2(3,n)) c c store the coordinate displacements c eps = 0.001d0 / sqrt(sum) do i = 1, nvar delta(i) = eps * uvec(i) / sqrt(xm(i)) end do c c compute the forward displacement c do i = 1, n k = 3 * (i-1) x(i) = bohr * (qe(k+1)+delta(k+1)) y(i) = bohr * (qe(k+2)+delta(k+2)) z(i) = bohr * (qe(k+3)+delta(k+3)) end do call gradient (e,grd1) c c compute the backward displacement c do i = 1, n k = 3 * (i-1) x(i) = bohr * (qe(k+1)-delta(k+1)) y(i) = bohr * (qe(k+2)-delta(k+2)) z(i) = bohr * (qe(k+3)-delta(k+3)) end do call gradient (e,grd2) c c update via finite differences c term = 0.5d0 * bohr / (eps * hartree) do i = 1, n k = 3 * (i-1) do j = 1, 3 kuvec(k+j) = term * (grd1(j,i)-grd2(j,i)) / sqrt(xm(k+j)) end do end do c c perform deallocation of some local arrays c deallocate (delta) deallocate (grd1) deallocate (grd2) return end c c c ################################################################# c ## ## c ## subroutine transform -- diagonalize trial basis vectors ## c ## ## c ################################################################# c c c "transform" diagonalizes the current basis vectors to produce c trial roots for sliding block iterative matrix diagonalization c c subroutine transform (ns,nb,h,c) implicit none integer i,j,k,ns,nb real*8 h(nb,*) real*8 c(nb,*) real*8, allocatable :: e1(:) real*8, allocatable :: h1(:) real*8, allocatable :: c1(:,:) c c c perform dynamic allocation of some local arrays c allocate (e1(ns)) allocate (h1((ns+1)*ns/2)) allocate (c1(ns,ns)) c c pack the upper triangle of matrix c k = 0 do i = 1, ns do j = i, ns k = k + 1 h1(k) = h(i,j) end do end do c c perform the matrix diagonalization c call diagq (ns,ns,h1,e1,c1) c c copy values into the return arrays c do i = 1, ns do j = 1, ns h(i,j) = 0.0d0 c(i,j) = c1(i,j) end do h(i,i) = e1(i) end do c c perform deallocation of some local arrays c deallocate (e1) deallocate (h1) deallocate (c1) return end c c c ############################################################# c ## ## c ## subroutine diagblk -- diagonalization for atom block ## c ## ## c ############################################################# c c c "diagblk" performs diagonalization of the Hessian for a c block of atoms within a larger system c c subroutine diagblk (k0,k1,n,vector,wres) implicit none integer i,j,k,m integer n,k0,k1 real*8 wres(*) real*8 vector(*) real*8, allocatable :: hval(:) real*8, allocatable :: hres(:) real*8, allocatable :: hvec(:,:) c c c perform dynamic allocation of some local arrays c allocate (hval(n)) allocate (hres((n+1)*n/2)) allocate (hvec(n,n)) c c pack the upper triangle of matrix c k = 0 do i = 1, n m = k0 + (i-1)*n do j = i, n k = k + 1 hres(k) = vector(m+j) end do end do c c perform the matrix diagonalization c call diagq (n,n,hres,hval,hvec) c c copy values into return arrays c k = 0 do i = 1, n do j = 1, n k = k + 1 vector(k0+k) = hvec(j,i) end do end do do i = 1, n wres(k1+i-1) = hval(i) end do c c perform deallocation of some local arrays c deallocate (hval) deallocate (hres) deallocate (hvec) return end c c c ######################################################### c ## ## c ## subroutine prtvib -- output of vibrational mode ## c ## ## c ######################################################### c c c "prtvib" writes to an external disk file a series of c coordinate sets representing motion along a vibrational c normal mode c c subroutine prtvib (ivib,r) use atoms use files implicit none integer i,j,k integer ivib,ixyz integer lext,nview integer freeunit real*8 ratio real*8 r(*) real*8, allocatable :: xorig(:) real*8, allocatable :: yorig(:) real*8, allocatable :: zorig(:) character*7 ext character*240 xyzfile c c c create a name for the vibrational displacement file c lext = 3 call numeral (ivib,ext,lext) xyzfile = filename(1:leng)//'.'//ext(1:lext) ixyz = freeunit () call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') c c perform dynamic allocation of some local arrays c allocate (xorig(n)) allocate (yorig(n)) allocate (zorig(n)) c c store the original atomic coordinates c do i = 1, n xorig(i) = x(i) yorig(i) = y(i) zorig(i) = z(i) end do c c make file with plus and minus the current vibration c nview = 3 do i = -nview, nview ratio = dble(i) / dble(nview) do k = 1, n j = 3 * (k-1) x(k) = xorig(k) + ratio*r(j+1) y(k) = yorig(k) + ratio*r(j+2) z(k) = zorig(k) + ratio*r(j+3) end do call prtxyz (ixyz) end do close (unit=ixyz) c c restore the original atomic coordinates c do i = 1, n x(i) = xorig(i) y(i) = yorig(i) z(i) = zorig(i) end do c c perform deallocation of some local arrays c deallocate (xorig) deallocate (yorig) deallocate (zorig) return end c c c ############################################################### c ## ## c ## subroutine hessblk -- Hessian elements for atom block ## c ## ## c ############################################################### c c c "hessblk" calls subroutines to calculate the Hessian elements c for each atom in turn with respect to Cartesian coordinates c c subroutine hessblk (amass,k0,i1,i2,vector) use atoms use bound use couple use hescut use hessn use inform use iounit use limits use mpole use potent use rigid use usage use vdw use vdwpot use units implicit none integer i,j,k integer ii,k0 integer i1,i2 real*8 ami,amik real*8 cutoff,rdn real*8 amass(*) real*8 vector(*) logical first save first data first / .true. / c c c maintain any periodic boundary conditions c if (use_bounds .and. .not.use_rigid) call bounds 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 compute the induced dipoles at polarizable atoms c if (use_polar) then call chkpole call rotpole ('MPOLE') call induce end if c c calculate the "reduced" atomic coordinates c if (use_vdw) then do i = 1, n ii = ired(i) rdn = kred(i) xred(i) = rdn*(x(i)-x(ii)) + x(ii) yred(i) = rdn*(y(i)-y(ii)) + y(ii) zred(i) = rdn*(z(i)-z(ii)) + z(ii) end do end if c c perform dynamic allocation of some global arrays c if (first) then first = .false. if (.not. allocated(hessx)) allocate (hessx(3,n)) if (.not. allocated(hessy)) allocate (hessy(3,n)) if (.not. allocated(hessz)) allocate (hessz(3,n)) end if c c zero out the Hessian elements for the current atom c ii = 0 do i = i1, i2 if (use(i)) then do k = i1, i2 do j = 1, 3 hessx(j,k) = 0.0d0 hessy(j,k) = 0.0d0 hessz(j,k) = 0.0d0 end do end do c c remove any previous use of the replicates method c cutoff = 0.0d0 call replica (cutoff) c c call the local geometry Hessian component routines c if (use_bond) call ebond2 (i) if (use_angle) call eangle2 (i) if (use_strbnd) call estrbnd2 (i) if (use_urey) call eurey2 (i) if (use_angang) call eangang2 (i) if (use_opbend) call eopbend2 (i) if (use_opdist) call eopdist2 (i) if (use_improp) call eimprop2 (i) if (use_imptor) call eimptor2 (i) if (use_tors) call etors2 (i) if (use_pitors) call epitors2 (i) if (use_strtor) call estrtor2 (i) if (use_angtor) call eangtor2 (i) if (use_tortor) call etortor2 (i) c c call the van der Waals Hessian component routines c if (use_vdw) then if (vdwtyp .eq. 'LENNARD-JONES') call elj2 (i) if (vdwtyp .eq. 'BUCKINGHAM') call ebuck2 (i) if (vdwtyp .eq. 'MM3-HBOND') call emm3hb2 (i) if (vdwtyp .eq. 'BUFFERED-14-7') call ehal2 (i) if (vdwtyp .eq. 'GAUSSIAN') call egauss2 (i) end if c c call the electrostatic Hessian component routines c if (use_charge) call echarge2 (i) if (use_chgdpl) call echgdpl2 (i) if (use_dipole) call edipole2 (i) if (use_mpole) call empole2 (i) if (use_polar) call epolar2 (i) if (use_rxnfld) call erxnfld2 (i) c c call any miscellaneous Hessian component routines c if (use_solv) call esolv2 (i) if (use_metal) call emetal2 (i) if (use_geom) call egeom2 (i) if (use_extra) call extra2 (i) c c store Hessian for the current atom block as a vector c ami = bohr**2 / (hartree*sqrt(amass(i))) do k = i1, i2 amik = ami / sqrt(amass(k)) do j = 1, 3 ii = ii + 1 vector(k0+ii) = hessx(j,k) * amik end do end do do k = i1, i2 amik = ami / sqrt(amass(k)) do j = 1, 3 ii = ii + 1 vector(k0+ii) = hessy(j,k) * amik end do end do do k = i1, i2 amik = ami / sqrt(amass(k)) do j = 1, 3 ii = ii + 1 vector(k0+ii) = hessz(j,k) * amik end do 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 ## program vibrate -- vibrational analysis and normal modes ## c ## ## c ################################################################## c c c "vibrate" performs a vibrational normal mode analysis; the c Hessian matrix of second derivatives is determined and then c diagonalized both directly and after mass weighting; output c consists of the eigenvalues of the force constant matrix as c well as the vibrational frequencies and displacements c c program vibrate use atomid use atoms use files use hescut use iounit use math use units use usage implicit none integer i,j,k,m integer ixyz,ihess integer lext,freeunit integer nfreq,ndummy integer nvib,ivib integer nview,next integer nlist,ilist integer, allocatable :: list(:) integer, allocatable :: iv(:) integer, allocatable :: hindex(:) integer, allocatable :: hinit(:,:) integer, allocatable :: hstop(:,:) real*8 factor,vnorm real*8 sum,scale,ratio real*8, allocatable :: xorig(:) real*8, allocatable :: yorig(:) real*8, allocatable :: zorig(:) real*8, allocatable :: mass2(:) real*8, allocatable :: h(:) real*8, allocatable :: eigen(:) real*8, allocatable :: matrix(:) real*8, allocatable :: hdiag(:,:) real*8, allocatable :: vects(:,:) logical exist,query character*1 letter character*7 ext character*240 xyzfile 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 perform dynamic allocation of some local arrays c nfreq = 3 * nuse allocate (mass2(n)) allocate (hinit(3,n)) allocate (hstop(3,n)) allocate (hdiag(3,n)) allocate (hindex(nfreq*(nfreq-1)/2)) allocate (h(nfreq*(nfreq-1)/2)) allocate (matrix(nfreq*(nfreq+1)/2)) c c initialize various things needed for vibrations c ndummy = 0 do i = 1, n if (use(i) .and. atomic(i).eq.0) then ndummy = ndummy + 1 mass(i) = 0.001d0 end if mass2(i) = sqrt(mass(i)) end do nvib = nfreq - 3*ndummy c c calculate the Hessian matrix of second derivatives c hesscut = 0.0d0 call hessian (h,hinit,hstop,hindex,hdiag) c c store upper triangle of the Hessian in "matrix" c ihess = 0 do i = 1, n if (use(i)) then do j = 1, 3 ihess = ihess + 1 matrix(ihess) = hdiag(j,i) do k = hinit(j,i), hstop(j,i) m = (hindex(k)+2) / 3 if (use(m)) then ihess = ihess + 1 matrix(ihess) = h(k) end if end do end do end if end do c c perform dynamic allocation of some local arrays c allocate (eigen(nfreq)) allocate (vects(nfreq,nfreq)) c c perform diagonalization to get Hessian eigenvalues c call diagq (nfreq,nfreq,matrix,eigen,vects) write (iout,10) 10 format (/,' Eigenvalues of the Hessian Matrix :',/) write (iout,20) (i,eigen(i),i=1,nvib) 20 format (5(i5,f10.3)) c c store upper triangle of the mass-weighted Hessian matrix c ihess = 0 do i = 1, n if (use(i)) then do j = 1, 3 ihess = ihess + 1 matrix(ihess) = hdiag(j,i) / mass(i) do k = hinit(j,i), hstop(j,i) m = (hindex(k)+2) / 3 if (use(m)) then ihess = ihess + 1 matrix(ihess) = h(k) / (mass2(i)*mass2(m)) end if end do end do end if end do c c diagonalize to get vibrational frequencies and normal modes c call diagq (nfreq,nfreq,matrix,eigen,vects) factor = sqrt(ekcal) / (2.0d0*pi*lightspd) do i = 1, nvib eigen(i) = factor * sign(1.0d0,eigen(i)) * sqrt(abs(eigen(i))) end do write (iout,30) 30 format (/,' Vibrational Frequencies (cm-1) :',/) write (iout,40) (i,eigen(i),i=1,nvib) 40 format (5(i5,f10.3)) c c perform deallocation of some local arrays c deallocate (hinit) deallocate (hstop) deallocate (hdiag) deallocate (h) deallocate (matrix) c c form Cartesian coordinate displacements from normal modes c do i = 1, nvib vnorm = 0.0d0 do j = 1, nfreq k = iuse((j+2)/3) vects(j,i) = vects(j,i) / mass2(k) vnorm = vnorm + vects(j,i)**2 end do vnorm = sqrt(vnorm) do j = 1, nfreq vects(j,i) = vects(j,i) / vnorm end do end do c c perform dynamic allocation of some local arrays c allocate (list(nfreq)) allocate (iv(nfreq)) allocate (xorig(n)) allocate (yorig(n)) allocate (zorig(n)) c c try to get output vibrational modes from command line c query = .true. call nextarg (string,exist) if (exist) then query = .false. letter = string(1:1) call upcase (letter) if (letter .eq. 'A') then nlist = nvib do i = 1, nlist list(i) = i end do else nlist = 0 do i = 1, nvib read (string,*,err=50,end=50) k if (k.ge.1 .and. k.le.nvib) then nlist = nlist + 1 list(nlist) = k else k = abs(k) call nextarg (string,exist) read (string,*,err=50,end=50) m m = min(abs(m),nvib) do j = k, m nlist = nlist + 1 list(nlist) = j end do end if call nextarg (string,exist) end do 50 continue end if end if c c ask the user for the vibrational modes to be output c if (query) then write (iout,60) 60 format (/,' Enter Vibrations to Output [List, A=All', & ' or =Exit] : ',$) read (input,70) record 70 format (a240) letter = ' ' next = 1 call gettext (record,letter,next) call upcase (letter) if (letter .eq. ' ') then nlist = 0 else if (letter .eq. 'A') then nlist = nvib do i = 1, nlist list(i) = i end do else do i = 1, nvib iv(i) = 0 end do read (record,*,err=80,end=80) (iv(i),i=1,nvib) 80 continue nlist = 0 i = 1 do while (iv(i) .ne. 0) k = iv(i) if (k.ge.1 .and. k.le.nvib) then nlist = nlist + 1 list(nlist) = k else k = abs(k) m = min(abs(iv(i+1)),nvib) do j = k, m nlist = nlist + 1 list(nlist) = j end do i = i + 1 end if i = i + 1 end do end if end if c c print the vibrational frequencies and normal modes c do ilist = 1, nlist ivib = list(ilist) write (iout,90) ivib,eigen(ivib) 90 format (/,' Vibrational Normal Mode',i6,' with Frequency', & f11.3,' cm-1', & //,5x,'Atom',5x,'Delta X',5x,'Delta Y',5x,'Delta Z',/) do i = 1, nuse j = 3 * (i-1) write (iout,100) iuse(i),vects(j+1,ivib),vects(j+2,ivib), & vects(j+3,ivib) 100 format (4x,i5,3f12.6) end do c c create a name for the vibrational displacement file c lext = 3 call numeral (ivib,ext,lext) xyzfile = filename(1:leng)//'.'//ext(1:lext) ixyz = freeunit () call version (xyzfile,'new') open (unit=ixyz,file=xyzfile,status='new') c c store the original atomic coordinates c do i = 1, n xorig(i) = x(i) yorig(i) = y(i) zorig(i) = z(i) end do c c scale based on the maximum displacement along the mode c scale = 0.0d0 do i = 1, nuse j = 3 * (i-1) sum = 0.0d0 do k = 1, 3 sum = sum + vects(j+k,ivib)**2 end do scale = max(sum,scale) end do scale = 0.1d0 * n**(1.0d0/3.0d0) / sqrt(scale) c c make file with plus and minus the current vibration c nview = 3 do i = -nview, nview ratio = scale * dble(i) / dble(nview) do k = 1, nuse j = 3 * (k-1) m = iuse(k) x(m) = xorig(m) + ratio*vects(j+1,ivib) y(m) = yorig(m) + ratio*vects(j+2,ivib) z(m) = zorig(m) + ratio*vects(j+3,ivib) end do call prtxyz (ixyz) end do close (unit=ixyz) c c restore the original atomic coordinates c do i = 1, n x(i) = xorig(i) y(i) = yorig(i) z(i) = zorig(i) end do end do c c perform deallocation of some local arrays c deallocate (list) deallocate (iv) deallocate (mass2) deallocate (xorig) deallocate (yorig) deallocate (zorig) deallocate (eigen) deallocate (vects) 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 vibrot -- vibrational analysis over torsions ## c ## ## c ############################################################## c c c "vibrot" computes the eigenvalues and eigenvectors of the c torsional Hessian matrix c c literature reference: c c M. Levitt, C. Sander and P. S. Stern, "Protein Normal-mode c Dynamics: Trypsin Inhibitor, Crambin, Ribonuclease and Lysozyme", c Journal of Molecular Biology, 181, 423-447 (1985) c c program vibrot use iounit use omega implicit none integer i,j,ihess real*8, allocatable :: eigen(:) real*8, allocatable :: matrix(:) real*8, allocatable :: vects(:,:) real*8, allocatable :: hrot(:,:) c c c set up the mechanics calculation and rotatable bonds c call initial call getint call mechanic call initrot c c perform dynamic allocation of some local arrays c allocate (eigen(nomega)) allocate (matrix(nomega*(nomega+1)/2)) allocate (vects(nomega,nomega)) allocate (hrot(nomega,nomega)) c c calculate the full torsional Hessian matrix c call hessrot ('FULL',hrot) c c write out the torsional Hessian diagonal c write (iout,10) 10 format (/,' Diagonal of the Torsional Hessian :',/) write (iout,20) (i,hrot(i,i),i=1,nomega) 20 format (4(i8,f11.3)) c c write out the torsional Hessian elements c if (nomega .le. 30) then write (iout,30) 30 format (/,' Torsional Hessian Matrix Elements :') do i = 1, nomega write (iout,40) 40 format () write (iout,50) (hrot(j,i),j=1,nomega) 50 format (6f13.4) end do end if c c place Hessian elements into triangular form c ihess = 0 do i = 1, nomega do j = i, nomega ihess = ihess + 1 matrix(ihess) = hrot(i,j) end do end do c c perform diagonalization to get Hessian eigenvalues c call diagq (nomega,nomega,matrix,eigen,vects) write (iout,60) 60 format (/,' Eigenvalues of the Hessian Matrix :',/) write (iout,70) (i,eigen(i),i=1,nomega) 70 format (4(i8,f11.3)) c c perform deallocation of some local arrays c deallocate (eigen) deallocate (matrix) deallocate (vects) deallocate (hrot) c c perform any final tasks before program exit c call final end c c c ################################################### c ## COPYRIGHT (C) 2010 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################## c ## ## c ## module vibs -- iterative vibrational analysis components ## c ## ## c ################################################################## c c c rho trial vectors for iterative vibrational analysis c rhok alternate vectors for iterative vibrational analysis c rwork temporary work array for eigenvector transformation c c module vibs implicit none real*8, allocatable :: rho(:,:) real*8, allocatable :: rhok(:,:) real*8, allocatable :: rwork(:,:) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module virial -- components of internal virial tensor ## c ## ## c ############################################################### c c c vir total internal virial Cartesian tensor components c use_virial logical flag governing use of virial computation c c module virial implicit none real*8 vir(3,3) logical use_virial save end c c c ################################################################ c ## COPYRIGHT (C) 1990 by Patrice Koehl & Jay William Ponder ## c ## All Rights Reserved ## c ################################################################ c c ########################################################### c ## ## c ## subroutine volume -- alpha shapes excluded volume ## c ## ## c ########################################################### c c c "volume" computes the weighted solvent excluded volume via c the inclusion-exclusion method of Herbert Edelsbrunner based c on alpha shapes; also finds the accessible surface area c c note for small or symmetric structures where alpha shapes c may fail, switch to the Connolly method c c developed to facilitate calling UnionBall from Tinker by c Jay W. Ponder, Washington University, October 2023 c c literature references: c c P. Mach and P. Koehl, "Geometric Measures of Large Biomolecules: c Surface, Volume, and Pockets", Journal of Computational Chemistry, c 32, 3023-3038 (2011) c c P. Koehl, A. Akopyan and H. Edelsbrunner, "Computing the Volume, c Surface Area, Mean, and Gaussian Curvatures of Molecules and Their c Derivatives", Journal of Chemical Information and Modeling, 63, c 973-985 (2023) c c variables and parameters: c c nsphere number of spheres/balls in the system c coords coordinates of the center of each sphere c radii radius value for each sphere c weight weight value for each sphere c probe radius value of the probe sphere c surf weighted surface area of union of spheres c vol weighted excluded volume of union of spheres c usurf unweighted surface area of union of spheres c uvol unweighted excluded volume of union of spheres c asurf weighted area contribution of each sphere c avol weighted volume contribution of each sphere c c subroutine volume (rad,weight,probe,surf,vol,asurf,avol) use atoms implicit none integer i,nsphere integer nsize,nfudge integer nredundant integer, allocatable :: redlist(:) real*8 surf,usurf,eps real*8 vol,uvol,voln real*8 reentrant real*8 probe,alpha real*8 rad(*) real*8 weight(*) real*8 asurf(*) real*8 avol(*) real*8, allocatable :: radii(:) real*8, allocatable :: asurfx(:) real*8, allocatable :: avolx(:) real*8, allocatable :: coords(:,:) logical dowiggle character*6 symmtyp c c c check coordinates for linearity, planarity and symmetry c symmtyp = 'NONE' call chksymm (symmtyp) dowiggle = .false. if (n.gt.2 .and. symmtyp.eq.'LINEAR') dowiggle = .true. if (n.gt.3 .and. symmtyp.eq.'PLANAR') dowiggle = .true. c c use Connolly method for small symmetric structures c if (dowiggle) then reentrant = 0.0d0 call connolly (n,x,y,z,rad,probe,reentrant,surf,vol) vol = vol * weight(1) voln = vol / dble(n) do i = 1, n avol(i) = voln end do return end if c c perform dynamic allocation of some local arrays c nfudge = 10 nsize = n + nfudge allocate (radii(nsize)) allocate (asurfx(nsize)) allocate (avolx(nsize)) allocate (coords(3,nsize)) allocate (redlist(nsize)) c c set the coordinates and sphere radii plus probe` c nsphere = n do i = 1, n coords(1,i) = x(i) coords(2,i) = y(i) coords(3,i) = z(i) radii(i) = 0.0d0 if (rad(i) .ne. 0.0d0) radii(i) = rad(i) + probe end do c c random coordinate perturbation to avoid numerical issues c if (dowiggle) then eps = 0.001d0 call wiggle (n,coords,eps) end if c c transfer coordinates, complete to minimum of four spheres c if needed, set Delaunay and alpha complex arrays c call setunion (nsphere,coords,radii) c c compute the weighted Delaunay triangulation c call regular3 (nredundant,redlist) c c compute the alpha complex for fixed value of alpha c alpha = 0.0d0 call alfcx (alpha,nredundant,redlist) c c if fewer than four balls, set artificial spheres as redundant c call readjust_sphere (nsphere,nredundant,redlist) c c get the accessible surface area and excluded volume c call ball_vol (weight,surf,vol,usurf,uvol,asurfx,avolx) c c copy area and volume of each sphere into Tinker array c do i = 1, n asurf(i) = asurfx(i) avol(i) = avolx(i) end do c c perform deallocation of some local arrays c deallocate (radii) deallocate (asurfx) deallocate (avolx) deallocate (coords) deallocate (redlist) return end c c c ############################################################ c ## ## c ## subroutine volume1 -- alpha shapes volume & derivs ## c ## ## c ############################################################ c c c "volume1" computes the weighted solvent excluded volume c and the first derivatives of the volume with respect to c Cartesian coordinates via the inclusion-exclusion method c of Herbert Edelsbrunner based on alpha shapes; also finds c the accessible surface area and first derivatives c c note for small or symmetric structures where alpha shapes c may fail, swith to Richmond, Connolly and Kundrot methods c c developed to facilitate calling UnionBall from Tinker by c Jay W. Ponder, Washington University, October 2023 c c literature references: c c P. Mach and P. Koehl, "Geometric Measures of Large Biomolecules: c Surface, Volume, and Pockets", Journal of Computational Chemistry, c 32, 3023-3038 (2011) c c P. Koehl, A. Akopyan and H. Edelsbrunner, "Computing the Volume, c Surface Area, Mean, and Gaussian Curvatures of Molecules and Their c Derivatives", Journal of Chemical Information and Modeling, 63, c 973-985 (2023) c c variables and parameters: c c nsphere number of spheres/balls in the system c coords coordinates of the center of each sphere c radii radius value for each sphere c weight weight value for each sphere c probe radius value of the probe sphere c surf weighted surface area of union of spheres c vol weighted excluded volume of union of spheres c usurf unweighted surface area of union of spheres c uvol unweighted excluded volume of union of spheres c asurf weighted area contribution of each sphere c avol weighted volume contribution of each sphere c dsurf derivatives of the weighted surface area over c sphere coordinates c dvol derivatives of the weighted volume over c sphere coordinates c c subroutine volume1 (rad,weight,probe,surf,vol,asurf,avol, & dsurf,dvol) use atoms implicit none integer i,nsphere integer nsize,nfudge integer nredundant integer, allocatable :: redlist(:) real*8 surf,usurf,eps real*8 vol,uvol,voln real*8 reentrant real*8 probe,alpha real*8 rad(*) real*8 weight(*) real*8 asurf(*) real*8 avol(*) real*8 dsurf(3,*) real*8 dvol(3,*) real*8, allocatable :: radii(:) real*8, allocatable :: asurfx(:) real*8, allocatable :: avolx(:) real*8, allocatable :: coords(:,:) real*8, allocatable :: dsurfx(:,:) real*8, allocatable :: dvolx(:,:) logical dowiggle character*6 symmtyp c c c check coordinates for linearity, planarity and symmetry c symmtyp = 'NONE' call chksymm (symmtyp) dowiggle = .false. if (n.gt.2 .and. symmtyp.eq.'LINEAR') dowiggle = .true. if (n.gt.3 .and. symmtyp.eq.'PLANAR') dowiggle = .true. c c use arc-based methods for small symmetric structures c if (dowiggle) then reentrant = 0.0d0 call connolly (n,x,y,z,rad,probe,reentrant,surf,vol) call kundrot1 (n,x,y,z,rad,probe,dvol) call richmond1 (n,x,y,z,rad,weight,probe,surf,asurf,dsurf) vol = vol * weight(1) voln = vol / dble(n) do i = 1, n dvol(1,i) = dvol(1,i) * weight(i) dvol(2,i) = dvol(2,i) * weight(i) dvol(3,i) = dvol(3,i) * weight(i) avol(i) = voln end do return end if c c perform dynamic allocation of some local arrays c nfudge = 10 nsize = n + nfudge allocate (radii(nsize)) allocate (asurfx(nsize)) allocate (avolx(nsize)) allocate (coords(3,nsize)) allocate (dsurfx(3,nsize)) allocate (dvolx(3,nsize)) allocate (redlist(nsize)) c c set the coordinates and sphere radii plus probe` c nsphere = n do i = 1, n coords(1,i) = x(i) coords(2,i) = y(i) coords(3,i) = z(i) radii(i) = 0.0d0 if (rad(i) .ne. 0.0d0) radii(i) = rad(i) + probe end do c c random coordinate perturbation to avoid numerical issues c if (dowiggle) then eps = 0.001d0 call wiggle (n,coords,eps) end if c c transfer coordinates, complete to minimum of four spheres c if needed, set Delaunay and alpha complex arrays c call setunion (nsphere,coords,radii) c c compute the weighted Delaunay triangulation c call regular3 (nredundant,redlist) c c compute the alpha complex for fixed value of alpha c alpha = 0.0d0 call alfcx (alpha,nredundant,redlist) c c if fewer than four balls, set artificial spheres as redundant c call readjust_sphere (nsphere,nredundant,redlist) c c get the accessible surface area and excluded volume c call ball_dvol (weight,surf,vol,usurf,uvol,asurfx,avolx, & dsurfx,dvolx) c c copy area and volume of each sphere into Tinker array c do i = 1, n asurf(i) = asurfx(i) avol(i) = avolx(i) dsurf(1,i) = dsurfx(1,i) dsurf(2,i) = dsurfx(2,i) dsurf(3,i) = dsurfx(3,i) dvol(1,i) = dvolx(1,i) dvol(2,i) = dvolx(2,i) dvol(3,i) = dvolx(3,i) end do c c perform deallocation of some local arrays c deallocate (radii) deallocate (asurfx) deallocate (avolx) deallocate (coords) deallocate (dsurfx) deallocate (dvolx) deallocate (redlist) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module warp -- potential surface smoothing parameters ## c ## ## c ############################################################### c c c deform value of the smoothing deformation parameter c difft diffusion coefficient for torsional potential c diffv diffusion coefficient for van der Waals potential c diffc diffusion coefficient for charge-charge potential c m2 second moment of the GDA gaussian for each atom c use_smooth flag to use a potential energy smoothing method c use_dem flag to use diffusion equation method potential c use_gda flag to use gaussian density annealing potential c use_tophat flag to use analytical tophat smoothed potential c use_stophat flag to use shifted tophat smoothed potential c c module warp implicit none real*8 deform real*8 difft real*8 diffv real*8 diffc real*8, allocatable :: m2(:) logical use_smooth logical use_dem logical use_gda logical use_tophat logical use_stophat save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## program xtalfit -- fit parameters to structure & energy ## c ## ## c ################################################################# c c c "xtalfit" determines optimized van der Waals and electrostatic c parameters by fitting to crystal structures, lattice energies, c and dimer structures and interaction energies c c program xtalfit use bound use boxes use files use iounit use molcul use potent use sizes use vdwpot use xtals implicit none integer i,ixtal integer atom1,atom2 integer nresid,prmtyp real*8 grdmin real*8, allocatable :: xx(:) real*8, allocatable :: resid(:) real*8, allocatable :: g(:) real*8, allocatable :: xlo(:) real*8, allocatable :: xhi(:) real*8, allocatable :: fjac(:,:) logical exist,query character*5 vindex character*16 label(7) character*240 record character*240 string external xtalerr,xtalwrt c c c initialize some variables to be used during fitting c call initial nvary = 0 nresid = 0 c c print informational header about available parameters c write (iout,10) 10 format (/,' The Following Parameters can be Fit for', & ' each Atom Type :', & //,4x,'(1) Van der Waals Atomic Radius', & /,4x,'(2) Van der Waals Well Depth', & /,4x,'(3) Hydrogen Atom Reduction Factor', & /,4x,'(4) Atomic Partial Charge', & /,4x,'(5) Bond Dipole Moment Magnitude', & /,4x,'(6) Bond Dipole Moment Position', & /,4x,'(7) Atomic Polarizability') c c get types of potential parameters to be optimized c query = .true. do while (query) prmtyp = -1 atom1 = 0 atom2 = 0 call nextarg (string,exist) if (exist) read (string,*,err=20,end=20) prmtyp call nextarg (string,exist) if (exist) read (string,*,err=20,end=20) atom1 call nextarg (string,exist) if (exist) read (string,*,err=20,end=20) atom2 20 continue if (prmtyp .ne. 0) then prmtyp = 0 write (iout,30) 30 format (/,' Enter Parameter Type then Atom Class', & ' or Type(s) : ',$) read (input,40) record 40 format (a240) read (record,*,err=50,end=50) prmtyp,atom1,atom2 50 continue end if if (prmtyp .eq. 0) then query = .false. else query = .true. nvary = nvary + 1 ivary(nvary) = prmtyp vary(1,nvary) = atom1 if (prmtyp.eq.5 .or. prmtyp.eq.6) then vary(1,nvary) = min(atom1,atom2) vary(2,nvary) = max(atom1,atom2) end if end if end do c c get termination criterion as RMS gradient over parameters c grdmin = -1.0d0 call nextarg (string,exist) if (exist) read (string,*,err=60,end=60) grdmin 60 continue if (grdmin .le. 0.0d0) then write (iout,70) 70 format (/,' Enter RMS Gradient Termination Criterion', & ' [0.1] : ',$) read (input,80) grdmin 80 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.1d0 c c get the number of structures to use in optimization c nxtal = 0 call nextarg (string,exist) if (exist) read (string,*,err=90,end=90) nxtal 90 continue if (nxtal .le. 0) then write (iout,100) 100 format (/,' Enter Number of Structures to be Used [1] : ',$) read (input,110) nxtal 110 format (i10) end if c c check for too few or too many molecular structures c if (nxtal .eq. 0) nxtal = 1 if (nxtal .gt. maxref) then write (iout,120) 120 format (/,' XTALFIT -- Too many Structures,', & ' Increase the Value of MAXREF') call fatal end if c c perform dynamic allocation of some local arrays c allocate (xx(nvary)) c c get coordinates and parameters for current structure c do ixtal = 1, nxtal call initial call getxyz call mechanic c c get ideal value for lattice or intermolecular energy c e0_lattice = 0.0d0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=130,end=130) e0_lattice query = .false. end if 130 continue if (query) then write (iout,140) 140 format (/,' Target for E-Lattice or E-Inter Value', & ' [=None] : ',$) read (input,150) e0_lattice 150 format (f20.0) end if if (e0_lattice .gt. 0.0d0) e0_lattice = -e0_lattice c c set the types of residuals for use in optimization c do i = 1, 6 iresid(nresid+i) = ixtal end do if (use_bounds) then rsdxtl(nresid+1) = 'Force a-Axis' rsdxtl(nresid+2) = 'Force b-Axis' rsdxtl(nresid+3) = 'Force c-Axis' rsdxtl(nresid+4) = 'Force Alpha' rsdxtl(nresid+5) = 'Force Beta' rsdxtl(nresid+6) = 'Force Gamma' else rsdxtl(nresid+1) = 'Force Mol1 X' rsdxtl(nresid+2) = 'Force Mol1 Y' rsdxtl(nresid+3) = 'Force Mol1 Z' rsdxtl(nresid+4) = 'Force Mol2 X' rsdxtl(nresid+5) = 'Force Mol2 Y' rsdxtl(nresid+6) = 'Force Mol2 Z' end if nresid = nresid + 6 c c print molecules per structure, energy and dipole values c write (iout,160) ixtal,filename(1:35),nmol 160 format (/,' File Name of Target Structure',i4,' :',8x,a35, & /,' Number of Molecules per Structure :',i13) if (e0_lattice .ne. 0.0d0) then nresid = nresid + 1 iresid(nresid) = ixtal if (use_bounds) then rsdxtl(nresid) = 'Lattice Energy' else rsdxtl(nresid) = 'E Intermolecular' end if write (iout,170) e0_lattice 170 format (' Target E-Lattice or E-Inter Value : ',f13.2) end if c c set the initial values of the parameters c call xtalprm ('STORE',ixtal,xx) end do c c turn off all local interactions and extra terms c call potoff use_vdw = .true. use_charge = .true. use_chgdpl = .true. use_dipole = .true. use_mpole = .true. use_polar = .true. c c types of variables for use in optimization c label(1) = 'Atomic Radius' label(2) = 'Well Depth' label(3) = 'H Reduction' label(4) = 'Partial Charge' label(5) = 'Dipole Magnitude' label(6) = 'Dipole Position' label(7) = 'Polarizability' do i = 1, nvary varxtl(i) = label(ivary(i)) end do vindex = 'Class' if (vdwindex .eq. 'TYPE ') vindex = 'Type ' c c print the initial parameter values c write (iout,180) 180 format (/,' Initial Values of the Parameters :',/) do i = 1, nvary if (ivary(i) .le. 3) then write (iout,190) i,varxtl(i),vindex,vary(1,i),xx(i) 190 format (3x,'(',i2,')',2x,a16,4x,'Atom ',a5,i5,4x,f12.4) else if (ivary(i) .ne. 6) then write (iout,200) i,varxtl(i),vary(1,i),xx(i) 200 format (3x,'(',i2,')',2x,a16,4x,'Atom Type ',i5,4x,f12.4) else write (iout,210) i,varxtl(i),vary(1,i),vary(2,i),xx(i) 210 format (3x,'(',i2,')',2x,a16,4x,'Bond Type ',2i5,f12.4) end if end do c c perform dynamic allocation of some local arrays c allocate (resid(nresid)) allocate (g(nvary)) allocate (xlo(nvary)) allocate (xhi(nvary)) allocate (fjac(nresid,nvary)) c c set upper and lower bounds based on the parameter type c do i = 1, nvary if (ivary(i).eq.4 .or. ivary(i).eq.5) then xlo(i) = xx(i) - 0.5d0 xhi(i) = xx(i) + 0.5d0 else xlo(i) = 0.5d0 * xx(i) xhi(i) = 1.5d0 * xx(i) end if end do c c use nonlinear least squares to refine the parameters c call square (nvary,nresid,xlo,xhi,xx,resid,g,fjac, & grdmin,xtalerr,xtalwrt) c c perform deallocation of some local arrays c deallocate (xlo) deallocate (xhi) deallocate (fjac) c c print final values of parameters and scaled derivatives c write (iout,220) 220 format (/,' Final Values of Parameters and Scaled', & ' Derivatives :',/) do i = 1, nvary if (ivary(i) .le. 3) then write (iout,230) i,varxtl(i),vindex,vary(1,i),xx(i),g(i) 230 format (3x,'(',i2,')',2x,a16,4x,'Atom ',a5,i5,2x,2f14.4) else if (ivary(i) .ne. 6) then write (iout,240) i,varxtl(i),vary(1,i),xx(i),g(i) 240 format (3x,'(',i2,')',2x,a16,4x,'Atom Type ',i5,2x,2f14.4) else write (iout,250) i,varxtl(i),vary(1,i),vary(2,i),xx(i),g(i) 250 format (3x,'(',i2,')',2x,a16,4x,'Bond Type ',2i5, & f11.4,f14.4) end if end do c c print final values of the individual residual functions c write (iout,260) 260 format (/,' Final Residual Error Function Values :',/) do i = 1, nresid if (i .lt. 100) then write (iout,270) i,rsdxtl(i),iresid(i),resid(i) 270 format (3x,'(',i2,')',2x,a16,6x,'Structure',i4,4x,f12.4) else write (iout,280) i,rsdxtl(i),iresid(i),resid(i) 280 format (2x,'(',i3,')',2x,a16,6x,'Structure',i4,4x,f12.4) end if end do c c perform deallocation of some local arrays c deallocate (xx) deallocate (resid) deallocate (g) c c perform any final tasks before program exit c call final end c c c ############################################################## c ## ## c ## subroutine xtalprm -- energy/optimization conversion ## c ## ## c ############################################################## c c c "xtalprm" stores or retrieves a molecular structure; used to c make a previously stored structure the active structure, or to c store a structure for later use c c the current version only provides for intermolecular potential c energy terms c c subroutine xtalprm (mode,ixtal,xx) use atoms use atomid use bound use boxes use charge use dipole use files use fracs use inform use kvdws use molcul use mpole use polar use vdw use vdwpot use xtals implicit none integer i,j,k integer init,stop integer ixtal,prmtyp integer it,kt,itm,ktm integer nlist integer, allocatable :: list(:) real*8 rd,ep real*8 sixth,weigh real*8 xmid,ymid,zmid real*8 e0_lattices(maxref) real*8 xx(*) logical first character*5 mode save e0_lattices save first data first / .true. / c c c save or restore the key values for the current crystal c if (mode .eq. 'STORE') then call makeref (ixtal) else if (mode .eq. 'RESET') then call getref (ixtal) call basefile (filename) silent = .true. call mechanic silent = .false. if (use_bounds) call bounds end if c c perform dynamic allocation of some global arrays c if (mode .eq. 'RESET') then if (first) then first = .false. allocate (xfrac(nmol)) allocate (yfrac(nmol)) allocate (zfrac(nmol)) end if end if c c get fractional coordinates of center of mass c if (mode .eq. 'RESET') then 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 zfrac(i) = zmid / gamma_term yfrac(i) = (ymid - zmid*beta_term) / gamma_sin xfrac(i) = xmid - ymid*gamma_cos - zmid*beta_cos zfrac(i) = zfrac(i) / zbox yfrac(i) = yfrac(i) / ybox xfrac(i) = xfrac(i) / xbox end do end if c c values of ideal intermolecular or lattice energy c if (mode .eq. 'STORE') then e0_lattices(ixtal) = e0_lattice else if (mode .eq. 'RESET') then e0_lattice = e0_lattices(ixtal) end if c c perform dynamic allocation of some local arrays c allocate (list(n)) c c set type or class index into condensed pair matrices c nlist = n do i = 1, n list(i) = 0 if (vdwindex .eq. 'TYPE') then list(i) = type(i) else list(i) = class(i) end if end do call sort8 (nlist,list) c c store or reset values of the optimization variables c do j = 1, nvary prmtyp = ivary(j) it = vary(1,j) if (prmtyp .eq. 1) then if (mode .eq. 'STORE') then xx(j) = rad(it) else if (mode .eq. 'RESET') then itm = mvdw(it) rad(it) = xx(j) do k = 1, nlist kt = list(k) ktm = mvdw(kt) if (rad(it).eq.0.0d0 .and. rad(kt).eq.0.0d0) then rd = 0.0d0 else if (radrule(1:10) .eq. 'ARITHMETIC') then rd = rad(it) + rad(kt) else if (radrule(1:9) .eq. 'GEOMETRIC') then rd = 2.0d0 * sqrt(rad(it) * rad(kt)) else if (radrule(1:10) .eq. 'CUBIC-MEAN') then rd = 2.0d0 * (rad(it)**3+rad(kt)**3) & / (rad(it)**2+rad(kt)**2) else rd = rad(it) + rad(kt) end if radmin(itm,ktm) = rd radmin(ktm,itm) = rd end do end if else if (prmtyp .eq. 2) then if (mode .eq. 'STORE') then xx(j) = eps(it) else if (mode .eq. 'RESET') then itm = mvdw(it) eps(it) = abs(xx(j)) do k = 1, nlist kt = list(k) ktm = mvdw(kt) if (eps(it).eq.0.0d0 .and. eps(kt).eq.0.0d0) then ep = 0.0d0 else if (epsrule(1:10) .eq. 'ARITHMETIC') then ep = 0.5d0 * (eps(it) + eps(kt)) else if (epsrule(1:9) .eq. 'GEOMETRIC') then ep = sqrt(eps(it) * eps(kt)) else if (epsrule(1:8) .eq. 'HARMONIC') then ep = 2.0d0 * (eps(it)*eps(kt)) / (eps(it)+eps(kt)) else if (epsrule(1:3) .eq. 'HHG') then ep = 4.0d0 * (eps(it)*eps(kt)) & / (sqrt(eps(it))+sqrt(eps(kt)))**2 else ep = sqrt(eps(it) * eps(kt)) end if epsilon(itm,ktm) = ep epsilon(ktm,itm) = ep end do end if else if (prmtyp .eq. 3) then if (mode .eq. 'STORE') then do i = 1, n if (class(i) .eq. it) then xx(j) = kred(i) goto 10 end if end do else if (mode .eq. 'RESET') then do i = 1, n if (class(i) .eq. it) kred(i) = xx(j) end do end if else if (prmtyp .eq. 4) then if (mode .eq. 'STORE') then do i = 1, nion if (type(iion(i)) .eq. it) then xx(j) = pchg(i) goto 10 end if end do else if (mode .eq. 'RESET') then do i = 1, nion if (type(iion(i)) .eq. it) pchg(i) = xx(j) end do end if else if (prmtyp .eq. 5) then kt = vary(2,j) if (mode .eq. 'STORE') then do i = 1, ndipole if (type(idpl(1,i)).eq.it .and. & type(idpl(2,i)).eq.kt) then xx(j) = bdpl(i) goto 10 end if end do else if (mode .eq. 'RESET') then do i = 1, ndipole if (type(idpl(1,i)).eq.it .and. & type(idpl(2,i)).eq.kt) bdpl(i) = xx(j) end do end if else if (prmtyp .eq. 6) then kt = vary(2,j) if (mode .eq. 'STORE') then do i = 1, ndipole if (type(idpl(1,i)).eq.it .and. & type(idpl(2,i)).eq.kt) then xx(j) = sdpl(i) goto 10 end if end do else if (mode .eq. 'RESET') then do i = 1, ndipole if (type(idpl(1,i)).eq.it .and. & type(idpl(2,i)).eq.kt) sdpl(i) = xx(j) end do end if else if (prmtyp .eq. 7) then if (mode .eq. 'STORE') then do i = 1, npole k = ipole(i) if (type(k) .eq. it) then xx(j) = polarity(k) goto 10 end if end do else if (mode .eq. 'RESET') then sixth = 1.0d0 / 6.0d0 do i = 1, npole k = ipole(i) if (type(k) .eq. it) then polarity(k) = xx(j) if (thole(k) .ne. 0.0d0) pdamp(k) = xx(j)**sixth end if end do end if end if 10 continue end do c c perform deallocation of some local arrays c deallocate (list) return end c c c ########################################################## c ## ## c ## subroutine xtalerr -- error function for xtalfit ## c ## ## c ########################################################## c c c "xtalerr" computes an error function value derived from c lattice energies, dimer intermolecular energies and the c gradient with respect to structural parameters c c subroutine xtalerr (nvaried,nresid,xx,resid) use atoms use boxes use bound use charge use dipole use energi use limits use math use molcul use mpole use polar use vdw use xtals implicit none integer i,k,ixtal integer nresid,nvaried real*8 energy,eps,temp real*8 e,e0 real*8 e_monomer real*8 e_lattice real*8 dmol,big real*8 e1,e2,e3 real*8 e4,e5,e6 real*8 g1,g2,g3 real*8 g4,g5,g6 real*8 xx(*) real*8 resid(*) c c c zero out number of residuals and set numerical step size c nresid = 0 eps = 1.0d-4 c c set force field parameter values and find the base energy c do ixtal = 1, nxtal call xtalprm ('RESET',ixtal,xx) e = energy () e0 = ev + ec + ecd + ed + em + ep c c perturb crystal lattice parameters and compute energies c if (use_bounds) then temp = xbox xbox = xbox + eps call xtalmove e = energy () e1 = ev + ec + ecd + ed + em + ep xbox = temp temp = ybox ybox = ybox + eps call xtalmove e = energy () e2 = ev + ec + ecd + ed + em + ep ybox = temp temp = zbox zbox = zbox + eps call xtalmove e = energy () e3 = ev + ec + ecd + ed + em + ep zbox = temp temp = alpha alpha = alpha + radian*eps call xtalmove e = energy () e4 = ev + ec + ecd + ed + em + ep alpha = temp temp = beta beta = beta + radian*eps call xtalmove e = energy () e5 = ev + ec + ecd + ed + em + ep beta = temp temp = gamma gamma = gamma + radian*eps call xtalmove e = energy () e6 = ev + ec + ecd + ed + em + ep gamma = temp call xtalmove c c translate dimer component molecules and compute energies c else do i = imol(1,1), imol(2,1) k = kmol(i) x(k) = x(k) + eps end do e = energy () e1 = ev + ec + ecd + ed + em + ep do i = imol(1,1), imol(2,1) k = kmol(i) x(k) = x(k) - eps end do do i = imol(1,1), imol(2,1) k = kmol(i) y(k) = y(k) + eps end do e = energy () e2 = ev + ec + ecd + ed + em + ep do i = imol(1,1), imol(2,1) k = kmol(i) y(k) = y(k) - eps end do do i = imol(1,1), imol(2,1) k = kmol(i) z(k) = z(k) + eps end do e = energy () e3 = ev + ec + ecd + ed + em + ep do i = imol(1,1), imol(2,1) k = kmol(i) z(k) = z(k) - eps end do do i = imol(1,1), imol(2,1) k = kmol(i) x(k) = x(k) + eps end do e = energy () e4 = ev + ec + ecd + ed + em + ep do i = imol(1,2), imol(2,2) k = kmol(i) x(k) = x(k) - eps end do do i = imol(1,2), imol(2,2) k = kmol(i) y(k) = y(k) + eps end do e = energy () e5 = ev + ec + ecd + ed + em + ep do i = imol(1,2), imol(2,2) k = kmol(i) y(k) = y(k) - eps end do do i = imol(1,2), imol(2,2) k = kmol(i) z(k) = z(k) + eps end do e = energy () e6 = ev + ec + ecd + ed + em + ep do i = imol(1,2), imol(2,2) k = kmol(i) z(k) = z(k) - eps end do end if c c get the gradient with respect to structure perturbations c g1 = (e1 - e0) / eps nresid = nresid + 1 resid(nresid) = g1 g2 = (e2 - e0) / eps nresid = nresid + 1 resid(nresid) = g2 g3 = (e3 - e0) / eps nresid = nresid + 1 resid(nresid) = g3 g4 = (e4 - e0) / eps nresid = nresid + 1 resid(nresid) = g4 g5 = (e5 - e0) / eps nresid = nresid + 1 resid(nresid) = g5 g6 = (e6 - e0) / eps nresid = nresid + 1 resid(nresid) = g6 c c setup to compute properties of monomer from crystal c if (use_bounds) then n = n / nmol nvdw = nvdw / nmol nion = nion / nmol ndipole = ndipole / nmol npole = npole / nmol npolar = npolar / nmol use_bounds = .false. use_replica = .false. use_ewald = .false. big = 1.0d12 vdwcut = big vdwtaper = big chgcut = big chgtaper = big dplcut = big dpltaper = big mpolecut = big mpoletaper = big c c compute the intermolecular or crystal lattice energy c e = energy () e_monomer = ev + ec + ecd + ed + em + ep dmol = dble(nmol) e_lattice = (e0 - dmol*e_monomer) / dmol else e_monomer = 0.0d0 e_lattice = e0 end if c c compute residual due to intermolecular or lattice energy; c weight energies more heavily, since there are fewer of them c if (e0_lattice .ne. 0.0d0) then nresid = nresid + 1 resid(nresid) = e_lattice - e0_lattice if (ixtal .le. 11) then resid(nresid) = 3.0d0 * resid(nresid) else resid(nresid) = 10.0d0 * resid(nresid) end if end if end do return end c c c ############################################################### c ## ## c ## subroutine xtalmove -- translation of rigid molecules ## c ## ## c ############################################################### c c c "xtalmove" converts fractional to Cartesian coordinates for c rigid molecules during optimization of force field parameters c c subroutine xtalmove use atoms use atomid use boxes use fracs use molcul implicit none integer i,j,k integer init,stop real*8 weigh real*8 xmid,ymid,zmid real*8, allocatable :: xoff(:) real*8, allocatable :: yoff(:) real*8, allocatable :: zoff(:) c c c get values for fractional coordinate interconversion c call lattice c c perform dynamic allocation of some local arrays c allocate (xoff(n)) allocate (yoff(n)) allocate (zoff(n)) 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 save atomic coordinates relative to center of mass c do j = init, stop k = kmol(j) xoff(k) = x(k) - xmid yoff(k) = y(k) - ymid zoff(k) = z(k) - zmid end do c c convert fractional center of mass to Cartesian coordinates c xmid = xfrac(i)*xbox + yfrac(i)*ybox*gamma_cos & + zfrac(i)*zbox*beta_cos ymid = yfrac(i)*ybox*gamma_sin + zfrac(i)*zbox*beta_term zmid = zfrac(i)*zbox*gamma_term c c translate coordinates via offset from center of mass c do j = init, stop k = kmol(j) x(k) = xoff(k) + xmid y(k) = yoff(k) + ymid z(k) = zoff(k) + zmid end do end do c c perform deallocation of some local arrays c deallocate (xoff) deallocate (yoff) deallocate (zoff) return end c c c ############################################################## c ## ## c ## subroutine xtalwrt -- output optimization parameters ## c ## ## c ############################################################## c c c "xtalwrt" prints intermediate results during fitting of c force field parameters to structures and energies c c subroutine xtalwrt (niter,nresid,xx,gs,resid) use iounit use vdwpot use xtals implicit none integer i,niter integer nresid real*8 xx(*) real*8 gs(*) real*8 resid(*) character*5 vindex c c c print the values of parameters and scaled derivatives c vindex = 'Class' if (vdwindex .eq. 'TYPE ') vindex = 'Type ' write (iout,10) niter 10 format (/,' Parameters and Scaled Derivatives at', & ' Iteration',i4,' :',/) do i = 1, nvary if (ivary(i) .le. 3) then write (iout,20) i,varxtl(i),vindex,vary(1,i),xx(i),gs(i) 20 format (3x,'(',i2,')',2x,a16,4x,'Atom ',a5,i5,2x,2f14.4) else if (ivary(i) .ne. 6) then write (iout,30) i,varxtl(i),vary(1,i),xx(i),gs(i) 30 format (3x,'(',i2,')',2x,a16,4x,'Atom Type ',i5,2x,2f14.4) else write (iout,40) i,varxtl(i),vary(1,i),vary(2,i),xx(i),gs(i) 40 format (3x,'(',i2,')',2x,a16,4x,'Bond Type ',2i5, & f11.4,f14.4) end if end do c c print the values of the individual residual functions c write (iout,50) niter 50 format (/,' Residual Error Function Values at Iteration', & i4,' :',/) do i = 1, nresid if (i .lt. 100) then write (iout,60) i,rsdxtl(i),iresid(i),resid(i) 60 format (3x,'(',i2,')',2x,a16,6x,'Structure',i4,4x,f12.4) else write (iout,70) i,rsdxtl(i),iresid(i),resid(i) 70 format (2x,'(',i3,')',2x,a16,6x,'Structure',i4,4x,f12.4) end if end do write (iout,80) 80 format () return end c c c ############################################################# c ## COPYRIGHT (C) 2004 by Pengyu Ren & Jay William Ponder ## c ## All Rights Reserved ## c ############################################################# c c ############################################################## c ## ## c ## program xtalmin -- full lattice crystal minimization ## c ## ## c ############################################################## c c c "xtalmin" performs a full crystal energy minimization by c optimizing over fractional atomic coordinates and the six c lattice lengths and angles c c program xtalmin use atoms use boxes use files use inform use iounit use keys use scales implicit none integer i,j,imin,nvar integer next,freeunit real*8 minimum,grdmin real*8 gnorm,grms real*8 glnorm,glrms real*8 xtalmin1,e real*8, allocatable :: xx(:) real*8, allocatable :: glat(:) real*8, allocatable :: xf(:) real*8, allocatable :: yf(:) real*8, allocatable :: zf(:) real*8, allocatable :: derivs(:,:) logical exist character*20 keyword character*240 minfile character*240 record character*240 string external xtalmin1 external optsave 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:240) 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 RMS Gradient per Atom Criterion', & ' [0.01] : ',$) read (input,40) grdmin 40 format (f20.0) end if if (grdmin .le. 0.0d0) grdmin = 0.01d0 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 write out the initial values of the lattice parameters c write (iout,50) xbox,ybox,zbox,alpha,beta,gamma 50 format (/,' Initial Lattice Dimensions : a ',f12.4, & /,' b ',f12.4, & /,' c ',f12.4, & /,' Alpha',f12.4, & /,' Beta ',f12.4, & /,' Gamma',f12.4) c c perform dynamic allocation of some global arrays c if (.not. allocated(scale)) allocate (scale(3*n+6)) c c set scale factors to apply to optimization variables c set_scale = .true. nvar = 0 do i = 1, n nvar = nvar + 1 scale(nvar) = 12.0d0 * xbox nvar = nvar + 1 scale(nvar) = 12.0d0 * ybox nvar = nvar + 1 scale(nvar) = 12.0d0 * zbox end do scale(nvar+1) = 4.0d0 * sqrt(xbox) scale(nvar+2) = 4.0d0 * sqrt(ybox) scale(nvar+3) = 4.0d0 * sqrt(zbox) scale(nvar+4) = 0.02d0 * sqrt(volbox) scale(nvar+5) = 0.02d0 * sqrt(volbox) scale(nvar+6) = 0.02d0 * sqrt(volbox) nvar = nvar + 6 c c perform dynamic allocation of some local arrays c allocate (xx(nvar)) allocate (glat(nvar)) allocate (xf(n)) allocate (yf(n)) allocate (zf(n)) allocate (derivs(3,n)) c c compute the fractional coordinates for each atom c call lattice do i = 1, n j = 3*i - 3 xx(j+1) = x(i)*recip(1,1) + y(i)*recip(2,1) + z(i)*recip(3,1) xx(j+2) = x(i)*recip(1,2) + y(i)*recip(2,2) + z(i)*recip(3,2) xx(j+3) = x(i)*recip(1,3) + y(i)*recip(2,3) + z(i)*recip(3,3) end do c c scale the fractional coordinates and lattice parameters c nvar = 3 * n do i = 1, nvar xx(i) = xx(i) * scale(i) end do xx(nvar+1) = xbox * scale(nvar+1) xx(nvar+2) = ybox * scale(nvar+2) xx(nvar+3) = zbox * scale(nvar+3) xx(nvar+4) = alpha * scale(nvar+4) xx(nvar+5) = beta * scale(nvar+5) xx(nvar+6) = gamma * scale(nvar+6) nvar = nvar + 6 c c make the call to the optimization routine c call ocvm (nvar,xx,minimum,grdmin,xtalmin1,optsave) c call lbfgs (nvar,xx,minimum,grdmin,xtalmin1,optsave) c c unscale fractional coordinates and get atomic coordinates c do i = 1, n j = 3*i - 3 xf(i) = xx(j+1) / scale(j+1) yf(i) = xx(j+2) / scale(j+2) zf(i) = xx(j+3) / scale(j+3) end do do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do c c compute final energy value and coordinate RMS gradient c call gradient (e,derivs) gnorm = 0.0d0 do i = 1, n do j = 1, 3 gnorm = gnorm + derivs(j,i)**2 end do end do gnorm = sqrt(gnorm) nvar = 3 * n grms = gnorm / sqrt(dble(nvar/3)) c c compute the final RMS gradient for lattice parameters c minimum = xtalmin1 (xx,glat) glnorm = 0.0d0 do i = nvar+1, nvar+6 glnorm = glnorm + (scale(i)*glat(i))**2 end do glnorm = sqrt(glnorm) glrms = glnorm / sqrt(6.0d0) c c write out the final energy and coordinate gradients c if (digits .ge. 8) then if (grms.gt.1.0d-8 .and. glrms.gt.1.0d-8) then write (iout,60) minimum,grms,gnorm,glrms,glnorm 60 format (/,' Final Potential Function Value :',f20.8, & /,' Final RMS Coordinate Gradient : ',f20.8, & /,' Final Coordinate Gradient Norm :',f20.8, & /,' Final RMS Lattice Gradient : ',f20.8, & /,' Final Lattice Gradient Norm : ',f20.8) else write (iout,70) minimum,grms,gnorm,glrms,glnorm 70 format (/,' Final Potential Function Value :',f20.8, & /,' Final RMS Coordinate Gradient : ',d20.8, & /,' Final Coordinate Gradient Norm :',d20.8, & /,' Final RMS Lattice Gradient : ',d20.8, & /,' Final Lattice Gradient Norm : ',d20.8) end if else if (digits .ge. 6) then if (grms.gt.1.0d-6 .and. glrms.gt.1.0d-6) then write (iout,80) minimum,grms,gnorm,glrms,glnorm 80 format (/,' Final Potential Function Value :',f18.6, & /,' Final RMS Coordinate Gradient : ',f18.6, & /,' Final Coordinate Gradient Norm :',f18.6, & /,' Final RMS Lattice Gradient : ',f18.6, & /,' Final Lattice Gradient Norm : ',f18.6) else write (iout,90) minimum,grms,gnorm,glrms,glnorm 90 format (/,' Final Potential Function Value :',f18.6, & /,' Final RMS Coordinate Gradient : ',d18.6, & /,' Final Coordinate Gradient Norm :',d18.6, & /,' Final RMS Lattice Gradient : ',d18.6, & /,' Final Lattice Gradient Norm : ',d18.6) end if else if (grms.gt.1.0d-4 .and. glrms.gt.1.0d-4) then write (iout,100) minimum,grms,gnorm,glrms,glnorm 100 format (/,' Final Potential Function Value :',f16.4, & /,' Final RMS Coordinate Gradient : ',f16.4, & /,' Final Coordinate Gradient Norm :',f16.4, & /,' Final RMS Lattice Gradient : ',f16.4, & /,' Final Lattice Gradient Norm : ',f16.4) else write (iout,110) minimum,grms,gnorm,glrms,glnorm 110 format (/,' Final Potential Function Value :',f16.4, & /,' Final RMS Coordinate Gradient : ',d16.4, & /,' Final Coordinate Gradient Norm :',d16.4, & /,' Final RMS Lattice Gradient : ',d16.4, & /,' Final Lattice Gradient Norm : ',d16.4) end if end if c c write out the final values of the lattice parameters c if (digits .ge. 8) then write (iout,120) xbox,ybox,zbox,alpha,beta,gamma 120 format (/,' Final Lattice Dimensions : a ',f16.8, & /,' b ',f16.8, & /,' c ',f16.8, & /,' Alpha',f16.8, & /,' Beta ',f16.8, & /,' Gamma',f16.8) else if (digits .ge. 6) then write (iout,130) xbox,ybox,zbox,alpha,beta,gamma 130 format (/,' Final Lattice Dimensions : a ',f14.6, & /,' b ',f14.6, & /,' c ',f14.6, & /,' Alpha',f14.6, & /,' Beta ',f14.6, & /,' Gamma',f14.6) else write (iout,140) xbox,ybox,zbox,alpha,beta,gamma 140 format (/,' Final Lattice Dimensions : a ',f12.4, & /,' b ',f12.4, & /,' c ',f12.4, & /,' Alpha',f12.4, & /,' Beta ',f12.4, & /,' Gamma',f12.4) 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 ## function xtalmin1 -- energy and gradient for lattice ## c ## ## c ############################################################## c c c "xtalmin1" is a service routine that computes the energy and c gradient with respect to fractional coordinates and lattice c dimensions for a crystal energy minimization c c function xtalmin1 (xx,g) use atoms use boxes use math use scales implicit none integer i,j real*8 xtalmin1,energy real*8 e,e0,old,eps real*8 xx(*) real*8 g(*) real*8, allocatable :: xf(:) real*8, allocatable :: yf(:) real*8, allocatable :: zf(:) real*8, allocatable :: derivs(:,:) c c c perform dynamic allocation of some local arrays c allocate (xf(n)) allocate (yf(n)) allocate (zf(n)) c c translate optimization variables to fractional coordinates c do i = 1, n j = 3*i - 3 xf(i) = xx(j+1) / scale(j+1) yf(i) = xx(j+2) / scale(j+2) zf(i) = xx(j+3) / scale(j+3) end do c c translate optimization variables to lattice parameters c xbox = xx(3*n+1) / scale(3*n+1) ybox = xx(3*n+2) / scale(3*n+2) zbox = xx(3*n+3) / scale(3*n+3) alpha = xx(3*n+4) / scale(3*n+4) beta = xx(3*n+5) / scale(3*n+5) gamma = xx(3*n+6) / scale(3*n+6) c c update current atomic coordinates based on optimization values c call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c find energy and fractional coordinates deriviatives c call gradient (e,derivs) xtalmin1 = e do i = 1, n j = 3*i - 3 g(j+1) = derivs(1,i)*lvec(1,1) + derivs(2,i)*lvec(1,2) & + derivs(3,i)*lvec(1,3) g(j+2) = derivs(1,i)*lvec(2,1) + derivs(2,i)*lvec(2,2) & + derivs(3,i)*lvec(2,3) g(j+3) = derivs(1,i)*lvec(3,1) + derivs(2,i)*lvec(3,2) & + derivs(3,i)*lvec(3,3) end do c c perform deallocation of some local arrays c deallocate (derivs) c c find derivative with respect to lattice a-axis length c eps = 0.0001d0 old = xbox xbox = xbox - 0.5d0*eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e0 = energy () xbox = xbox + eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e = energy () g(3*n+1) = (e - e0) / eps xbox = old c c find derivative with respect to lattice b-axis length c old = ybox ybox = ybox - 0.5d0*eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e0 = energy () ybox = ybox + eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e = energy () g(3*n+2) = (e - e0) / eps ybox = old c c find derivative with respect to lattice c-axis length c old = zbox zbox = zbox - 0.5d0*eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e0 = energy () zbox = zbox + eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e = energy () g(3*n+3) = (e - e0) / eps zbox = old c c find derivative with respect to lattice alpha angle c eps = eps * radian old = alpha alpha = alpha - 0.5d0*eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e0 = energy () alpha = alpha + eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e = energy () g(3*n+4) = (e - e0) / eps alpha = old c c find derivative with respect to lattice beta angle c old = beta beta = beta - 0.5d0*eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e0 = energy () beta = beta + eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e = energy () g(3*n+5) = (e - e0) / eps beta = old c c find derivative with respect to lattice gamma angle c old = gamma gamma = gamma - 0.5d0*eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e0 = energy () gamma = gamma + eps call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do e = energy () g(3*n+6) = (e - e0) / eps gamma = old c c revert to the original atomic coordinate values c call lattice do i = 1, n x(i) = xf(i)*lvec(1,1) + yf(i)*lvec(2,1) + zf(i)*lvec(3,1) y(i) = xf(i)*lvec(1,2) + yf(i)*lvec(2,2) + zf(i)*lvec(3,2) z(i) = xf(i)*lvec(1,3) + yf(i)*lvec(2,3) + zf(i)*lvec(3,3) end do c c apply scale factors to the coordinate and lattice gradient c do i = 1, 3*n+6 g(i) = g(i) / scale(i) end do c c perform deallocation of some local arrays c deallocate (xf) deallocate (yf) deallocate (zf) return end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################### c ## ## c ## module xtals -- structures used for parameter fitting ## c ## ## c ############################################################### c c c maxlsq maximum number of least squares variables c maxrsd maximum number of residual functions c c nxtal number of molecular structures to be stored c nvary number of potential parameters to optimize c ivary index for the types of potential parameters c iresid structure to which each residual function refers c vary atom numbers involved in potential parameters c e0_lattice ideal lattice energy for the current crystal c varxtl type of each potential parameter to be optimized c rsdxtl experimental variable for each of the residuals c c module xtals implicit none integer maxlsq,maxrsd parameter (maxlsq=1000) parameter (maxrsd=1000) integer nxtal,nvary integer ivary(maxlsq) integer iresid(maxrsd) integer vary(2,maxlsq) real*8 e0_lattice character*16 varxtl(maxlsq) character*16 rsdxtl(maxrsd) save end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################ c ## ## c ## subroutine xyzatm -- single atom internal to Cartesian ## c ## ## c ################################################################ c c c "xyzatm" computes the Cartesian coordinates of a single c atom from its defining internal coordinate values c c subroutine xyzatm (i,ia,bond,ib,angle1,ic,angle2,chiral) use atoms use inform use iounit use math implicit none integer i,ia,ib,ic,chiral real*8 bond,angle1,angle2 real*8 eps,rad1,rad2 real*8 sin1,cos1,sin2,cos2 real*8 cosine,sine,sine2 real*8 xab,yab,zab,rab real*8 xba,yba,zba,rba real*8 xbc,ybc,zbc,rbc real*8 xac,yac,zac,rac real*8 xt,yt,zt,xu,yu,zu real*8 cosb,sinb,cosg,sing real*8 xtmp,ztmp,a,b,c c c c convert angles to radians, and get their sines and cosines c eps = 0.00000001d0 rad1 = angle1 / radian rad2 = angle2 / radian sin1 = sin(rad1) cos1 = cos(rad1) sin2 = sin(rad2) cos2 = cos(rad2) c c if no second site given, place the atom at the origin c if (ia .eq. 0) then x(i) = 0.0d0 y(i) = 0.0d0 z(i) = 0.0d0 c c if no third site given, place the atom along the z-axis c else if (ib .eq. 0) then x(i) = x(ia) y(i) = y(ia) z(i) = z(ia) + bond c c if no fourth site given, place the atom in the x,z-plane c else if (ic .eq. 0) then xab = x(ia) - x(ib) yab = y(ia) - y(ib) zab = z(ia) - z(ib) rab = sqrt(xab**2 + yab**2 + zab**2) xab = xab / rab yab = yab / rab zab = zab / rab cosb = zab sinb = sqrt(xab**2 + yab**2) if (sinb .eq. 0.0d0) then cosg = 1.0d0 sing = 0.0d0 else cosg = yab / sinb sing = xab / sinb end if xtmp = bond*sin1 ztmp = rab - bond*cos1 x(i) = x(ib) + xtmp*cosg + ztmp*sing*sinb y(i) = y(ib) - xtmp*sing + ztmp*cosg*sinb z(i) = z(ib) + ztmp*cosb c c general case where the second angle is a dihedral angle c else if (chiral .eq. 0) then xab = x(ia) - x(ib) yab = y(ia) - y(ib) zab = z(ia) - z(ib) rab = sqrt(xab**2 + yab**2 + zab**2) xab = xab / rab yab = yab / rab zab = zab / rab xbc = x(ib) - x(ic) ybc = y(ib) - y(ic) zbc = z(ib) - z(ic) rbc = sqrt(xbc**2 + ybc**2 + zbc**2) xbc = xbc / rbc ybc = ybc / rbc zbc = zbc / rbc xt = zab*ybc - yab*zbc yt = xab*zbc - zab*xbc zt = yab*xbc - xab*ybc cosine = xab*xbc + yab*ybc + zab*zbc sine = sqrt(max(1.0d0-cosine**2,eps)) xt = xt / sine yt = yt / sine zt = zt / sine xu = yt*zab - zt*yab yu = zt*xab - xt*zab zu = xt*yab - yt*xab x(i) = x(ia) + bond * (xu*sin1*cos2 + xt*sin1*sin2 - xab*cos1) y(i) = y(ia) + bond * (yu*sin1*cos2 + yt*sin1*sin2 - yab*cos1) z(i) = z(ia) + bond * (zu*sin1*cos2 + zt*sin1*sin2 - zab*cos1) if (abs(cosine) .ge. 1.0d0) then cosb = zab sinb = sqrt(xab**2 + yab**2) if (sinb .eq. 0.0d0) then cosg = 1.0d0 sing = 0.0d0 else cosg = yab / sinb sing = xab / sinb end if xtmp = bond*sin1 ztmp = rab - bond*cos1 x(i) = x(ib) + xtmp*cosg + ztmp*sing*sinb y(i) = y(ib) - xtmp*sing + ztmp*cosg*sinb z(i) = z(ib) + ztmp*cosb write (iout,10) i 10 format (/,' XYZATM -- Warning, Undefined Dihedral', & ' Angle at Atom',i6) end if c c general case where the second angle is a bond angle c else if (abs(chiral) .eq. 1) then xba = x(ib) - x(ia) yba = y(ib) - y(ia) zba = z(ib) - z(ia) rba = sqrt(xba**2 + yba**2 + zba**2) xba = xba / rba yba = yba / rba zba = zba / rba xac = x(ia) - x(ic) yac = y(ia) - y(ic) zac = z(ia) - z(ic) rac = sqrt(xac**2 + yac**2 + zac**2) xac = xac / rac yac = yac / rac zac = zac / rac xt = zba*yac - yba*zac yt = xba*zac - zba*xac zt = yba*xac - xba*yac cosine = xba*xac + yba*yac + zba*zac sine2 = max(1.0d0-cosine**2,eps) if (abs(cosine) .ge. 1.0d0) then write (iout,20) i 20 format (/,' XYZATM -- Warning, Collinear Defining', & ' Atoms at Atom',i6) end if a = (-cos2 - cosine*cos1) / sine2 b = (cos1 + cosine*cos2) / sine2 c = (1.0d0 + a*cos2 - b*cos1) / sine2 if (c .gt. eps) then c = chiral * sqrt(c) else if (c .lt. -eps) then c = sqrt((a*xac+b*xba)**2 + (a*yac+b*yba)**2 & + (a*zac+b*zba)**2) a = a / c b = b / c c = 0.0d0 if (debug) then write (iout,30) ia 30 format (/,' XYZATM -- Warning, Sum of Bond Angles', & ' Too Large at Atom',i6) end if else c = 0.0d0 end if x(i) = x(ia) + bond * (a*xac + b*xba + c*xt) y(i) = y(ia) + bond * (a*yac + b*yba + c*yt) z(i) = z(ia) + bond * (a*zac + b*zba + c*zt) 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 xyzedit -- editing of Cartesian coordinates ## c ## ## c ############################################################# c c c "xyzedit" provides for modification and manipulation c of the contents of Cartesian coordinates files c c program xyzedit use atomid use atoms use bound use boxes use couple use files use inform use iounit use limits use math use molcul use ptable use titles use units use usage implicit none integer i,j,k,it integer init,stop integer ixyz,imod,itmp integer nmode,mode integer natom,nlist integer next,nask integer offset,origin integer oldtype,newtype integer freeunit,trimtext integer, allocatable :: list(:) integer, allocatable :: keep(:) integer, allocatable :: tmptype(:) real*8 xi,yi,zi real*8 xr,yr,zr real*8 xcm,ycm,zcm real*8 xnew,ynew,znew real*8 xorig,yorig,zorig real*8 ri,rij,dij real*8 phi,theta,psi real*8 cphi,ctheta,cpsi real*8 sphi,stheta,spsi real*8 dist2,cut2 real*8 random,norm,weigh real*8, allocatable :: rad(:) real*8 a(3,3) logical exist,query logical opened,multi logical append,first character*1 axis character*3 symb character*240 xyzfile character*240 modfile character*240 tmpfile character*240 record character*240 string external random,merge c c c initialize various constants and the output flags c call initial opened = .false. multi = .false. nmode = 26 offset = 0 c c find the Cartesian coordinates file to be processed c ixyz = 0 call getcart (ixyz) xyzfile = filename first = .false. c c get the force field definition and assign atom types c call attach call active call field call katom c c present a list of possible coordinate modifications c write (iout,10) 10 format (/,' The Tinker XYZ File Editing Utility Can :', & //,4x,'(1) Offset the Numbers of the Current Atoms', & /,4x,'(2) Remove User Specified Individual Atoms', & /,4x,'(3) Remove User Specified Types of Atoms', & /,4x,'(4) Delete Inactive Atoms Beyond Cutoff Range', & /,4x,'(5) Insertion of Individual Specified Atoms', & /,4x,'(6) Replace Old Atom Type with a New Type', & /,4x,'(7) Assign Connectivities for Linear Chain', & /,4x,'(8) Assign Connectivities Based on Distance', & /,4x,'(9) Assign Atom Types for BASIC Force Field', & /,3x,'(10) Transfer Atom Types from Another Structure', & /,3x,'(11) Convert Units from Bohrs to Angstroms', & /,3x,'(12) Invert thru Origin to Give Mirror Image', & /,3x,'(13) Translate All Atoms by an X,Y,Z-Vector', & /,3x,'(14) Translate Center of Mass to the Origin', & /,3x,'(15) Translate a Specified Atom to the Origin', & /,3x,'(16) Translate and Rotate to Inertial Frame', & /,3x,'(17) Rotate All Atoms Around a Specified Axis', & /,3x,'(18) Move to Specified Rigid Body Coordinates', & /,3x,'(19) Move Stray Molecules into Periodic Box', & /,3x,'(20) Trim a Periodic Box to a Smaller Size', & /,3x,'(21) Make Truncated Octahedron from Cubic Box', & /,3x,'(22) Make Rhombic Dodecahedron from Cubic Box', & /,3x,'(23) Append a Second XYZ File to Current One', & /,3x,'(24) Create and Fill a Periodic Boundary Box', & /,3x,'(25) Soak Current Molecule in Box of Solvent', & /,3x,'(26) Place Monoatomic Ions around a Solute') c c get the desired type of coordinate file modification c 20 continue abort = .false. mode = -1 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=30,end=30) mode if (mode.ge.0 .and. mode.le.nmode) query = .false. end if 30 continue if (query) then do while (mode.lt.0 .or. mode.gt.nmode) mode = 0 write (iout,40) 40 format (/,' Number of the Desired Choice [=Exit]', & ' : ',$) read (input,50,err=20,end=60) mode 50 format (i10) 60 continue end do end if c c open the file to be used for the output coordinates c if (mode.gt.0 .and. .not.opened) then opened = .true. imod = freeunit () modfile = filename(1:leng)//'.xyz' call version (modfile,'new') open (unit=imod,file=modfile,status='new') end if c c get the offset value to be used in atom renumbering c if (mode .eq. 1) then 70 continue offset = 0 query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=80,end=80) offset query = .false. end if 80 continue if (query) then write (iout,90) 90 format (/,' Offset used to Renumber the Atoms [0] : ',$) read (input,100,err=70) offset 100 format (i10) end if do while (.not. abort) call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c remove a specified list of individual atoms c if (mode .eq. 2) then allocate (list(n)) nlist = 0 do i = 1, n list(i) = 0 end do write (iout,110) 110 format (/,' Numbers of the Atoms to be Removed : ',$) read (input,120) record 120 format (a240) read (record,*,err=130,end=130) (list(i),i=1,n) 130 continue do while (list(nlist+1) .ne. 0) nlist = nlist + 1 end do do i = 1, nlist if (list(i) .gt. n) list(i) = n if (list(i) .lt. -n) list(i) = -n end do call sort4 (nlist,list) do while (.not. abort) do i = nlist, 1, -1 if (i .gt. 1) then if (list(i-1) .lt. 0) then do j = abs(list(i)), abs(list(i-1)), -1 call delete (j) end do else if (list(i) .gt. 0) then call delete (list(i)) end if else if (list(i) .gt. 0) then call delete (list(i)) end if end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do deallocate (list) if (.not. multi) then call getref (1) goto 20 end if end if c c remove atoms with any of a specified list of atom types c if (mode .eq. 3) then allocate (list(n)) nlist = 0 do i = 1, n list(i) = 0 end do write (iout,140) 140 format (/,' Atom Types to be Removed : ',$) read (input,150) record 150 format (a240) read (record,*,err=160,end=160) (list(i),i=1,n) 160 continue do while (list(nlist+1) .ne. 0) nlist = nlist + 1 end do natom = n do while (.not. abort) do i = natom, 1, -1 it = type(i) do j = 1, nlist if (list(j) .eq. it) then call delete (i) goto 170 end if end do 170 continue end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do deallocate (list) if (.not. multi) then call getref (1) goto 20 end if end if c c remove atoms that are inactive and lie outside all cutoffs c if (mode .eq. 4) then call cutoffs cut2 = 0.0d0 if (vdwcut .le. 1000.0d0) cut2 = max(vdwcut**2,cut2) if (chgcut .le. 1000.0d0) cut2 = max(chgcut**2,cut2) if (dplcut .le. 1000.0d0) cut2 = max(dplcut**2,cut2) if (mpolecut .le. 1000.0d0) cut2 = max(mpolecut**2,cut2) if (cut2 .eq. 0.0d0) cut2 = 1.0d16 allocate (list(n)) allocate (keep(n)) do while (.not. abort) nlist = 0 do i = 1, n keep(i) = 0 end do do i = 1, n if (.not. use(i)) then do j = 1, n12(i) keep(i12(j,i)) = i end do do j = 1, n13(i) keep(i13(j,i)) = i end do do j = 1, n14(i) keep(i14(j,i)) = i end do xi = x(i) yi = y(i) zi = z(i) do j = 1, n if (use(j)) then if (keep(j) .eq. i) goto 180 dist2 = (x(j)-xi)**2+(y(j)-yi)**2+(z(j)-zi)**2 if (dist2 .le. cut2) goto 180 end if end do nlist = nlist + 1 list(nlist) = i 180 continue end if end do do i = nlist, 1, -1 call delete (list(i)) end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do deallocate (list) deallocate (keep) if (.not. multi) then call getref (1) goto 20 end if end if c c insert a specified list of individual atoms c if (mode .eq. 5) then allocate (list(n)) nlist = 0 do i = 1, n list(i) = 0 end do write (iout,190) 190 format (/,' Numbers of the Atoms to be Inserted : ',$) read (input,200) record 200 format (a240) read (record,*,err=210,end=210) (list(i),i=1,n) 210 continue do while (list(nlist+1) .ne. 0) nlist = nlist + 1 end do call sort4 (nlist,list) do while (.not. abort) do i = nlist, 1, -1 if (i .gt. 1) then if (list(i-1) .lt. 0) then do j = abs(list(i-1)), abs(list(i)) call insert (j) end do else if (list(i) .gt. 0) then call insert (list(i)) end if else if (list(i) .gt. 0) then call insert (list(i)) end if end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do deallocate (list) if (.not. multi) then call getref (1) goto 20 end if end if c c get an old atom type and new atom type for replacement c if (mode .eq. 6) then 220 continue oldtype = 0 newtype = 0 call nextarg (string,exist) if (exist) read (string,*,err=230,end=230) oldtype call nextarg (string,exist) if (exist) read (string,*,err=230,end=230) newtype 230 continue if (oldtype.eq.0 .or. newtype.eq.0) then write (iout,240) 240 format (/,' Numbers of the Old and New Atom Types : ',$) read (input,250) record 250 format (a240) end if read (record,*,err=220,end=220) oldtype,newtype do while (.not. abort) do i = 1, n if (use(i)) then if (type(i) .eq. oldtype) then type(i) = newtype end if end if end do call katom call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c assign atom connectivities to produce a linear chain c if (mode .eq. 7) then do while (.not. abort) do i = 1, n n12(i) = 0 if (i .ne. 1) then n12(i) = n12(i) + 1 i12(n12(i),i) = i - 1 end if if (i .ne. n) then n12(i) = n12(i) + 1 i12(n12(i),i) = i + 1 end if end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c assign atom connectivities based on interatomic distances c if (mode .eq. 8) then allocate (rad(n)) do while (.not. abort) call unitcell call lattice do i = 1, n rad(i) = 0.76d0 k = atomic(i) if (k .ne. 0) then rad(i) = covrad(k) else symb = name(i) call upcase (symb(1:1)) call lowcase (symb(2:3)) do j = 1, maxele if (symb .eq. elemnt(j)) then k = j goto 260 end if end do do j = 1, maxele if (symb(1:1) .eq. elemnt(j)(1:1)) then k = j goto 260 end if end do 260 continue if (k .ne. 0) rad(i) = covrad(k) end if rad(i) = 1.15d0 * rad(i) end do do i = 1, n n12(i) = 0 end do do i = 1, n-1 xi = x(i) yi = y(i) zi = z(i) ri = rad(i) do j = i+1, n xr = x(j) - xi yr = y(j) - yi zr = z(j) - zi rij = ri + rad(j) dij = sqrt(xr*xr + yr*yr + zr*zr) if (dij .lt. rij) then n12(i) = n12(i) + 1 i12(n12(i),i) = j n12(j) = n12(j) + 1 i12(n12(j),j) = i end if end do end do do i = 1, n call sort (n12(i),i12(1,i)) end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do deallocate (rad) if (.not. multi) then call getref (1) goto 20 end if end if c c assign atom types for the Tinker BASIC force field c if (mode .eq. 9) then do while (.not. abort) do i = 1, n k = atomic(i) if (k .eq. 0) then symb = name(i) call upcase (symb(1:1)) call lowcase (symb(2:3)) do j = 1, maxele if (symb .eq. elemnt(j)) then k = j goto 270 end if end do do j = 1, maxele if (symb(1:1) .eq. elemnt(j)(1:1)) then k = j goto 270 end if end do 270 continue end if type(i) = 10*k + n12(i) end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c transfer atoms types from one structure to another c if (mode .eq. 10) then call makeref (1) call nextarg (tmpfile,exist) if (exist) then call basefile (tmpfile) call suffix (tmpfile,'xyz','old') inquire (file=tmpfile,exist=exist) end if nask = 0 do while (.not.exist .and. nask.lt.maxask) write (iout,280) 280 format (/,' Enter Name of Atom Type Template', & ' Structure : ',$) read (input,290) tmpfile 290 format (a240) call basefile (tmpfile) call suffix (tmpfile,'xyz','old') inquire (file=tmpfile,exist=exist) end do itmp = freeunit () open (unit=itmp,file=tmpfile,status='old') rewind (unit=itmp) call readxyz (itmp) close (unit=itmp) allocate (tmptype(n)) do i = 1, n tmptype(i) = type(i) end do filename = xyzfile call getref (1) do while (.not. abort) do i = 1, n if (use(i)) type(i) = tmptype(i) end do call katom call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do deallocate (tmptype) if (.not. multi) then call getref (1) goto 20 end if end if c c convert the coordinate units from Bohrs to Angstroms c if (mode .eq. 11) then do while (.not. abort) do i = 1, n x(i) = x(i) * bohr y(i) = y(i) * bohr z(i) = z(i) * bohr end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c get mirror image by inverting coordinates through origin c if (mode .eq. 12) then do while (.not. abort) do i = 1, n x(i) = -x(i) y(i) = -y(i) z(i) = -z(i) end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c translate the entire system by a specified x,y,z-vector c if (mode .eq. 13) then xr = 0.0d0 yr = 0.0d0 zr = 0.0d0 call nextarg (string,exist) if (exist) read (string,*,err=300,end=300) xr call nextarg (string,exist) if (exist) read (string,*,err=300,end=300) yr call nextarg (string,exist) if (exist) read (string,*,err=300,end=300) zr 300 continue if (xr.eq.0.0d0 .and. yr.eq.0.0d0 .and. zr.eq.0.0d0) then write (iout,310) 310 format (/,' Enter Translation Vector Components : ',$) read (input,320) record 320 format (a240) read (record,*,err=330,end=330) xr,yr,zr 330 continue end if do while (.not. abort) do i = 1, n x(i) = x(i) + xr y(i) = y(i) + yr z(i) = z(i) + zr end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c translate the center of mass to the coordinate origin c if (mode .eq. 14) then do while (.not. abort) xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 norm = 0.0d0 do i = 1, n if (use(i)) then weigh = mass(i) xcm = xcm + x(i)*weigh ycm = ycm + y(i)*weigh zcm = zcm + z(i)*weigh norm = norm + weigh end if end do xcm = xcm / norm ycm = ycm / norm zcm = zcm / norm do i = 1, n x(i) = x(i) - xcm y(i) = y(i) - ycm z(i) = z(i) - zcm end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c translate to place a specified atom at the origin c if (mode .eq. 15) then origin = 0 call nextarg (string,exist) if (exist) read (string,*,err=340,end=340) origin 340 continue if (origin .eq. 0) then write (iout,350) 350 format (/,' Number of the Atom to Move to the Origin', & ' : ',$) read (input,360) origin 360 format (i10) end if do while (.not. abort) xorig = x(origin) yorig = y(origin) zorig = z(origin) do i = 1, n x(i) = x(i) - xorig y(i) = y(i) - yorig z(i) = z(i) - zorig end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c translate and rotate into standard orientation c if (mode .eq. 16) then do while (.not. abort) call inertia (2) call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c rotate about a coordinate axis by a specified amount c if (mode .eq. 17) then axis = ' ' theta = 0.0d0 call nextarg (string,exist) if (exist) read (string,*,err=370,end=370) axis call nextarg (string,exist) if (exist) read (string,*,err=370,end=370) theta 370 continue if (axis .eq. ' ') then write (iout,380) 380 format (/,' Enter Axis (X,Y,Z) and Rotation [0 deg] : ',$) read (input,390) string 390 format (a240) next = 1 call getword (string,axis,next) call upcase (axis) string = string(next:240) read (string,*,err=400,end=400) theta 400 continue end if theta = theta / radian ctheta = cos(theta) stheta = sin(theta) do i = 1, 3 do j = 1, 3 a(j,i) = 0.0d0 end do a(i,i) = 1.0d0 end do if (axis .eq. 'X') then a(2,2) = ctheta a(3,2) = stheta a(2,3) = -stheta a(3,3) = ctheta else if (axis .eq. 'Y') then a(1,1) = ctheta a(3,1) = -stheta a(1,3) = stheta a(3,3) = ctheta else if (axis .eq. 'Z') then a(1,1) = ctheta a(2,1) = stheta a(1,2) = -stheta a(2,2) = ctheta end if do while (.not. abort) do i = 1, n xorig = x(i) yorig = y(i) zorig = z(i) x(i) = a(1,1)*xorig + a(2,1)*yorig + a(3,1)*zorig + xcm y(i) = a(1,2)*xorig + a(2,2)*yorig + a(3,2)*zorig + ycm z(i) = a(1,3)*xorig + a(2,3)*yorig + a(3,3)*zorig + zcm end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c translate and rotate to specified rigid body coordinates c if (mode .eq. 18) then xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 phi = 0.0d0 theta = 0.0d0 psi = 0.0d0 call nextarg (string,exist) if (exist) read (string,*,err=410,end=410) xcm call nextarg (string,exist) if (exist) read (string,*,err=410,end=410) ycm call nextarg (string,exist) if (exist) read (string,*,err=410,end=410) zcm call nextarg (string,exist) if (exist) read (string,*,err=410,end=410) phi call nextarg (string,exist) if (exist) read (string,*,err=410,end=410) theta call nextarg (string,exist) if (exist) read (string,*,err=410,end=410) psi 410 continue if (min(xcm,ycm,zcm,phi,theta,psi).eq.0.0d0 .and. & max(xcm,ycm,zcm,phi,theta,psi).eq.0.0d0) then write (iout,420) 420 format (/,' Enter Rigid Body Coordinates : ',$) read (input,430) record 430 format (a240) read (record,*,err=440,end=440) xcm,ycm,zcm,phi,theta,psi 440 continue end if call inertia (2) phi = phi / radian theta = theta / radian psi = psi / radian cphi = cos(phi) sphi = sin(phi) ctheta = cos(theta) stheta = sin(theta) cpsi = cos(psi) spsi = sin(psi) a(1,1) = ctheta * cphi a(2,1) = spsi*stheta*cphi - cpsi*sphi a(3,1) = cpsi*stheta*cphi + spsi*sphi a(1,2) = ctheta * sphi a(2,2) = spsi*stheta*sphi + cpsi*cphi a(3,2) = cpsi*stheta*sphi - spsi*cphi a(1,3) = -stheta a(2,3) = ctheta * spsi a(3,3) = ctheta * cpsi do while (.not. abort) do i = 1, n xorig = x(i) yorig = y(i) zorig = z(i) x(i) = a(1,1)*xorig + a(2,1)*yorig + a(3,1)*zorig + xcm y(i) = a(1,2)*xorig + a(2,2)*yorig + a(3,2)*zorig + ycm z(i) = a(1,3)*xorig + a(2,3)*yorig + a(3,3)*zorig + zcm end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c move stray molecules back into original periodic box c if (mode .eq. 19) then do while (.not. abort) call unitcell if (use_bounds) then call lattice call molecule call bounds end if call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c remove molecules to trim periodic box to smaller size c if (mode .eq. 20) then xnew = 0.0d0 ynew = 0.0d0 znew = 0.0d0 call nextarg (string,exist) if (exist) read (string,*,err=450,end=450) xnew call nextarg (string,exist) if (exist) read (string,*,err=450,end=450) ynew call nextarg (string,exist) if (exist) read (string,*,err=450,end=450) znew 450 continue do while (xnew .eq. 0.0d0) write (iout,460) 460 format (/,' Enter Periodic Box Dimensions (X,Y,Z) : ',$) read (input,470) record 470 format (a240) read (record,*,err=480,end=480) xnew,ynew,znew 480 continue end do if (ynew .eq. 0.0d0) ynew = xnew if (znew .eq. 0.0d0) znew = xnew xbox = xnew ybox = ynew zbox = znew call lattice call molecule allocate (list(n)) allocate (keep(n)) do while (.not. abort) do i = 1, n list(i) = 1 end do do i = 1, nmol init = imol(1,i) stop = imol(2,i) xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 do j = init, stop k = kmol(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do weigh = molmass(i) xcm = xcm / weigh ycm = ycm / weigh zcm = zcm / weigh if (abs(xcm).gt.xbox2 .or. abs(ycm).gt.ybox2 & .or. abs(zcm).gt.zbox2) then do j = init, stop k = kmol(j) list(k) = 0 end do end if end do k = 0 do i = 1, n if (list(i) .ne. 0) then k = k + 1 keep(k) = i list(i) = k end if end do n = k do k = 1, n i = keep(k) name(k) = name(i) x(k) = x(i) y(k) = y(i) z(k) = z(i) type(k) = type(i) n12(k) = n12(i) do j = 1, n12(k) i12(j,k) = list(i12(j,i)) end do end do call makeref (1) call readcart (ixyz,first) if (.not. abort) then multi = .true. xbox = xnew ybox = ynew zbox = znew call lattice call molecule end if if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do deallocate (list) deallocate (keep) if (.not. multi) then call getref (1) goto 20 end if end if c c trim cube to truncated octahedron or rhombic dodecahedron c if (mode.eq.21 .or. mode.eq.22) then call unitcell do while (xbox .eq. 0.0d0) write (iout,490) 490 format (/,' Enter Edge Length of Cubic Periodic Box : ',$) read (input,500) record 500 format (a240) read (record,*,err=510,end=510) xbox 510 continue end do ybox = xbox zbox = xbox nonprism = .false. octahedron = .false. dodecadron = .false. call bounds nonprism = .true. if (mode .eq. 20) octahedron = .true. if (mode .eq. 21) dodecadron = .true. if (dodecadron) zbox = xbox * root2 call lattice call molecule allocate (list(n)) allocate (keep(n)) do while (.not. abort) do i = 1, n list(i) = 1 end do do i = 1, nmol init = imol(1,i) stop = imol(2,i) xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 do j = init, stop k = kmol(j) weigh = mass(k) xcm = xcm + x(k)*weigh ycm = ycm + y(k)*weigh zcm = zcm + z(k)*weigh end do weigh = molmass(i) xcm = xcm / weigh ycm = ycm / weigh zcm = zcm / weigh if (octahedron) then xcm = xcm - xbox*nint(xcm/xbox) ycm = ycm - ybox*nint(ycm/ybox) zcm = zcm - zbox*nint(zcm/zbox) if (abs(xcm)+abs(ycm)+abs(zcm) .gt. box34) then do j = init, stop k = kmol(j) list(k) = 0 end do end if else if (dodecadron) then xcm = xcm - xbox*nint(xcm/xbox) ycm = ycm - ybox*nint(ycm/ybox) zcm = zcm - root2*zbox*nint(zcm/(zbox*root2)) if (abs(xcm)+abs(ycm)+abs(root2*zcm) .gt. xbox) then do j = init, stop k = kmol(j) list(k) = 0 end do end if end if end do k = 0 do i = 1, n if (list(i) .ne. 0) then k = k + 1 keep(k) = i list(i) = k end if end do n = k do k = 1, n i = keep(k) name(k) = name(i) x(k) = x(i) y(k) = y(i) z(k) = z(i) type(k) = type(i) n12(k) = n12(i) do j = 1, n12(k) i12(j,k) = list(i12(j,i)) end do end do call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do deallocate (list) deallocate (keep) if (.not. multi) then call getref (1) goto 20 end if end if c c append a second file to the current coordinates file c if (mode .eq. 23) then append = .false. do while (.not. abort) call makeref (1) if (append) then call getref (3) else call getxyz call makeref (3) append = .true. end if call merge (1) call makeref (1) call readcart (ixyz,first) if (.not. abort) multi = .true. if (multi) then call makeref (2) call getref (1) call prtmod (imod,offset) call getref (2) end if end do if (.not. multi) then call getref (1) goto 20 end if end if c c create random box full of the current coordinates file c if (mode .eq. 24) then call makebox end if c c solvate the current system by insertion into a solvent box c if (mode .eq. 25) then call soak end if c c replace random solvent molecules outside solute with ions c if (mode .eq. 26) then call molecule call addions end if c c output final coordinates for single frame and print info c if (opened .and. .not.multi) then call prtmod (imod,offset) end if if (opened) then close (unit=imod) write (iout,520) modfile(1:trimtext(modfile)) 520 format (/,' New Coordinates Written To : ',a) end if close (unit=ixyz) c c perform any final tasks before program exit c call final end c c c ################################################################ c ## ## c ## subroutine prtmod -- Cartesian coordinates with offset ## c ## ## c ################################################################ c c c "prtmod" writes out a set of modified Cartesian coordinates c with an optional atom number offset to an external disk file c c subroutine prtmod (imod,offset) use atomid use atoms use bound use boxes use couple use inform use titles implicit none integer i,j,k,imod integer offset integer size,crdsiz real*8 crdmin,crdmax character*2 atmc character*2 crdc character*2 digc character*25 fstr c c c check for large systems needing extended formatting c atmc = 'i6' if (n+offset .ge. 100000) atmc = 'i7' if (n+offset .ge. 1000000) atmc = 'i8' crdmin = 0.0d0 crdmax = 0.0d0 do i = 1, n crdmin = min(crdmin,x(i),y(i),z(i)) crdmax = max(crdmax,x(i),y(i),z(i)) end do crdsiz = 6 if (crdmin .le. -1000.0d0) crdsiz = 7 if (crdmax .ge. 10000.0d0) crdsiz = 7 if (crdmin .le. -10000.0d0) crdsiz = 8 if (crdmax .ge. 100000.0d0) crdsiz = 8 crdsiz = crdsiz + max(6,digits) size = 0 call numeral (crdsiz,crdc,size) if (digits .le. 6) then digc = '6 ' else if (digits .le. 8) then digc = '8' else digc = '10' end if c c write out the number of atoms and the title c if (ltitle .eq. 0) then fstr = '('//atmc//')' write (imod,fstr(1:4)) n else fstr = '('//atmc//',2x,a)' write (imod,fstr(1:9)) n,title(1:ltitle) end if c c write out the periodic cell lengths and angles c if (use_bounds) then fstr = '(1x,6f'//crdc//'.'//digc//')' write (imod,fstr) xbox,ybox,zbox,alpha,beta,gamma end if c c write out the coordinate line for each atom c fstr = '('//atmc//',2x,a3,3f'//crdc// & '.'//digc//',i6,8'//atmc//')' do i = 1, n k = n12(i) if (k .eq. 0) then write (imod,fstr) i+offset,name(i),x(i),y(i),z(i),type(i) else write (imod,fstr) i+offset,name(i),x(i),y(i),z(i),type(i), & (i12(j,i)+offset,j=1,k) end if end do return end c c c ################################################################ c ## ## c ## subroutine makebox -- build periodic box from monomers ## c ## ## c ################################################################ c c c "makebox" builds a periodic box of a desired size by randomly c copying a specified number of monomers into a target box size, c followed by optional excluded volume refinement c c subroutine makebox use atomid use atoms use boxes use couple use iounit implicit none integer i,j,k,m integer ncopy integer offset real*8 xcm,ycm,zcm real*8 phi,theta,psi real*8 cphi,ctheta,cpsi real*8 sphi,stheta,spsi real*8 random,reduce real*8 norm,weigh real*8, allocatable :: x0(:) real*8, allocatable :: y0(:) real*8, allocatable :: z0(:) real*8 a(3,3) logical exist,query logical refine character*1 answer character*240 record character*240 string c c c get the number of copies of the monomer to be used c ncopy = 0 call nextarg (string,exist) if (exist) read (string,*,err=10,end=10) ncopy 10 continue if (ncopy .eq. 0) then write (iout,20) 20 format (/,' Enter Number of Copies to Put in Box : ',$) read (input,30) ncopy 30 format (i10) end if c c find the size of the periodic box to be constructed c xbox = 0.0d0 ybox = 0.0d0 zbox = 0.0d0 call nextarg (string,exist) if (exist) read (string,*,err=40,end=40) xbox call nextarg (string,exist) if (exist) read (string,*,err=40,end=40) ybox call nextarg (string,exist) if (exist) read (string,*,err=40,end=40) zbox 40 continue do while (xbox .eq. 0.0d0) write (iout,50) 50 format (/,' Enter Periodic Box Dimensions (X,Y,Z) : ',$) read (input,60) record 60 format (a240) read (record,*,err=70,end=70) xbox,ybox,zbox 70 continue end do if (ybox .eq. 0.0d0) ybox = xbox if (zbox .eq. 0.0d0) zbox = xbox orthogonal = .true. c c decide whether to use excluded volume refinement c refine = .true. answer = 'Y' query = .true. call nextarg (string,exist) if (exist) then read (string,*,err=80,end=80) answer query = .false. end if 80 continue if (query) then write (iout,90) 90 format (/,' Refine the Periodic Box Configuration', & ' [Y] : ',$) read (input,100) answer 100 format (a1) end if call upcase (answer) if (answer .eq. 'N') refine = .false. c c center the monomer and reduce its size to avoid overlap c xcm = 0.0d0 ycm = 0.0d0 zcm = 0.0d0 norm = 0.0d0 do i = 1, n weigh = mass(i) xcm = xcm + x(i)*weigh ycm = ycm + y(i)*weigh zcm = zcm + z(i)*weigh norm = norm + weigh end do xcm = xcm / norm ycm = ycm / norm zcm = zcm / norm allocate (x0(n)) allocate (y0(n)) allocate (z0(n)) reduce = 0.001d0 do i = 1, n x(i) = x(i) - xcm y(i) = y(i) - ycm z(i) = z(i) - zcm if (refine) then x(i) = reduce * x(i) y(i) = reduce * y(i) z(i) = reduce * z(i) end if x0(i) = x(i) y0(i) = y(i) z0(i) = z(i) end do c c randomly place monomer copies in the periodic box c do k = 1, ncopy offset = (k-1) * n xcm = xbox * (random()-0.5d0) ycm = ybox * (random()-0.5d0) zcm = zbox * (random()-0.5d0) phi = 360.0d0 * random () theta = 360.0d0 * random () psi = 360.0d0 * random () cphi = cos(phi) sphi = sin(phi) ctheta = cos(theta) stheta = sin(theta) cpsi = cos(psi) spsi = sin(psi) a(1,1) = ctheta * cphi a(2,1) = spsi*stheta*cphi - cpsi*sphi a(3,1) = cpsi*stheta*cphi + spsi*sphi a(1,2) = ctheta * sphi a(2,2) = spsi*stheta*sphi + cpsi*cphi a(3,2) = cpsi*stheta*sphi - spsi*cphi a(1,3) = -stheta a(2,3) = ctheta * spsi a(3,3) = ctheta * cpsi do i = 1, n j = i + offset name(j) = name(i) type(j) = type(i) mass(j) = mass(i) x(j) = a(1,1)*x0(i) + a(2,1)*y0(i) + a(3,1)*z0(i) + xcm y(j) = a(1,2)*x0(i) + a(2,2)*y0(i) + a(3,2)*z0(i) + ycm z(j) = a(1,3)*x0(i) + a(2,3)*y0(i) + a(3,3)*z0(i) + zcm n12(j) = n12(i) do m = 1, n12(i) i12(m,j) = i12(m,i) + offset end do end do end do deallocate (x0) deallocate (y0) deallocate (z0) offset = 0 n = ncopy * n c c optionally perform excluded volume coordinate refinement c if (refine) then call boxfix call bounds else call lattice call molecule call bounds end if return end c c c ################################################################# c ## ## c ## subroutine boxfix -- expand molecules into periodic box ## c ## ## c ################################################################# c c c "boxfix" uses minimization of valence and vdw potential energy c to expand and refine a collection of solvent molecules in a c periodic box c c subroutine boxfix use atomid use atoms use boxes use inform use limits use linmin use minima use neigh use output use potent use scales use vdw use vdwpot implicit none integer i,j,k,nvar integer ii,kk real*8 minimum real*8 boxfix1 real*8 grdmin real*8 boxsiz real*8, allocatable :: xx(:) external boxfix1 external optsave c c c setup for minimization with only valence and vdw terms c call mechanic call potoff use_bond = .true. use_angle = .true. use_opbend = .true. use_opdist = .true. use_improp = .true. use_imptor = .true. use_tors = .true. use_vdw = .true. c c set artificial Lennard-Jones vdw values for the system c vdwtyp = 'LENNARD-JONES' nvdw = n do i = 1, n ivdw(i) = i jvdw(i) = mvdw(class(i)) ired(i) = i end do do i = 1, n-1 ii = jvdw(i) do k = i+1, n kk = jvdw(k) if (atomic(i).eq.1 .and. atomic(k).eq.1) then radmin(ii,kk) = 2.90d0 epsilon(ii,kk) = 0.016d0 radmin4(ii,kk) = 2.90d0 epsilon4(ii,kk) = 0.016d0 else if (atomic(i).eq.1 .or. atomic(k).eq.1) then radmin(ii,kk) = 3.35d0 epsilon(ii,kk) = 0.040d0 radmin4(ii,kk) = 3.35d0 epsilon4(ii,kk) = 0.040d0 else radmin(ii,kk) = 3.80d0 epsilon(ii,kk) = 0.100d0 radmin4(ii,kk) = 3.80d0 epsilon4(ii,kk) = 0.100d0 end if end do end do c c cutoff values and neighbor lists for vdw interactions c use_list = .false. use_vlist = .false. vdwcut = 5.0d0 vdwtaper = 4.5d0 lbuffer = 1.0d0 boxsiz = min(xbox,ybox,zbox) if (boxsiz .gt. 2.0d0*(vdwcut+lbuffer)) then use_list = .true. use_vlist = .true. dovlst = .true. lbuf2 = (0.5d0*lbuffer)**2 vbuf2 = (vdwcut+lbuffer)**2 vbufx = (vdwcut+2.0d0*lbuffer)**2 maxvlst = int(sqrt(vbuf2)**3) + 100 end if c c perform dynamic allocation of some global arrays c if (use_vlist) 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 c c perform dynamic allocation of some global arrays c if (.not. allocated(scale)) allocate (scale(3*n)) c c mark for use of all atoms, and set scale factors c nvar = 0 do i = 1, n do j = 1, 3 nvar = nvar + 1 scale(nvar) = 12.0d0 end do end do c c perform dynamic allocation of some local arrays c allocate (xx(nvar)) c c scale the coordinates of each active atom c nvar = 0 do i = 1, n nvar = nvar + 1 xx(nvar) = x(i) * scale(nvar) nvar = nvar + 1 xx(nvar) = y(i) * scale(nvar) nvar = nvar + 1 xx(nvar) = z(i) * scale(nvar) end do c c make the call to the optimization routine c iprint = 100 maxiter = 10000 stpmax = 10.0d0 grdmin = 1.0d0 coordtype = 'NONE' call lbfgs (nvar,xx,minimum,grdmin,boxfix1,optsave) c c unscale the final coordinates for active atoms c nvar = 0 do i = 1, n nvar = nvar + 1 x(i) = xx(nvar) / scale(nvar) nvar = nvar + 1 y(i) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(i) = xx(nvar) / scale(nvar) end do c c perform deallocation of some local arrays c deallocate (xx) return end c c c ############################################################ c ## ## c ## function boxfix1 -- energy and gradient for boxfix ## c ## ## c ############################################################ c c c "boxfix1" is a service routine that computes the energy and c gradient during refinement of a periodic box c c function boxfix1 (xx,g) use atoms use energi use potent use repel use scales implicit none integer i,nvar real*8 e,boxfix1 real*8 xx(*) real*8 g(*) real*8, allocatable :: derivs(:,:) c c c convert optimization parameters to atomic coordinates c nvar = 0 do i = 1, n nvar = nvar + 1 x(i) = xx(nvar) / scale(nvar) nvar = nvar + 1 y(i) = xx(nvar) / scale(nvar) nvar = nvar + 1 z(i) = xx(nvar) / scale(nvar) end do c c perform dynamic allocation of some local arrays c allocate (derivs(3,n)) c c compute and store the energy and gradient c call gradient (e,derivs) boxfix1 = e c c convert gradient components to optimization parameters c nvar = 0 do i = 1, n nvar = nvar + 1 g(nvar) = derivs(1,i) / scale(nvar) nvar = nvar + 1 g(nvar) = derivs(2,i) / scale(nvar) nvar = nvar + 1 g(nvar) = derivs(3,i) / scale(nvar) end do c c perform deallocation of some local arrays c deallocate (derivs) return end c c c ############################################################## c ## ## c ## subroutine soak -- place a solute into a solvent box ## c ## ## c ############################################################## c c c "soak" takes a currently defined solute system and places c it into a solvent box, with removal of any solvent molecules c that overlap the solute c c subroutine soak use atomid use atoms use bound use boxes use couple use files use inform use iounit use molcul use output use refer implicit none integer i,j,k integer ii,jj integer n12i,n12k integer isolv,iaux integer icount,nask integer ntot,freeunit integer, allocatable :: map(:) real*8 xi,yi,zi real*8 xr,yr,zr real*8 rik2,close2 real*8 dxx,dxx2 real*8 dxh,dxh2 real*8 dhh,dhh2 logical exist,header logical first logical, allocatable :: remove(:) character*240 solvfile character*240 auxfile external merge c c c make a copy of the solute coordinates and connectivities c call makeref (1) c c get the filename for the solvent box coordinates c call nextarg (solvfile,exist) if (exist) then call basefile (solvfile) call suffix (solvfile,'xyz','old') inquire (file=solvfile,exist=exist) end if nask = 0 do while (.not.exist .and. nask.lt.maxask) write (iout,10) 10 format (/,' Enter Name of Solvent Box Coordinates : ',$) read (input,20) solvfile 20 format (a240) call basefile (solvfile) if (archive) then call suffix (solvfile,'xyz','old') else if (binary) then call suffix (solvfile,'dcd','old') end if inquire (file=solvfile,exist=exist) end do c c read the coordinate file containing the solvent atoms c if (archive) then isolv = freeunit () open (unit=isolv,file=solvfile,status='old') rewind (unit=isolv) call readxyz (isolv) close (unit=isolv) else if (binary) then call nextarg (auxfile,exist) if (exist) then call basefile (auxfile) call suffix (auxfile,'xyz','old') inquire (file=auxfile,exist=exist) end if nask = 0 do while (.not.exist .and. nask.lt.maxask) nask = nask + 1 write (iout,30) 30 format (/,' Enter Formatted Coordinate File Name : ',$) read (input,40) auxfile 40 format (a240) call basefile (auxfile) call suffix (auxfile,'xyz','old') inquire (file=auxfile,exist=exist) end do if (.not. exist) call fatal iaux = freeunit () open (unit=iaux,file=auxfile,status='old') rewind (unit=iaux) call readxyz (iaux) close (unit=iaux) filename = solvfile isolv = freeunit () open (unit=isolv,file=solvfile,form='unformatted',status='old') rewind (unit=isolv) first = .true. call readdcd (isolv,first) close (unit=isolv) end if c c combine solute and solvent into a single coordinate set c call merge (1) call basefile (solvfile) call getkey c c reset the default values for unitcell dimensions c xbox = 0.0d0 ybox = 0.0d0 zbox = 0.0d0 alpha = 0.0d0 beta = 0.0d0 gamma = 0.0d0 c c count number of molecules and set lattice parameters c call molecule call unitcell call lattice c c set distance cutoffs for solute-solvent close contacts c dxx = 2.40d0 dxh = 2.19d0 dhh = 1.82d0 dxx2 = dxx * dxx dxh2 = dxh * dxh dhh2 = dhh * dhh c c perform dynamic allocation of some local arrays c allocate (map(n)) allocate (remove(nmol)) c c initialize the list of solvent molecules to be deleted c do i = 1, nmol remove(i) = .false. end do c c print header information when processing large systems c icount = 0 header = .true. if (n-nref(1) .ge. 10000) then write (iout,50) 50 format (/,' Scan for Solvent Molecules to be Removed :') end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(nref,n,x,y,z,n12,molcule,dxx2,dxh2,dhh2,remove, !$OMP& header,icount,iout) !$OMP DO schedule(guided) c c search for close contacts between solute and solvent c do i = nref(1)+1, n if (.not. remove(molcule(i))) then xi = x(i) yi = y(i) zi = z(i) n12i = n12(i) do k = 1, nref(1) n12k = n12(k) xr = x(k) - xi yr = y(k) - yi zr = z(k) - zi call imagen (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr if (n12i.gt.1 .and. n12k.gt.1) then close2 = dxx2 else if (n12i.gt.1 .or. n12k.gt.1) then close2 = dxh2 else close2 = dhh2 end if if (rik2 .lt. close2) then remove(molcule(i)) = .true. goto 60 end if end do 60 continue end if icount = icount + 1 if (mod(icount,10000) .eq. 0) then if (header) then header = .false. write (iout,70) 70 format () end if write (iout,80) 10000*(icount/10000) 80 format (' Solvent Atoms Processed',i15) end if end do c c OpenMP directives for the major loop structure c !$OMP END DO !$OMP END PARALLEL c c print final status when processing large systems c icount = n - nref(1) if (mod(icount,10000).ne.0 .and. icount.gt.10000) then write (iout,90) icount 90 format (' Solvent Atoms Processed',i15) end if c c delete solvent molecules that are too close to the solute c k = nref(1) ntot = k do i = nref(1)+1, n map(i) = 0 if (.not. remove(molcule(i))) then k = k + 1 map(i) = k ntot = k end if end do do i = nref(1)+1, n ii = map(i) if (ii .ne. 0) then x(ii) = x(i) y(ii) = y(i) z(ii) = z(i) name(ii) = name(i) type(ii) = type(i) k = 0 do j = 1, n12(i) jj = map(i12(j,i)) if (jj .ne. 0) then k = k + 1 i12(k,ii) = jj end if end do n12(ii) = k end if end do n = ntot c c perform deallocation of some local arrays c deallocate (map) deallocate (remove) return end c c c ############################################################### c ## ## c ## subroutine addions -- placement of ions around solute ## c ## ## c ############################################################### c c c "addions" takes a currently defined solvated system and c places ions, with removal of solvent molecules c c subroutine addions use atomid use atoms use couple use iounit use katoms use molcul implicit none integer i,j,k integer nsolute,size integer start,stop integer icount,iontyp integer ncopy,ranatm integer, allocatable :: list(:) integer, allocatable :: isolute(:) real*8 xi,yi,zi real*8 xr,yr,zr,rik2 real*8 close,close2 real*8 rand,random real*8 weigh,xmid,ymid,zmid real*8, allocatable :: xion(:) real*8, allocatable :: yion(:) real*8, allocatable :: zion(:) logical exist,header,done logical, allocatable :: remove(:) character*240 record character*240 string external random c c c perform dynamic allocation of some local arrays c size = 40 allocate (list(size)) allocate (isolute(n)) c c get the range atoms numbers constituting the solute c do i = 1, size list(i) = 0 end do i = 0 do while (exist) call nextarg (string,exist) if (exist) then read (string,*,err=10,end=10) list(i+1) i = i + 1 end if end do 10 continue if (i .eq. 0) then write (iout,20) 20 format (/,' Enter Atom Numbers in Solute Molecules : ',$) read (input,30) record 30 format (a240) read (record,*,err=40,end=40) (list(i),i=1,size) 40 continue end if i = 1 nsolute = 0 do while (list(i) .ne. 0) list(i) = max(-n,min(n,list(i))) if (list(i) .gt. 0) then k = list(i) nsolute = nsolute + 1 isolute(nsolute) = k i = i + 1 else list(i+1) = max(-n,min(n,list(i+1))) do k = abs(list(i)), abs(list(i+1)) nsolute = nsolute + 1 isolute(nsolute) = k end do i = i + 2 end if end do c c get the atom type of ion to be added and number of copies c 50 continue iontyp = 0 ncopy = 0 call nextarg (string,exist) if (exist) read (string,*,err=60,end=60) iontyp call nextarg (string,exist) if (exist) read (string,*,err=60,end=60) ncopy 60 continue if (iontyp.eq.0 .or. ncopy.eq.0) then write (iout,70) 70 format (/,' Enter Ion Atom Type Number & Copies to Add : ',$) read (input,80) record 80 format (a240) end if read (record,*,err=50,end=50) iontyp,ncopy c c set minimum distance cutoff for solute-ion contacts c close = 6.0d0 close2 = close * close c c perform dynamic allocation of some local arrays c allocate (remove(nmol)) allocate (xion(ncopy)) allocate (yion(ncopy)) allocate (zion(ncopy)) c c initialize the list of solvent molecules to be deleted c do i = 1, nmol remove(i) = .false. end do c c print header information when processing large systems c icount = 0 header = .true. if (n .ge. 10000) then write (iout,90) 90 format (/,' Scan for Available Locations to Place Ions :') end if c c OpenMP directives for the major loop structure c !$OMP PARALLEL default(private) !$OMP& shared(n,x,y,z,molcule,close2,remove,header,nsolute, !$OMP& isolute,icount,iout) !$OMP DO schedule(guided) c c search for short distance between solute and solvent c do i = 1, n if (.not. remove(molcule(i))) then xi = x(i) yi = y(i) zi = z(i) do k = 1, nsolute j = isolute(k) xr = x(j) - xi yr = y(j) - yi zr = z(j) - zi call imagen (xr,yr,zr) rik2 = xr*xr + yr*yr + zr*zr if (rik2 .lt. close2) then remove(molcule(i)) = .true. goto 100 end if end do 100 continue end if icount = icount + 1 if (mod(icount,10000) .eq. 0) then if (header) then header = .false. write (iout,110) 110 format () end if write (iout,120) 10000*(icount/10000) 120 format (' Solvent Atoms Processed',i15) 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 (list) deallocate (isolute) c c print final status when processing large systems c if (mod(n,10000).ne.0 .and. n.gt.10000) then write (iout,130) n 130 format (' Solvent Atoms Processed',i15) end if c c randomly replace the solvent molecules with ions c do i = 1, ncopy done = .false. do while (.not. done) rand = random () ranatm = int(rand*dble(n)) + 1 c c check solute distance, then delete polyatomic molecule c if (.not. remove(molcule(ranatm))) then start = imol(1,molcule(ranatm)) stop = imol(2,molcule(ranatm)) if (start .eq. stop) then done = .false. else done = .true. xmid = 0.0d0 ymid = 0.0d0 zmid = 0.0d0 do k = stop, start, -1 weigh = mass(k) xmid = xmid + x(k)*weigh ymid = ymid + y(k)*weigh zmid = zmid + z(k)*weigh call delete (k) end do weigh = molmass(molcule(ranatm)) xion(i) = xmid / weigh yion(i) = ymid / weigh zion(i) = zmid / weigh end if end if end do end do c c insert new monoatomic ions at saved centers of mass c do i = 1, ncopy n = n + 1 name(n) = symbol(iontyp) x(n) = xion(i) y(n) = yion(i) z(n) = zion(i) type(n) = iontyp n12(n) = 0 end do c c perform deallocation of some local arrays c deallocate (remove) deallocate (xion) deallocate (yion) deallocate (zion) return end c c c ################################################### c ## COPYRIGHT (C) 1990 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################# c ## ## c ## program xyzint -- Cartesian to internal coordinates ## c ## ## c ############################################################# c c c "xyzint" takes as input a Cartesian coordinates file, then c converts to and writes out an internal coordinates file c c program xyzint use files use iounit use titles implicit none integer izmt,mode integer next,freeunit logical exist character*1 answer character*240 intfile character*240 record c c c get and read the Cartesian coordinates file c call initial call getxyz write (iout,10) title(1:ltitle) 10 format (/,' Title : ',a) c c set the mode for conversion to internal coordinates c call nextarg (answer,exist) if (.not. exist) then write (iout,20) 20 format (/,' Template (T), Dihedrals (D), Manual (M)', & ' or Automatic [A] : ',$) read (input,30) record 30 format (a240) next = 1 call gettext (record,answer,next) end if call upcase (answer) mode = 0 if (answer .eq. 'M') then mode = 1 else if (answer .eq. 'T') then mode = 2 intfile = filename(1:leng)//'.int' call version (intfile,'old') inquire (file=intfile,exist=exist) if (exist) then izmt = freeunit () open (unit=izmt,file=intfile,status='old') rewind (unit=izmt) call readint (izmt) close (unit=izmt) else mode = 0 write (iout,40) 40 format (/,' XYZINT -- Warning, Template File was', & ' not Found') end if else if (answer .eq. 'D') then mode = 3 end if c c convert from Cartesian to internal coordinates c call makeint (mode) c c write out the internal coordinates file c izmt = freeunit () intfile = filename(1:leng)//'.int' call version (intfile,'new') open (unit=izmt,file=intfile,status='new') call prtint (izmt) close (unit=izmt) c c perform any final tasks before program exit c call final end c c c ################################################### c ## COPYRIGHT (C) 1991 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ################################################################# c ## ## c ## program xyzmol2 -- Cartesian coordinates to Tripos MOL2 ## c ## ## c ################################################################# c c c "xyzmol2" takes as input a Cartesian coordinates file, c converts to and then writes out a Tripos MOL2 file c c program xyzmol2 use files use iounit use titles implicit none integer imol2,freeunit character*240 mol2file c c c get and read the Cartesian coordinates file c call initial call getxyz write (iout,10) title(1:ltitle) 10 format (' Title : ',a) c c find the connectivity and rings in the structure c call attach call bonds call angles call torsions call bitors call rings c c open a new version of the Tripos MOL2 file c imol2 = freeunit () mol2file = filename(1:leng)//'.mol2' call version (mol2file,'new') open (unit=imol2,file=mol2file,status='new') c c output the coordinates into Tripos MOL2 format c call prtmol2 (imol2) close (unit=imol2) 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 xyzpdb -- Cartesian to Protein Data Bank file ## c ## ## c ############################################################### c c c "xyzpdb" takes as input a Cartesian coordinates file, c then converts to and writes out a Protein Data Bank file c c program xyzpdb use files use inform implicit none integer i,ipdb,ixyz integer freeunit logical multi character*7 fstr character*240 pdbfile character*240 xyzfile c c c get the Cartesian coordinates file for the system c call initial call getxyz c c get atomic number of each atom and count the molecules c call attach call field call katom call molecule c c check for multiple coordinate sets and get first structure c ixyz = freeunit () xyzfile = filename call suffix (xyzfile,'xyz','old') open (unit=ixyz,file=xyzfile,status ='old') rewind (unit=ixyz) call readxyz (ixyz) call readxyz (ixyz) multi = .true. if (abort) multi = .false. rewind (unit=ixyz) call readxyz (ixyz) c c open the Protein Data Bank file to be used for output c ipdb = freeunit () pdbfile = filename(1:leng)//'.pdb' call version (pdbfile,'new') open (unit=ipdb,file=pdbfile,status='new') c c add each successive coordinate frame to the PDB file c i = 0 do while (.not. abort) if (multi) i = i + 1 call makepdb call prtpdb (ipdb,i) call readxyz (ixyz) end do c c append termination record to the end of the PDB file c fstr = '(''END'')' write (ipdb,fstr(1:7)) c c perform any final tasks before program exit c close (unit=ixyz) close (unit=ipdb) call final end c c c ############################################################### c ## ## c ## subroutine makepdb -- build PDB from Cartesian coords ## c ## ## c ############################################################### c c c "makepdb" cconstructs a Protein Data Bank file from a set c of Cartesian coordinates with special handling for systems c consisting of biopolymer chains, ligands and water molecules c c subroutine makepdb use atomid use atoms use couple use files use molcul use pdb use resdue use sequen implicit none integer i,j,k,m,ii integer kp,ka,kn integer iseq,freeunit integer start,stop integer pdbnum,atmnum integer justify,cbi integer noxy,nhydro integer, allocatable :: ni(:) integer, allocatable :: cai(:) integer, allocatable :: ci(:) integer, allocatable :: oi(:) integer, allocatable :: poi(:) integer, allocatable :: op1(:) integer, allocatable :: op2(:) integer, allocatable :: op3(:) integer, allocatable :: c5i(:) integer, allocatable :: o5i(:) integer, allocatable :: c4i(:) integer, allocatable :: o4i(:) integer, allocatable :: c3i(:) integer, allocatable :: o3i(:) integer, allocatable :: c2i(:) integer, allocatable :: o2i(:) integer, allocatable :: c1i(:) logical exist,generic logical cbone,nbone,obone logical first logical, allocatable :: water(:) logical, allocatable :: hetmol(:) character*3 resname character*4 atmname character*7, allocatable :: restyp(:) character*240 seqfile save first data first / .true. / c c c perform dynamic allocation of some global arrays c if (first) then first = .false. if (.not. allocated(resnum)) allocate (resnum(maxatm)) if (.not. allocated(resatm)) allocate (resatm(2,maxatm)) if (.not. allocated(npdb12)) allocate (npdb12(maxatm)) if (.not. allocated(ipdb12)) allocate (ipdb12(maxval,maxatm)) if (.not. allocated(pdblist)) allocate (pdblist(maxatm)) if (.not. allocated(xpdb)) allocate (xpdb(maxatm)) if (.not. allocated(ypdb)) allocate (ypdb(maxatm)) if (.not. allocated(zpdb)) allocate (zpdb(maxatm)) if (.not. allocated(pdbres)) allocate (pdbres(maxatm)) if (.not. allocated(pdbatm)) allocate (pdbatm(maxatm)) if (.not. allocated(pdbtyp)) allocate (pdbtyp(maxatm)) end if c c initialize number of PDB atoms and atom mapping c npdb = 0 do i = 1, n pdblist(i) = 0 end do c c read the biopolymer sequence file if one exists c iseq = freeunit () seqfile = filename(1:leng)//'.seq' call version (seqfile,'old') inquire (file=seqfile,exist=exist) if (exist) then open (unit=iseq,file=seqfile,status='old') rewind (unit=iseq) call readseq (iseq) close (unit=iseq) end if c c check for the existence of a generic sequence file c if (.not. exist) then if (ldir .eq. 0) then seqfile = 'tinker.seq' else seqfile = filename(1:ldir)//'tinker.seq' end if call version (seqfile,'old') inquire (file=seqfile,exist=exist) if (exist) then open (unit=iseq,file=seqfile,status='old') rewind (unit=iseq) call readseq (iseq) close (unit=iseq) end if end if c c perform dynamic allocation of some local arrays c allocate (ni(maxres)) allocate (cai(maxres)) allocate (ci(maxres)) allocate (oi(maxres)) allocate (poi(maxres)) allocate (op1(maxres)) allocate (op2(maxres)) allocate (op3(maxres)) allocate (c5i(maxres)) allocate (o5i(maxres)) allocate (c4i(maxres)) allocate (o4i(maxres)) allocate (c3i(maxres)) allocate (o3i(maxres)) allocate (c2i(maxres)) allocate (o2i(maxres)) allocate (c1i(maxres)) allocate (restyp(maxres)) c c zero out the backbone atoms for biopolymer sequences c do i = 1, nseq ni(i) = 0 cai(i) = 0 ci(i) = 0 oi(i) = 0 poi(i) = 0 op1(i) = 0 op2(i) = 0 op3(i) = 0 c5i(i) = 0 o5i(i) = 0 c4i(i) = 0 o4i(i) = 0 c3i(i) = 0 o3i(i) = 0 c2i(i) = 0 o2i(i) = 0 c1i(i) = 0 end do c c set the molecule type for each residue via chain type c generic = .true. do i = 1, nchain do j = ichain(1,i), ichain(2,i) restyp(j) = 'GENERIC' if (chntyp(i) .eq. 'PEPTIDE') restyp(j) = 'PEPTIDE' if (chntyp(i) .eq. 'NUCLEIC') restyp(j) = 'NUCLEIC' end do if (restyp(j) .ne. 'GENERIC') generic = .false. end do c c perform dynamic allocation of some local arrays c allocate (water(nmol)) c c check each molecule to see if it is a water molecule c do i = 1, nmol water(i) = .false. if (imol(2,i)-imol(1,i) .eq. 2) then noxy = 0 nhydro = 0 do j = imol(1,i), imol(2,i) k = kmol(j) if (atomic(k) .eq. 8) noxy = noxy + 1 if (atomic(k) .eq. 1) nhydro = nhydro + 1 end do if (noxy.eq.1 .and. nhydro.eq.2) water(i) = .true. end if end do c c for general structures, transfer each atom to PDB format c if (generic) then do i = 1, nmol do j = imol(1,i), imol(2,i) k = kmol(j) atmname = ' '//name(k) if (water(i)) then resname = 'HOH' else justify = 0 call numeral (type(k),resname,justify) end if pdbnum = i call pdbatom (atmname,resname,pdbnum,k) pdbtyp(npdb) = 'HETATM' end do end do do i = 1, nmol do j = imol(1,i), imol(2,i) k = kmol(j) kp = pdblist(k) npdb12(kp) = n12(k) do m = 1, n12(k) ipdb12(m,kp) = pdblist(i12(m,k)) end do end do end do end if c c find the amide nitrogens and other peptide backbone atoms c m = 1 do i = 1, n if (restyp(m) .eq. 'PEPTIDE') then resname = amino(seqtyp(m)) if (resname .eq. 'H2N') then m = m + 1 resname = amino(seqtyp(m)) if (atomic(i) .eq. 7) then obone = .false. do j = 1, n14(i) k = i14(j,i) if (atomic(k) .eq. 8) then obone = .true. end if end do if (obone) then ni(m) = i cai(m) = i + 1 ci(m) = i + 2 oi(m) = i + 3 m = m + 1 end if end if else if (resname .eq. 'FOR') then if (atomic(i) .eq. 6) then nbone = .false. obone = .false. do j = 1, n12(i) k = i12(j,i) if (atomic(k) .eq. 7) then nbone = .true. else if (atomic(k) .eq. 8) then obone = .true. end if end do if (nbone .and. obone) then cai(m) = i ci(m) = i oi(m) = i + 1 m = m + 1 end if end if else if (resname .eq. 'ACE') then if (atomic(i) .eq. 6) then nbone = .false. obone = .false. do j = 1, n13(i) k = i13(j,i) if (atomic(k) .eq. 7) then nbone = .true. else if (atomic(k) .eq. 8) then obone = .true. end if end do if (nbone .and. obone) then cai(m) = i ci(m) = i + 1 oi(m) = i + 2 m = m + 1 end if end if else if (resname .eq. 'COH') then if (n12(i) .gt. 1) then if (atomic(i) .eq. 8) then nbone = .false. obone = .false. do j = 1, n13(i) k = i13(j,i) if (atomic(k) .eq. 8) then obone = .true. end if end do do j = 1, n14(i) k = i14(j,i) if (atomic(k) .eq. 7) then nbone = .true. end if end do if (nbone .and. obone) then ni(m) = i m = m + 1 end if end if end if else if (resname .eq. 'NH2') then if (atomic(i) .eq. 7) then nbone = .false. obone = .false. do j = 1, n13(i) k = i13(j,i) if (atomic(k) .eq. 8) then obone = .true. end if end do do j = 1, n14(i) k = i14(j,i) if (atomic(k) .eq. 7) then nbone = .true. end if end do if (nbone .and. obone) then ni(m) = i m = m + 1 end if end if else if (resname .eq. 'NME') then if (atomic(i) .eq. 7) then nbone = .false. obone = .false. do j = 1, n13(i) k = i13(j,i) if (atomic(k) .eq. 8) then obone = .true. end if end do do j = 1, n14(i) k = i14(j,i) if (atomic(k) .eq. 7) then nbone = .true. end if end do if (nbone .and. obone) then ni(m) = i cai(m) = i + 1 m = m + 1 end if end if else if (atomic(i) .eq. 7) then obone = .false. do j = 1, n14(i) k = i14(j,i) if (atomic(k) .eq. 8) then obone = .true. end if end do if (obone) then ni(m) = i cai(m) = i + 1 ci(m) = i + 2 oi(m) = i + 3 m = m + 1 end if end if end if c c find the phosphates and sugar C1 nucleotide backbone atoms c else if (restyp(m) .eq. 'NUCLEIC') then resname = nuclz(seqtyp(m)) if (resname .eq. ' MP') then if (atomic(i) .eq. 15) then poi(m) = i m = m + 1 end if end if if (atomic(i).eq.6 .and. n12(i).eq.4) then cbone = .false. nbone = .false. obone = .false. do j = 1, n12(i) k = i12(j,i) ka = atomic(k) kn = n12(k) if (ka .eq. 6) cbone = .true. if (ka.eq.7 .and. kn.eq.3) nbone = .true. if (ka.eq.8 .and. kn.eq.2) obone = .true. end do if (cbone .and. nbone .and. obone) then c1i(m) = i m = m + 1 end if end if end if if (m .gt. nseq) goto 10 end do 10 continue c c find the remainder of the nucleotide backbone atoms c do ii = 1, nchain if (chntyp(ii) .eq. 'NUCLEIC') then start = ichain(1,ii) stop = ichain(2,ii) do i = start, stop m = c1i(i) if (m .ne. 0) then do j = 1, n12(m) k = i12(j,m) ka = atomic(k) if (ka .eq. 6) c2i(i) = k if (ka .eq. 7) ni(i) = k if (ka .eq. 8) o4i(i) = k end do m = o4i(i) do j = 1, n12(m) k = i12(j,m) ka = atomic(k) if (ka.eq.6 .and. k.ne.c1i(i)) c4i(i) = k end do m = c2i(i) do j = 1, n12(m) k = i12(j,m) ka = atomic(k) if (ka .eq. 8) o2i(i) = k if (ka.eq.6 .and. k.ne.c1i(i)) c3i(i) = k end do m = c3i(i) do j = 1, n12(m) k = i12(j,m) ka = atomic(k) if (ka .eq. 8) o3i(i) = k end do m = c4i(i) do j = 1, n12(m) k = i12(j,m) ka = atomic(k) if (ka.eq.6 .and. k.ne.c3i(i)) c5i(i) = k end do m = c5i(i) do j = 1, n12(m) k = i12(j,m) ka = atomic(k) if (ka .eq. 8) o5i(i) = k end do m = o5i(i) do j = 1, n12(m) k = i12(j,m) ka = atomic(k) if (ka .eq. 15) poi(i) = k end do end if if (i .gt. 1) then resname = nuclz(seqtyp(i-1)) if (resname .eq. ' MP') poi(i) = 0 if (resname .eq. ' DP') poi(i) = 0 if (resname .eq. ' TP') poi(i) = 0 end if m = poi(i) if (m .ne. 0) then do j = 1, n12(m) k = i12(j,m) ka = atomic(k) if (ka.eq.8 .and. n12(k).eq.1) then if (op1(i) .eq. 0) then op1(i) = k else if (op2(i) .eq. 0) then op2(i) = k else op3(i) = k end if end if end do end if end do end if end do c c copy the atoms of each biopolymer residue into PDB format c do m = 1, nchain start = ichain(1,m) stop = ichain(2,m) if (chntyp(m) .eq. 'PEPTIDE') then do i = start, stop resname = amino(seqtyp(i)) if (resname .eq. 'H2N') then continue else if (resname .eq. 'FOR') then call pdbatom (' C ',resname,i,ci(i)) call pdbatom (' O ',resname,i,oi(i)) else if (resname .eq. 'ACE') then call pdbatom (' CH3',resname,i,cai(i)) call pdbatom (' C ',resname,i,ci(i)) call pdbatom (' O ',resname,i,oi(i)) else if (resname .eq. 'COH') then call pdbatom (' OH ',resname,i,ni(i)) else if (resname .eq. 'NH2') then call pdbatom (' N ',resname,i,ni(i)) else if (resname .eq. 'NME') then call pdbatom (' N ',resname,i,ni(i)) call pdbatom (' CH3',resname,i,cai(i)) else call pdbatom (' N ',resname,i,ni(i)) call pdbatom (' CA ',resname,i,cai(i)) call pdbatom (' C ',resname,i,ci(i)) call pdbatom (' O ',resname,i,oi(i)) end if call getside (resname,i,ci(i),cai(i),cbi) if ((resname.eq.'CYS'.or.resname.eq.'CYX') & .and. cbi.ne.0) then resname = 'CYS' do j = 1, n13(cbi) if (atomic(i13(j,cbi)) .eq. 16) resname = 'CYX' end do end if if (i.eq.stop .and. ci(i).ne.0) then do j = 1, n12(ci(i)) k = i12(j,ci(i)) if (atomic(k).eq.8 .and. k.ne.oi(i)) then call pdbatom (' OXT',resname,i,k) goto 20 end if end do 20 continue end if call getproh (resname,i,m,ni(i),cai(i),cbi) end do else if (chntyp(m) .eq. 'NUCLEIC') then do i = start, stop resname = nuclz(seqtyp(i)) if (resname .eq. ' MP') then call pdbatom (' P ',resname,i,poi(i)) call pdbatom (' OP1',resname,i,op1(i)) call pdbatom (' OP2',resname,i,op2(i)) call pdbatom (' OP3',resname,i,op3(i)) else if (resname .eq. ' DP') then else if (resname .eq. ' TP') then else call pdbatom (' P ',resname,i,poi(i)) call pdbatom (' OP1',resname,i,op1(i)) call pdbatom (' OP2',resname,i,op2(i)) call pdbatom (' O5''',resname,i,o5i(i)) call pdbatom (' C5''',resname,i,c5i(i)) call pdbatom (' C4''',resname,i,c4i(i)) call pdbatom (' O4''',resname,i,o4i(i)) call pdbatom (' C3''',resname,i,c3i(i)) call pdbatom (' O3''',resname,i,o3i(i)) call pdbatom (' C2''',resname,i,c2i(i)) call pdbatom (' O2''',resname,i,o2i(i)) call pdbatom (' C1''',resname,i,c1i(i)) call getbase (resname,i,ni(i)) call getnuch (resname,i,ni(i),c1i(i),c2i(i),o2i(i), & c3i(i),o3i(i),c4i(i),c5i(i),o5i(i)) end if end do end if end do c c perform deallocation of some local arrays c deallocate (ni) deallocate (cai) deallocate (ci) deallocate (oi) deallocate (poi) deallocate (op1) deallocate (op2) deallocate (op3) deallocate (c5i) deallocate (o5i) deallocate (c4i) deallocate (o4i) deallocate (c3i) deallocate (o3i) deallocate (c2i) deallocate (o2i) deallocate (c1i) deallocate (restyp) c c perform dynamic allocation of some local arrays c allocate (hetmol(nmol)) c c copy any water, ions or ligands following biopolymer chains c if (.not. generic) then do i = 1, nmol hetmol(i) = .true. end do do i = 1, n if (pdblist(i) .ne. 0) hetmol(molcule(i)) = .false. end do do i = 1, nmol if (hetmol(i)) then do j = imol(1,i), imol(2,i) k = kmol(j) atmnum = atomic(k) atmname = ' '//name(k) justify = 0 call numeral (type(k),resname,justify) if (water(i)) then if (atmnum .eq. 1) atmname = ' H ' if (atmnum .eq. 8) atmname = ' O ' resname = 'HOH' else if (atmnum .eq. 11) then atmname = 'NA ' resname = ' NA' else if (atmnum .eq. 12) then atmname = 'MG ' resname = ' MG' else if (atmnum .eq. 17) then atmname = 'CL ' resname = ' CL' else if (atmnum .eq. 19) then atmname = ' K ' resname = ' K' else if (atmnum .eq. 20) then atmname = 'CA ' resname = ' CA' else if (atmnum .eq. 35) then atmname = 'BR ' resname = ' BR' else if (atmnum .eq. 53) then atmname = ' I ' resname = ' I' end if pdbnum = nseq + i - 1 call pdbatom (atmname,resname,pdbnum,k) pdbtyp(npdb) = 'HETATM' end do end if end do do i = 1, nmol if (hetmol(i)) then do j = imol(1,i), imol(2,i) k = kmol(j) kp = pdblist(k) npdb12(kp) = n12(k) do m = 1, n12(k) ipdb12(m,kp) = pdblist(i12(m,k)) end do end do end if end do end if c c perform deallocation of some local arrays c deallocate (water) deallocate (hetmol) return end c c c ############################################################# c ## ## c ## subroutine pdbatom -- add a single atom to PDB file ## c ## ## c ############################################################# c c c "pdbatom" adds an atom to the Protein Data Bank file c c subroutine pdbatom (atmname,resname,ires,icoord) use atoms use pdb implicit none integer ires,icoord character*3 resname character*4 atmname c c c for each atom set the sequential number, record type, atom c name, residue name, residue number and atomic coordinates c if (icoord .ne. 0) then npdb = npdb + 1 pdbtyp(npdb) = 'ATOM ' pdbatm(npdb) = atmname pdbres(npdb) = resname resnum(npdb) = ires xpdb(npdb) = x(icoord) ypdb(npdb) = y(icoord) zpdb(npdb) = z(icoord) npdb12(npdb) = 0 pdblist(icoord) = npdb end if return end c c c ################################################################## c ## ## c ## subroutine getside -- extract the amino acid side chains ## c ## ## c ################################################################## c c c "getside" finds the side chain heavy atoms for a single amino c acid residue and copies the names and coordinates to the Protein c Data Bank file c c subroutine getside (resname,ires,ci,cai,cbi) use atomid use atoms use couple implicit none integer i,j,ires integer ci,cai,cbi character*3 resname c c c if residue is a terminal cap, there is no side chain c cbi = 0 if (resname .eq. 'H2N') return if (resname .eq. 'FOR') return if (resname .eq. 'ACE') return if (resname .eq. 'COH') return if (resname .eq. 'NH2') return if (resname .eq. 'NME') return c c find the beta carbon atom for the current residue c do i = 1, n if (i.ne.ci .and. atomic(i).eq.6) then do j = 1, 4 if (i12(j,i) .eq. cai) then cbi = i if (resname .ne. 'AIB') then call pdbatom (' CB ',resname,ires,cbi) else call pdbatom (' CB1',resname,ires,cbi) end if goto 10 end if end do end if end do 10 continue if (cbi .eq. 0) return c c glycine residue (GLY) c if (resname .eq. 'GLY') then continue c c alanine residue (ALA) c else if (resname .eq. 'ALA') then continue c c valine residue (VAL) c else if (resname .eq. 'VAL') then call pdbatom (' CG1',resname,ires,cbi+1) call pdbatom (' CG2',resname,ires,cbi+2) c c leucine residue (LEU) c else if (resname .eq. 'LEU') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD1',resname,ires,cbi+2) call pdbatom (' CD2',resname,ires,cbi+3) c c isoleucine residue (ILE) c else if (resname .eq. 'ILE') then call pdbatom (' CG1',resname,ires,cbi+1) call pdbatom (' CG2',resname,ires,cbi+2) call pdbatom (' CD1',resname,ires,cbi+3) c c serine residue (SER) c else if (resname .eq. 'SER') then call pdbatom (' OG ',resname,ires,cbi+1) c c threonine residue (THR) c else if (resname .eq. 'THR') then call pdbatom (' OG1',resname,ires,cbi+1) call pdbatom (' CG2',resname,ires,cbi+2) c c cysteine residue (CYS) c else if (resname .eq. 'CYS') then call pdbatom (' SG ',resname,ires,cbi+1) c c cysteine residue (CYX) c else if (resname .eq. 'CYX') then call pdbatom (' SG ',resname,ires,cbi+1) c c deprotonated cysteine residue (CYD) c else if (resname .eq. 'CYD') then call pdbatom (' SG ',resname,ires,cbi+1) c c proline residue (PRO) c else if (resname .eq. 'PRO') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD ',resname,ires,cbi+2) c c phenylalanine residue (PHE) c else if (resname .eq. 'PHE') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD1',resname,ires,cbi+2) call pdbatom (' CD2',resname,ires,cbi+3) call pdbatom (' CE1',resname,ires,cbi+4) call pdbatom (' CE2',resname,ires,cbi+5) call pdbatom (' CZ ',resname,ires,cbi+6) c c tyrosine residue (TYR) c else if (resname .eq. 'TYR') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD1',resname,ires,cbi+2) call pdbatom (' CD2',resname,ires,cbi+3) call pdbatom (' CE1',resname,ires,cbi+4) call pdbatom (' CE2',resname,ires,cbi+5) call pdbatom (' CZ ',resname,ires,cbi+6) call pdbatom (' OH ',resname,ires,cbi+7) c c deprotonated tyrosine residue (TYD) c else if (resname .eq. 'TYD') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD1',resname,ires,cbi+2) call pdbatom (' CD2',resname,ires,cbi+3) call pdbatom (' CE1',resname,ires,cbi+4) call pdbatom (' CE2',resname,ires,cbi+5) call pdbatom (' CZ ',resname,ires,cbi+6) call pdbatom (' OH ',resname,ires,cbi+7) c c tryptophan residue (TRP) c else if (resname .eq. 'TRP') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD1',resname,ires,cbi+2) call pdbatom (' CD2',resname,ires,cbi+3) call pdbatom (' NE1',resname,ires,cbi+4) call pdbatom (' CE2',resname,ires,cbi+5) call pdbatom (' CE3',resname,ires,cbi+6) call pdbatom (' CZ2',resname,ires,cbi+7) call pdbatom (' CZ3',resname,ires,cbi+8) call pdbatom (' CH2',resname,ires,cbi+9) c c histidine (HD and HE) residue (HIS) c else if (resname .eq. 'HIS') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' ND1',resname,ires,cbi+2) call pdbatom (' CD2',resname,ires,cbi+3) call pdbatom (' CE1',resname,ires,cbi+4) call pdbatom (' NE2',resname,ires,cbi+5) c c histidine (HD only) residue (HID) c else if (resname .eq. 'HID') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' ND1',resname,ires,cbi+2) call pdbatom (' CD2',resname,ires,cbi+3) call pdbatom (' CE1',resname,ires,cbi+4) call pdbatom (' NE2',resname,ires,cbi+5) c c histidine (HE only) residue (HIE) c else if (resname .eq. 'HIE') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' ND1',resname,ires,cbi+2) call pdbatom (' CD2',resname,ires,cbi+3) call pdbatom (' CE1',resname,ires,cbi+4) call pdbatom (' NE2',resname,ires,cbi+5) c c aspartic acid residue (ASP) c else if (resname .eq. 'ASP') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' OD1',resname,ires,cbi+2) call pdbatom (' OD2',resname,ires,cbi+3) c c protonated aspartic acid residue (ASH) c else if (resname .eq. 'ASH') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' OD1',resname,ires,cbi+2) call pdbatom (' OD2',resname,ires,cbi+3) c c asparagine residue (ASN) c else if (resname .eq. 'ASN') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' OD1',resname,ires,cbi+2) call pdbatom (' ND2',resname,ires,cbi+3) c c glutamic acid residue (GLU) c else if (resname .eq. 'GLU') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD ',resname,ires,cbi+2) call pdbatom (' OE1',resname,ires,cbi+3) call pdbatom (' OE2',resname,ires,cbi+4) c c protonated glutamic acid residue (GLH) c else if (resname .eq. 'GLH') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD ',resname,ires,cbi+2) call pdbatom (' OE1',resname,ires,cbi+3) call pdbatom (' OE2',resname,ires,cbi+4) c c glutamine residue (GLN) c else if (resname .eq. 'GLN') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD ',resname,ires,cbi+2) call pdbatom (' OE1',resname,ires,cbi+3) call pdbatom (' NE2',resname,ires,cbi+4) c c methionine residue (MET) c else if (resname .eq. 'MET') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' SD ',resname,ires,cbi+2) call pdbatom (' CE ',resname,ires,cbi+3) c c lysine residue (LYS) c else if (resname .eq. 'LYS') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD ',resname,ires,cbi+2) call pdbatom (' CE ',resname,ires,cbi+3) call pdbatom (' NZ ',resname,ires,cbi+4) c c deprotonated lysine residue (LYD) c else if (resname .eq. 'LYD') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD ',resname,ires,cbi+2) call pdbatom (' CE ',resname,ires,cbi+3) call pdbatom (' NZ ',resname,ires,cbi+4) c c arginine residue (ARG) c else if (resname .eq. 'ARG') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD ',resname,ires,cbi+2) call pdbatom (' NE ',resname,ires,cbi+3) call pdbatom (' CZ ',resname,ires,cbi+4) call pdbatom (' NH1',resname,ires,cbi+5) call pdbatom (' NH2',resname,ires,cbi+6) c c ornithine residue (ORN) c else if (resname .eq. 'ORN') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD ',resname,ires,cbi+2) call pdbatom (' NE ',resname,ires,cbi+3) c c methylalanine residue (AIB) c else if (resname .eq. 'AIB') then call pdbatom (' CB2',resname,ires,cbi+1) c c pyroglutamic acid residue (PCA) c else if (resname .eq. 'PCA') then call pdbatom (' CG ',resname,ires,cbi+1) call pdbatom (' CD ',resname,ires,cbi+2) call pdbatom (' OE ',resname,ires,cbi+3) c c unknown residue (UNK) c else if (resname .eq. 'UNK') then continue end if return end c c c ################################################################ c ## ## c ## subroutine getproh -- extract the amino acid hydrogens ## c ## ## c ################################################################ c c c "getproh" finds the hydrogen atoms for a single amino acid c residue and copies the names and coordinates to the Protein c Data Bank file c c subroutine getproh (resname,ires,jchain,ni,cai,cbi) use atomid use atoms use couple use fields use sequen implicit none integer i,nh,hca integer ires,jchain integer ni,cai,cbi logical allatom character*3 resname character*4 atmname c c c get any amide hydrogen atoms for non-N-terminal residues c if (ires.ne.ichain(1,jchain) .or. n12(ni).ne.4) then if (resname .ne. 'PRO') then do i = 1, n if (atomic(i).eq.1 .and. i12(1,i).eq.ni) then if (resname .eq. 'COH') then call pdbatom (' HO ',resname,ires,i) else if (resname .eq. 'NH2') then call pdbatom (' H1 ',resname,ires,i) call pdbatom (' H2 ',resname,ires,i+1) else call pdbatom (' H ',resname,ires,i) end if goto 10 end if end do end if c c get any amide hydrogen atoms for N-terminal residues c else if (resname .eq. 'PRO') then nh = 0 do i = 1, n if (atomic(i).eq.1 .and. i12(1,i).eq.ni) then nh = nh + 1 if (nh .eq. 1) then atmname = ' H1 ' else if (nh .eq. 2) then atmname = ' H2 ' end if call pdbatom (atmname,resname,ires,i) if (nh .eq. 2) goto 10 end if end do else if (resname .eq. 'PCA') then do i = 1, n if (atomic(i).eq.1 .and. i12(1,i).eq.ni) then atmname = ' H ' call pdbatom (atmname,resname,ires,i) goto 10 end if end do else nh = 0 do i = 1, n if (atomic(i).eq.1 .and. i12(1,i).eq.ni) then nh = nh + 1 if (nh .eq. 1) then atmname = ' H1 ' else if (nh .eq. 2) then atmname = ' H2 ' else if (nh .eq. 3) then atmname = ' H3 ' end if call pdbatom (atmname,resname,ires,i) if (nh .eq. 3) goto 10 end if end do end if end if 10 continue c c get the alpha hydrogen atom for the current residue c hca = 0 do i = 1, n if (atomic(i).eq.1 .and. i12(1,i).eq.cai) then hca = i if (resname .eq. 'GLY') then atmname = ' HA2' else if (resname .eq. 'FOR') then atmname = ' H ' else if (resname .eq. 'ACE') then atmname = ' H1 ' else if (resname .eq. 'NME') then atmname = ' H1 ' else atmname = ' HA ' end if call pdbatom (atmname,resname,ires,i) goto 20 end if end do 20 continue c c backbone only if no alpha hydrogen or beta carbon c if (hca.eq.0 .and. cbi.eq.0) return c c if no alpha hydrogen, then united atom force field c if (hca .ne. 0) then allatom = .true. else if (resname .eq. 'AIB') then if (n12(cbi) .eq. 1) then allatom = .false. else allatom = .true. end if else allatom = .false. end if c c glycine residue (GLY) c if (resname .eq. 'GLY') then if (allatom) then call pdbatom (' HA3',resname,ires,hca+1) end if c c alanine residue (ALA) c else if (resname .eq. 'ALA') then if (allatom) then call pdbatom (' HB1',resname,ires,hca+2) call pdbatom (' HB2',resname,ires,hca+3) call pdbatom (' HB3',resname,ires,hca+4) end if c c valine residue (VAL) c else if (resname .eq. 'VAL') then if (allatom) then call pdbatom (' HB ',resname,ires,hca+4) call pdbatom ('HG11',resname,ires,hca+5) call pdbatom ('HG12',resname,ires,hca+6) call pdbatom ('HG13',resname,ires,hca+7) call pdbatom ('HG21',resname,ires,hca+8) call pdbatom ('HG22',resname,ires,hca+9) call pdbatom ('HG23',resname,ires,hca+10) end if c c leucine residue (LEU) c else if (resname .eq. 'LEU') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+5) call pdbatom (' HB3',resname,ires,hca+6) call pdbatom (' HG ',resname,ires,hca+7) call pdbatom ('HD11',resname,ires,hca+8) call pdbatom ('HD12',resname,ires,hca+9) call pdbatom ('HD13',resname,ires,hca+10) call pdbatom ('HD21',resname,ires,hca+11) call pdbatom ('HD22',resname,ires,hca+12) call pdbatom ('HD23',resname,ires,hca+13) end if c c isoleucine residue (ILE) c else if (resname .eq. 'ILE') then if (allatom) then call pdbatom (' HB ',resname,ires,hca+5) call pdbatom ('HG12',resname,ires,hca+6) call pdbatom ('HG13',resname,ires,hca+7) call pdbatom ('HG21',resname,ires,hca+8) call pdbatom ('HG22',resname,ires,hca+9) call pdbatom ('HG23',resname,ires,hca+10) call pdbatom ('HD11',resname,ires,hca+11) call pdbatom ('HD12',resname,ires,hca+12) call pdbatom ('HD13',resname,ires,hca+13) end if c c serine residue (SER) c else if (resname .eq. 'SER') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+3) call pdbatom (' HB3',resname,ires,hca+4) call pdbatom (' HG ',resname,ires,hca+5) else call pdbatom (' HG ',resname,ires,cbi+2) end if c c threonine residue (THR) c else if (resname .eq. 'THR') then if (allatom) then call pdbatom (' HB ',resname,ires,hca+4) call pdbatom (' HG1',resname,ires,hca+5) call pdbatom ('HG21',resname,ires,hca+6) call pdbatom ('HG22',resname,ires,hca+7) call pdbatom ('HG23',resname,ires,hca+8) else call pdbatom (' HG1',resname,ires,cbi+3) end if c c cysteine residue (CYS) c else if (resname .eq. 'CYS') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+3) call pdbatom (' HB3',resname,ires,hca+4) call pdbatom (' HG ',resname,ires,hca+5) else if (biotyp(86) .ne. 0) then call pdbatom (' HG ',resname,ires,cbi+2) end if c c cystine residue (CYX) c else if (resname .eq. 'CYX') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+3) call pdbatom (' HB3',resname,ires,hca+4) end if c c deprotonated cysteine residue (CYD) c else if (resname .eq. 'CYD') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+3) call pdbatom (' HB3',resname,ires,hca+4) end if c c proline residue (PRO) c else if (resname .eq. 'PRO') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+4) call pdbatom (' HB3',resname,ires,hca+5) call pdbatom (' HG2',resname,ires,hca+6) call pdbatom (' HG3',resname,ires,hca+7) call pdbatom (' HD2',resname,ires,hca+8) call pdbatom (' HD3',resname,ires,hca+9) end if c c phenylalanine residue (PHE) c else if (resname .eq. 'PHE') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+8) call pdbatom (' HB3',resname,ires,hca+9) call pdbatom (' HD1',resname,ires,hca+10) call pdbatom (' HD2',resname,ires,hca+11) call pdbatom (' HE1',resname,ires,hca+12) call pdbatom (' HE2',resname,ires,hca+13) call pdbatom (' HZ ',resname,ires,hca+14) else if (biotyp(126) .ne. 0) then call pdbatom (' HD1',resname,ires,cbi+7) call pdbatom (' HD2',resname,ires,cbi+8) call pdbatom (' HE1',resname,ires,cbi+9) call pdbatom (' HE2',resname,ires,cbi+10) call pdbatom (' HZ ',resname,ires,cbi+11) end if c c tyrosine residue (TYR) c else if (resname .eq. 'TYR') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+9) call pdbatom (' HB3',resname,ires,hca+10) call pdbatom (' HD1',resname,ires,hca+11) call pdbatom (' HD2',resname,ires,hca+12) call pdbatom (' HE1',resname,ires,hca+13) call pdbatom (' HE2',resname,ires,hca+14) call pdbatom (' HH ',resname,ires,hca+15) else if (biotyp(141) .ne. 0) then call pdbatom (' HD1',resname,ires,cbi+8) call pdbatom (' HD2',resname,ires,cbi+9) call pdbatom (' HE1',resname,ires,cbi+10) call pdbatom (' HE2',resname,ires,cbi+11) call pdbatom (' HH ',resname,ires,cbi+12) else call pdbatom (' HH ',resname,ires,cbi+8) end if c c deprotonated tyrosine residue (TYD) c else if (resname .eq. 'TYD') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+9) call pdbatom (' HB3',resname,ires,hca+10) call pdbatom (' HD1',resname,ires,hca+11) call pdbatom (' HD2',resname,ires,hca+12) call pdbatom (' HE1',resname,ires,hca+13) call pdbatom (' HE2',resname,ires,hca+14) else if (biotyp(141) .ne. 0) then call pdbatom (' HD1',resname,ires,cbi+8) call pdbatom (' HD2',resname,ires,cbi+9) call pdbatom (' HE1',resname,ires,cbi+10) call pdbatom (' HE2',resname,ires,cbi+11) end if c c tryptophan residue (TRP) c else if (resname .eq. 'TRP') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+11) call pdbatom (' HB3',resname,ires,hca+12) call pdbatom (' HD1',resname,ires,hca+13) call pdbatom (' HE1',resname,ires,hca+14) call pdbatom (' HE3',resname,ires,hca+15) call pdbatom (' HZ2',resname,ires,hca+16) call pdbatom (' HZ3',resname,ires,hca+17) call pdbatom (' HH2',resname,ires,hca+18) else if (biotyp(172) .ne. 0) then call pdbatom (' HD1',resname,ires,cbi+10) call pdbatom (' HE1',resname,ires,cbi+11) call pdbatom (' HE3',resname,ires,cbi+12) call pdbatom (' HZ2',resname,ires,cbi+13) call pdbatom (' HZ3',resname,ires,cbi+14) call pdbatom (' HH2',resname,ires,cbi+15) else call pdbatom (' HE1',resname,ires,cbi+10) end if c c histidine (HD and HE) residue (HIS) c else if (resname .eq. 'HIS') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+7) call pdbatom (' HB3',resname,ires,hca+8) call pdbatom (' HD1',resname,ires,hca+9) call pdbatom (' HD2',resname,ires,hca+10) call pdbatom (' HE1',resname,ires,hca+11) call pdbatom (' HE2',resname,ires,hca+12) else if (biotyp(197) .ne. 0) then call pdbatom (' HD1',resname,ires,cbi+6) call pdbatom (' HD2',resname,ires,cbi+7) call pdbatom (' HE1',resname,ires,cbi+8) call pdbatom (' HE2',resname,ires,cbi+9) else call pdbatom (' HD1',resname,ires,cbi+6) call pdbatom (' HE2',resname,ires,cbi+7) end if c c histidine (HD only) residue (HID) c else if (resname .eq. 'HID') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+7) call pdbatom (' HB3',resname,ires,hca+8) call pdbatom (' HD1',resname,ires,hca+9) call pdbatom (' HD2',resname,ires,hca+10) call pdbatom (' HE1',resname,ires,hca+11) else if (biotyp(214) .ne. 0) then call pdbatom (' HD1',resname,ires,cbi+6) call pdbatom (' HD2',resname,ires,cbi+7) call pdbatom (' HE1',resname,ires,cbi+8) else call pdbatom (' HD1',resname,ires,cbi+6) end if c c histidine (HE only) residue (HIE) c else if (resname .eq. 'HIE') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+7) call pdbatom (' HB3',resname,ires,hca+8) call pdbatom (' HD2',resname,ires,hca+9) call pdbatom (' HE1',resname,ires,hca+10) call pdbatom (' HE2',resname,ires,hca+11) else if (biotyp(229) .ne. 0) then call pdbatom (' HD2',resname,ires,cbi+6) call pdbatom (' HE1',resname,ires,cbi+7) call pdbatom (' HE2',resname,ires,cbi+8) else call pdbatom (' HE2',resname,ires,cbi+6) end if c c aspartic acid residue (ASP) c else if (resname .eq. 'ASP') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+5) call pdbatom (' HB3',resname,ires,hca+6) end if c c protonated aspartic acid residue (ASH) c else if (resname .eq. 'ASH') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+5) call pdbatom (' HB3',resname,ires,hca+6) call pdbatom (' HD2',resname,ires,hca+7) else call pdbatom (' HD2',resname,ires,cbi+4) end if c c asparagine residue (ASN) c else if (resname .eq. 'ASN') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+5) call pdbatom (' HB3',resname,ires,hca+6) call pdbatom ('HD21',resname,ires,hca+7) call pdbatom ('HD22',resname,ires,hca+8) else call pdbatom ('HD21',resname,ires,cbi+4) call pdbatom ('HD22',resname,ires,cbi+5) end if c c glutamic acid residue (GLU) c else if (resname .eq. 'GLU') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+6) call pdbatom (' HB3',resname,ires,hca+7) call pdbatom (' HG2',resname,ires,hca+8) call pdbatom (' HG3',resname,ires,hca+9) end if c c protonated glutamic acid residue (GLH) c else if (resname .eq. 'GLH') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+6) call pdbatom (' HB3',resname,ires,hca+7) call pdbatom (' HG2',resname,ires,hca+8) call pdbatom (' HG3',resname,ires,hca+9) call pdbatom (' HE2',resname,ires,hca+10) else call pdbatom (' HE2',resname,ires,cbi+5) end if c c glutamine residue (GLN) c else if (resname .eq. 'GLN') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+6) call pdbatom (' HB3',resname,ires,hca+7) call pdbatom (' HG2',resname,ires,hca+8) call pdbatom (' HG3',resname,ires,hca+9) call pdbatom ('HE21',resname,ires,hca+10) call pdbatom ('HE22',resname,ires,hca+11) else call pdbatom ('HE21',resname,ires,cbi+5) call pdbatom ('HE22',resname,ires,cbi+6) end if c c methionine residue (MET) c else if (resname .eq. 'MET') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+5) call pdbatom (' HB3',resname,ires,hca+6) call pdbatom (' HG2',resname,ires,hca+7) call pdbatom (' HG3',resname,ires,hca+8) call pdbatom (' HE1',resname,ires,hca+9) call pdbatom (' HE2',resname,ires,hca+10) call pdbatom (' HE3',resname,ires,hca+11) end if c c lysine residue (LYS) c else if (resname .eq. 'LYS') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+6) call pdbatom (' HB3',resname,ires,hca+7) call pdbatom (' HG2',resname,ires,hca+8) call pdbatom (' HG3',resname,ires,hca+9) call pdbatom (' HD2',resname,ires,hca+10) call pdbatom (' HD3',resname,ires,hca+11) call pdbatom (' HE2',resname,ires,hca+12) call pdbatom (' HE3',resname,ires,hca+13) call pdbatom (' HZ1',resname,ires,hca+14) call pdbatom (' HZ2',resname,ires,hca+15) call pdbatom (' HZ3',resname,ires,hca+16) else call pdbatom (' HZ1',resname,ires,cbi+5) call pdbatom (' HZ2',resname,ires,cbi+6) call pdbatom (' HZ3',resname,ires,cbi+7) end if c c deprotonated lysine residue (LYD) c else if (resname .eq. 'LYD') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+6) call pdbatom (' HB3',resname,ires,hca+7) call pdbatom (' HG2',resname,ires,hca+8) call pdbatom (' HG3',resname,ires,hca+9) call pdbatom (' HD2',resname,ires,hca+10) call pdbatom (' HD3',resname,ires,hca+11) call pdbatom (' HE2',resname,ires,hca+12) call pdbatom (' HE3',resname,ires,hca+13) call pdbatom (' HZ1',resname,ires,hca+14) call pdbatom (' HZ2',resname,ires,hca+15) else call pdbatom (' HZ1',resname,ires,cbi+5) call pdbatom (' HZ2',resname,ires,cbi+6) end if c c arginine residue (ARG) c else if (resname .eq. 'ARG') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+8) call pdbatom (' HB3',resname,ires,hca+9) call pdbatom (' HG2',resname,ires,hca+10) call pdbatom (' HG3',resname,ires,hca+11) call pdbatom (' HD2',resname,ires,hca+12) call pdbatom (' HD3',resname,ires,hca+13) call pdbatom (' HE ',resname,ires,hca+14) call pdbatom ('HH11',resname,ires,hca+15) call pdbatom ('HH12',resname,ires,hca+16) call pdbatom ('HH21',resname,ires,hca+17) call pdbatom ('HH22',resname,ires,hca+18) else call pdbatom (' HE ',resname,ires,cbi+7) call pdbatom ('HH11',resname,ires,cbi+8) call pdbatom ('HH12',resname,ires,cbi+9) call pdbatom ('HH21',resname,ires,cbi+10) call pdbatom ('HH22',resname,ires,cbi+11) end if c c ornithine residue (ORN) c else if (resname .eq. 'ORN') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+5) call pdbatom (' HB3',resname,ires,hca+6) call pdbatom (' HG2',resname,ires,hca+7) call pdbatom (' HG3',resname,ires,hca+8) call pdbatom (' HD2',resname,ires,hca+9) call pdbatom (' HD3',resname,ires,hca+10) call pdbatom (' HE1',resname,ires,hca+11) call pdbatom (' HE2',resname,ires,hca+12) call pdbatom (' HE3',resname,ires,hca+13) else call pdbatom (' HE1',resname,ires,cbi+4) call pdbatom (' HE2',resname,ires,cbi+5) call pdbatom (' HE3',resname,ires,cbi+6) end if c c methylalanine residue (AIB) c else if (resname .eq. 'AIB') then if (allatom) then call pdbatom ('HB11',resname,ires,cbi+2) call pdbatom ('HB12',resname,ires,cbi+3) call pdbatom ('HB13',resname,ires,cbi+4) call pdbatom ('HB21',resname,ires,cbi+5) call pdbatom ('HB22',resname,ires,cbi+6) call pdbatom ('HB23',resname,ires,cbi+7) end if c c pyroglutamic acid residue (PCA) c else if (resname .eq. 'PCA') then if (allatom) then call pdbatom (' HB2',resname,ires,hca+5) call pdbatom (' HB3',resname,ires,hca+6) call pdbatom (' HG2',resname,ires,hca+7) call pdbatom (' HG3',resname,ires,hca+8) end if c c unknown residue (UNK) c else if (resname .eq. 'UNK') then if (allatom) then call pdbatom (' HA3',resname,ires,hca+1) end if c c N-terminal deprotonated residue (H2N) c else if (resname .eq. 'H2N') then continue c c N-terminal formyl residue (FOR) c else if (resname .eq. 'FOR') then continue c c N-terminal acetyl residue (ACE) c else if (resname .eq. 'ACE') then if (allatom) then call pdbatom (' H2 ',resname,ires,hca+1) call pdbatom (' H3 ',resname,ires,hca+2) end if c c C-terminal protonated residue (COH) c else if (resname .eq. 'COH') then continue c c C-terminal amide residue (NH2) c else if (resname .eq. 'NH2') then continue c c C-terminal N-methylamide residue (NME) c else if (resname .eq. 'NME') then if (allatom) then call pdbatom (' H2 ',resname,ires,hca+1) call pdbatom (' H3 ',resname,ires,hca+2) end if end if return end c c c ################################################################## c ## ## c ## subroutine getbase -- extract the nucleotide side chains ## c ## ## c ################################################################## c c c "getbase" finds the base heavy atoms for a single nucleotide c residue and copies the names and coordinates to the Protein c Data Bank file c c subroutine getbase (resname,ires,ni) implicit none integer ires,ni character*3 resname c c c adenine in adenosine residue (A) c if (resname .eq. ' A') then call pdbatom (' N9 ',resname,ires,ni) call pdbatom (' C8 ',resname,ires,ni+1) call pdbatom (' N7 ',resname,ires,ni+2) call pdbatom (' C5 ',resname,ires,ni+3) call pdbatom (' C6 ',resname,ires,ni+4) call pdbatom (' N6 ',resname,ires,ni+5) call pdbatom (' N1 ',resname,ires,ni+6) call pdbatom (' C2 ',resname,ires,ni+7) call pdbatom (' N3 ',resname,ires,ni+8) call pdbatom (' C4 ',resname,ires,ni+9) c c guanine in guanosine residue (G) c else if (resname .eq. ' G') then call pdbatom (' N9 ',resname,ires,ni) call pdbatom (' C8 ',resname,ires,ni+1) call pdbatom (' N7 ',resname,ires,ni+2) call pdbatom (' C5 ',resname,ires,ni+3) call pdbatom (' C6 ',resname,ires,ni+4) call pdbatom (' O6 ',resname,ires,ni+5) call pdbatom (' N1 ',resname,ires,ni+6) call pdbatom (' C2 ',resname,ires,ni+7) call pdbatom (' N2 ',resname,ires,ni+8) call pdbatom (' N3 ',resname,ires,ni+9) call pdbatom (' C4 ',resname,ires,ni+10) c c cytosine in cytidine residue (C) c else if (resname .eq. ' C') then call pdbatom (' N1 ',resname,ires,ni) call pdbatom (' C2 ',resname,ires,ni+1) call pdbatom (' O2 ',resname,ires,ni+2) call pdbatom (' N3 ',resname,ires,ni+3) call pdbatom (' C4 ',resname,ires,ni+4) call pdbatom (' N4 ',resname,ires,ni+5) call pdbatom (' C5 ',resname,ires,ni+6) call pdbatom (' C6 ',resname,ires,ni+7) c c uracil in uridine residue (U) c else if (resname .eq. ' U') then call pdbatom (' N1 ',resname,ires,ni) call pdbatom (' C2 ',resname,ires,ni+1) call pdbatom (' O2 ',resname,ires,ni+2) call pdbatom (' N3 ',resname,ires,ni+3) call pdbatom (' C4 ',resname,ires,ni+4) call pdbatom (' O4 ',resname,ires,ni+5) call pdbatom (' C5 ',resname,ires,ni+6) call pdbatom (' C6 ',resname,ires,ni+7) c c adenine in deoxyadenosine residue (DA) c else if (resname .eq. ' DA') then call pdbatom (' N9 ',resname,ires,ni) call pdbatom (' C8 ',resname,ires,ni+1) call pdbatom (' N7 ',resname,ires,ni+2) call pdbatom (' C5 ',resname,ires,ni+3) call pdbatom (' C6 ',resname,ires,ni+4) call pdbatom (' N6 ',resname,ires,ni+5) call pdbatom (' N1 ',resname,ires,ni+6) call pdbatom (' C2 ',resname,ires,ni+7) call pdbatom (' N3 ',resname,ires,ni+8) call pdbatom (' C4 ',resname,ires,ni+9) c c guanine in deoxyguanosine residue (DG) c else if (resname .eq. ' DG') then call pdbatom (' N9 ',resname,ires,ni) call pdbatom (' C8 ',resname,ires,ni+1) call pdbatom (' N7 ',resname,ires,ni+2) call pdbatom (' C5 ',resname,ires,ni+3) call pdbatom (' C6 ',resname,ires,ni+4) call pdbatom (' O6 ',resname,ires,ni+5) call pdbatom (' N1 ',resname,ires,ni+6) call pdbatom (' C2 ',resname,ires,ni+7) call pdbatom (' N2 ',resname,ires,ni+8) call pdbatom (' N3 ',resname,ires,ni+9) call pdbatom (' C4 ',resname,ires,ni+10) c c cytosine in deoxycytidine residue (DC) c else if (resname .eq. ' DC') then call pdbatom (' N1 ',resname,ires,ni) call pdbatom (' C2 ',resname,ires,ni+1) call pdbatom (' O2 ',resname,ires,ni+2) call pdbatom (' N3 ',resname,ires,ni+3) call pdbatom (' C4 ',resname,ires,ni+4) call pdbatom (' N4 ',resname,ires,ni+5) call pdbatom (' C5 ',resname,ires,ni+6) call pdbatom (' C6 ',resname,ires,ni+7) c c thymine in deoxythymidine residue (DT) c else if (resname .eq. ' DT') then call pdbatom (' N1 ',resname,ires,ni) call pdbatom (' C2 ',resname,ires,ni+1) call pdbatom (' O2 ',resname,ires,ni+2) call pdbatom (' N3 ',resname,ires,ni+3) call pdbatom (' C4 ',resname,ires,ni+4) call pdbatom (' O4 ',resname,ires,ni+5) call pdbatom (' C5 ',resname,ires,ni+6) call pdbatom (' C7 ',resname,ires,ni+7) call pdbatom (' C6 ',resname,ires,ni+8) end if return end c c c ################################################################ c ## ## c ## subroutine getnuch -- extract the nucleotide hydrogens ## c ## ## c ################################################################ c c c "getnuch" finds the nucleotide hydrogen atoms for a single c residue and copies the names and coordinates to the Protein c Data Bank file c c subroutine getnuch (resname,ires,ni,c1i,c2i, & o2i,c3i,o3i,c4i,c5i,o5i) use atomid use couple implicit none integer i,k integer ires,ni integer c1i,c4i integer c2i,o2i integer c3i,o3i integer c5i,o5i logical allatom,done character*3 resname c c c if no ribose C1 hydrogen, then united atom force field c allatom = .true. if (n12(c1i) .ne. 4) allatom = .false. c c get sugar ring hydrogen atoms for the current residue c done = .false. do i = 1, n12(c5i) k = i12(i,c5i) if (atomic(k).eq.1) then if (.not. done) then call pdbatom (' H5''',resname,ires,k) done = .true. else call pdbatom ('H5''''',resname,ires,k) end if end if end do do i = 1, n12(c4i) k = i12(i,c4i) if (atomic(k) .eq. 1) call pdbatom (' H4''',resname,ires,k) end do do i = 1, n12(c3i) k = i12(i,c3i) if (atomic(k) .eq. 1) call pdbatom (' H3''',resname,ires,k) end do done = .false. do i = 1, n12(c2i) k = i12(i,c2i) if (atomic(k) .eq. 1) then if (.not. done) then call pdbatom (' H2''',resname,ires,k) done = .true. else call pdbatom ('H2''''',resname,ires,k) end if end if end do if (o2i .ne. 0) then do i = 1, n12(o2i) k = i12(i,o2i) if (atomic(k) .eq. 1) call pdbatom ('HO2''',resname,ires,k) end do end if do i = 1, n12(c1i) k = i12(i,c1i) if (atomic(k) .eq. 1) call pdbatom (' H1''',resname,ires,k) end do c c adenine in adenosine residue (A) c if (resname .eq. ' A') then if (allatom) then call pdbatom (' H8 ',resname,ires,ni+10) call pdbatom (' H61',resname,ires,ni+11) call pdbatom (' H62',resname,ires,ni+12) call pdbatom (' H2 ',resname,ires,ni+13) else call pdbatom (' H61',resname,ires,ni+10) call pdbatom (' H62',resname,ires,ni+11) end if c c guanine in guanosine residue (G) c else if (resname .eq. ' G') then if (allatom) then call pdbatom (' H8 ',resname,ires,ni+11) call pdbatom (' H1 ',resname,ires,ni+12) call pdbatom (' H21',resname,ires,ni+13) call pdbatom (' H22',resname,ires,ni+14) else call pdbatom (' H1 ',resname,ires,ni+11) call pdbatom (' H21',resname,ires,ni+12) call pdbatom (' H22',resname,ires,ni+13) end if c c cytosine in cytidine residue (C) c else if (resname .eq. ' C') then if (allatom) then call pdbatom (' H41',resname,ires,ni+8) call pdbatom (' H42',resname,ires,ni+9) call pdbatom (' H5 ',resname,ires,ni+10) call pdbatom (' H6 ',resname,ires,ni+11) else call pdbatom (' H41',resname,ires,ni+8) call pdbatom (' H42',resname,ires,ni+9) end if c c uracil in uridine residue (U) c else if (resname .eq. ' U') then if (allatom) then call pdbatom (' H3 ',resname,ires,ni+8) call pdbatom (' H5 ',resname,ires,ni+9) call pdbatom (' H6 ',resname,ires,ni+10) else call pdbatom (' H3 ',resname,ires,ni+8) end if c c adenine in deoxyadenosine residue (DA) c else if (resname .eq. ' DA') then if (allatom) then call pdbatom (' H8 ',resname,ires,ni+10) call pdbatom (' H61',resname,ires,ni+11) call pdbatom (' H62',resname,ires,ni+12) call pdbatom (' H2 ',resname,ires,ni+13) else call pdbatom (' H61',resname,ires,ni+10) call pdbatom (' H62',resname,ires,ni+11) end if c c guanine in deoxyguanosine residue (DG) c else if (resname .eq. ' DG') then if (allatom) then call pdbatom (' H8 ',resname,ires,ni+11) call pdbatom (' H1 ',resname,ires,ni+12) call pdbatom (' H21',resname,ires,ni+13) call pdbatom (' H22',resname,ires,ni+14) else call pdbatom (' H1 ',resname,ires,ni+11) call pdbatom (' H21',resname,ires,ni+12) call pdbatom (' H22',resname,ires,ni+13) end if c c cytosine in deoxycytidine residue (DC) c else if (resname .eq. ' DC') then if (allatom) then call pdbatom (' H41',resname,ires,ni+8) call pdbatom (' H42',resname,ires,ni+9) call pdbatom (' H5 ',resname,ires,ni+10) call pdbatom (' H6 ',resname,ires,ni+11) else call pdbatom (' H41',resname,ires,ni+8) call pdbatom (' H42',resname,ires,ni+9) end if c c thymine in deoxythymidine residue (DT) c else if (resname .eq. ' DT') then if (allatom) then call pdbatom (' H3 ',resname,ires,ni+9) call pdbatom (' H71',resname,ires,ni+10) call pdbatom (' H72',resname,ires,ni+11) call pdbatom (' H73',resname,ires,ni+12) call pdbatom (' H6 ',resname,ires,ni+13) else call pdbatom (' H3 ',resname,ires,ni+9) end if end if c c get any capping hydrogen atoms for the current residue c do i = 1, n12(o5i) k = i12(i,o5i) if (atomic(k) .eq. 1) call pdbatom (' H5T',resname,ires,k) end do do i = 1, n12(o3i) k = i12(i,o3i) if (atomic(k) .eq. 1) call pdbatom (' H3T',resname,ires,k) 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 zatom -- adds a single atom to Z-matrix ## c ## ## c ############################################################ c c c "zatom" adds an atom to the end of the current Z-matrix c and then increments the atom counter; atom type, defining c atoms and internal coordinates are passed as arguments c c subroutine zatom (bionum,bond,angle,dihed,iz1,iz2,iz3,iz4) use angbnd use atomid use atoms use bndstr use fields use iounit use kangs use katoms use kbonds use sizes use zclose use zcoord implicit none integer i,size integer bionum integer na,nb integer iz1,iz2 integer iz3,iz4 integer ita,itb integer itc,itd real*8 bond,angle real*8 dihed logical lookup character*4 pa,pb,pc,pd character*8 blank8,ptb character*12 blank12,pta c c c choose ideal or force field bond and angle values c lookup = .false. c c fill various arrays with information for this atom c if (bionum .gt. 0) then type(n) = biotyp(bionum) if (type(n) .gt. 0) then name(n) = symbol(type(n)) else name(n) = 'XXX' end if zbond(n) = bond zang(n) = angle ztors(n) = dihed if (ztors(n) .lt. -180.0d0) then ztors(n) = ztors(n) + 360.0d0 else if (ztors(n) .gt. 180.0d0) then ztors(n) = ztors(n) - 360.0d0 end if iz(1,n) = iz1 iz(2,n) = iz2 iz(3,n) = iz3 iz(4,n) = iz4 c c find force field bond length and angle values c if (lookup) then ita = 0 itb = 0 itc = 0 itd = 0 if (n .ne. 0) ita = atmcls(type(n)) if (iz1 .ne. 0) itb = atmcls(type(iz1)) if (iz2 .ne. 0) itc = atmcls(type(iz2)) if (iz3 .ne. 0) itd = atmcls(type(iz3)) blank8 = ' ' blank12 = ' ' do i = maxnb, 1, -1 if (kb(i) .eq. blank8) nb = i - 1 end do do i = maxna, 1, -1 if (ka(i) .eq. blank12) na = i - 1 end do size = 4 call numeral (ita,pa,size) call numeral (itb,pb,size) if (ita .le. itb) then ptb = pa//pb else ptb = pb//pa end if do i = 1, nb if (kb(i) .eq. ptb) then if (blen(i) .ne. 0.0d0) zbond(n) = blen(i) goto 10 end if end do 10 continue call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itc,pc,size) if (ita .le. itc) then pta = pa//pb//pc else pta = pc//pb//pa end if do i = 1, na if (ka(i) .eq. pta) then if (ang(1,i) .ne. 0.0d0) zang(n) = ang(1,i) goto 20 end if end do 20 continue if (iz4 .ne. 0) then call numeral (ita,pa,size) call numeral (itb,pb,size) call numeral (itd,pd,size) if (ita .le. itd) then pta = pa//pb//pd else pta = pd//pb//pa end if do i = 1, na if (ka(i) .eq. pta) then if (ang(1,i) .ne. 0.0d0) ztors(n) = ang(1,i) goto 30 end if end do 30 continue end if end if c c increment atom counter and check for too many atoms c n = n + 1 if (n .gt. maxatm) then write (iout,40) maxatm 40 format (/,' ZATOM -- The Maximum of',i9,' Atoms', & ' has been Exceeded') call fatal end if c c add an extra bond to make a ring closure c else if (bionum .eq. -1) then nadd = nadd + 1 iadd(1,nadd) = iz1 iadd(2,nadd) = iz2 c c delete an extra bond to make separate molecules c else if (bionum .eq. -2) then ndel = ndel + 1 idel(1,ndel) = iz1 idel(2,ndel) = iz2 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 zclose -- Z-matrix ring openings and closures ## c ## ## c ############################################################## c c c nadd number of added bonds between Z-matrix atoms c ndel number of bonds between Z-matrix bonds to delete c iadd numbers of the atom pairs defining added bonds c idel numbers of the atom pairs defining deleted bonds c c module zclose use sizes implicit none integer nadd,ndel integer iadd(2,maxatm) integer idel(2,maxatm) save end c c c ################################################### c ## COPYRIGHT (C) 1992 by Jay William Ponder ## c ## All Rights Reserved ## c ################################################### c c ############################################################## c ## ## c ## module zcoord -- Z-matrix internal coordinate values ## c ## ## c ############################################################## c c c iz defining atom numbers for each Z-matrix atom c zbond bond length used to define each Z-matrix atom c zang bond angle used to define each Z-matrix atom c ztors angle or torsion used to define Z-matrix atom c c module zcoord use sizes implicit none integer iz(4,maxatm) real*8 zbond(maxatm) real*8 zang(maxatm) real*8 ztors(maxatm) save end /* * This version of pmpb.c is compatible with APBS Version 1.3 * * Note: The "routines.h" header file includes apbscfg.h, which * defines ENABLE_TINKER. ENABLE_TINKER turns on function prototypes * in the headers included within "apbs.h"; therefore, "routines.h" * needs to be before "apbs.h" to avoid implicit function definitons */ #include "apbs/apbscfg.h" #include "apbs/routines.h" #include "apbs/apbs.h" /* * Below we define aliases to allow Tinker Fortran code * to call the C routines in this file when linking on * Windows under the Intel compiler * * Replace __ICL with _WIN32 or _WIN64 to cause these * definitions to always be used on Windows machines * * Also use the -Qlowercase flag to deal with the Intel * compiler's name mangling on Windows; underscores are * used by default on Linux and macOS, but not Windows */ #ifdef __ICL #define apbsinitial_ apbsinitial #define apbsempole_ apbsempole #define apbsinduce_ apbsinduce #define apbsnlinduce_ apbsnlinduce #define pbdirectpolforce_ pbdirectpolforce #define pbmutualpolforce_ pbmutualpolforce #define apbsfinal_ apbsfinal #endif /*********************************************************************** Below are some global variables that are saved between APBS calls. There may be a better way to do this, although passing pointers into Fortran should be avoided. ***********************************************************************/ // Tinker MAXATM parameter; must match "sizes.f" #define maxatm 1000000 // Tinker MAXION parameter; must match "pbstuf.f" #define maxion 10 // APBS configuration objects Vmem *mem = VNULL; Vcom *com = VNULL; Vio *sock = VNULL; NOsh *nosh = VNULL; // atom list Valist *alist[NOSH_MAXMOL]; // potential solutions saved for polarization force calculation Vgrid *permU[2]; Vgrid *indU[2]; Vgrid *nlIndU[2]; // kappa and dielectric Vgrids (for homogeneous and solvated states) Vgrid *dielXMap[NOSH_MAXMOL]; Vgrid *dielYMap[NOSH_MAXMOL]; Vgrid *dielZMap[NOSH_MAXMOL]; Vgrid *kappaMap[NOSH_MAXMOL]; Vgrid *potMap[NOSH_MAXMOL]; Vgrid *chargeMap[NOSH_MAXMOL]; double realCenter[3]; /*********************************************************************** apbsinitial is called from Tinker to: (1) Initialize APBS Vcom, Vmem and NOsh objects (2) Create a "virtual" APBS input file and parse it ***********************************************************************/ void apbsinitial_ (int dime[3], double grid[3], double gcent[3], double cgrid[3], double cgcent[3], double fgrid[3], double fgcent[3], double *pdie, double *sdie, double *srad, double *swin, double *sdens, double *kelvin, int *ionn, double ionc[maxion], int ionq[maxion], double ionr[maxion], char *pbtypef, int *pbtypelen, char *pbsolnf, int *pbsolnlen, char *bcflf, int *bcfllen, char *chgmf, int *chgmlen, char *srfmf, int *srfmlen, int fortranAppendedPbtypeLen, int fortranAppendedPbsolnLen, int fortranAppendedBfclLen, int fortranAppendedChgmLen, int fortranAppendedSrfmLen) { /* All character strings passed from Fortran result in an integer * appended to the list of arguments, each equal to the static * length of 20 specified in the Fortran module 'pbstuf.f' * * Further below the Fortran strings will be converted into * null terminated C-strings */ char pbtype[21]; // lpbe char pbsoln[21]; // mg-manual or mg-auto char bcfl[21]; // zero, sdh, mdh char chgm[21]; // spl4 char srfm[21]; // mol, smol, spl2 /* Bogus argc and argv variables used for Vcom constructor */ int argc = 0; char **argv; /* CPU info */ int rank, size; /* APBS "input file" is a character buffer */ char buff[4096]; char tmp[1024]; /* Loop index */ int i; /* Start the timer; it is not stopped until apbsfinal is called */ Vnm_tstart(APBS_TIMER_WALL_CLOCK, "APBS WALL CLOCK"); /* Convert Fortran strings to null-terminated C-String */ strncpy(pbtype, pbtypef, *pbtypelen); strncpy(pbsoln, pbsolnf, *pbsolnlen); strncpy(bcfl, bcflf, *bcfllen); strncpy(chgm, chgmf, *chgmlen); strncpy(srfm, srfmf, *srfmlen); pbtype[*pbtypelen] = '\0'; pbsoln[*pbsolnlen] = '\0'; bcfl[*bcfllen] = '\0'; chgm[*chgmlen] = '\0'; srfm[*srfmlen] = '\0'; /* Rather than require an APBS input file, a character buffer is * loaded with two ELEC statements: * * (1) The homogeneous calculation * (2) The solvated calculation * * Many options for partial charge systems are not yet supported * for AMOEBA (or are not appropriate); The subset of ELEC options * that can be modified are configured using Tinker keywords * * Initialization of the "nosh" input data structure then proceeds * using the buffer data; If the syntax of the ELEC statement changes, * then corresponding changes will be needed to be made below */ /* Homogeneous */ strcpy(buff,"ELEC NAME HOMOGENEOUS\n"); sprintf(tmp,"\t%s\n",pbsoln); strcat(buff,tmp); sprintf(tmp,"\t%s\n",pbtype); strcat(buff,tmp); sprintf(tmp,"\tDIME\t%3i %3i %3i\n",dime[0],dime[1],dime[2]); strcat(buff,tmp); // MG-AUTO if (strcmp(pbsoln,"MG-AUTO") == 0) { sprintf(tmp,"\tCGLEN %10.6f %10.6f %10.6f\n", dime[0]*cgrid[0], dime[1]*cgrid[1], dime[2]*cgrid[2]); strcat(buff,tmp); sprintf(tmp,"\tCGCENT %10.6f %10.6f %10.6f\n", cgcent[0], cgcent[1],cgcent[2]); strcat(buff,tmp); sprintf(tmp,"\tFGLEN %10.6f %10.6f %10.6f\n", dime[0]*fgrid[0], dime[1]*fgrid[1], dime[2]*fgrid[2]); strcat(buff,tmp); sprintf(tmp,"\tFGCENT %10.6f %10.6f %10.6f\n", fgcent[0], fgcent[1], fgcent[2]); strcat(buff,tmp); } else { // MG-MANUAL sprintf(tmp,"\tGLEN %10.6f %10.6f %10.6f\n", dime[0]*grid[0], dime[1]*grid[1], dime[2]*grid[2]); strcat(buff,tmp); sprintf(tmp,"\tGCENT %10.6f %10.6f %10.6f\n", gcent[0], gcent[1], gcent[2]); strcat(buff,tmp); } strcat(buff,"\tMOL\t1\n"); sprintf(tmp,"\tBCFL\t%s\n", bcfl); strcat(buff,tmp); sprintf(tmp,"\tPDIE %10.6f\n", *pdie); strcat(buff,tmp); sprintf(tmp,"\tSDIE %10.6f\n", *pdie); strcat(buff,tmp); sprintf(tmp,"\tCHGM\t%s\n", chgm); strcat(buff,tmp); sprintf(tmp,"\tSRFM\t%s\n", srfm); strcat(buff,tmp); sprintf(tmp,"\tSRAD %10.6f\n", *srad); strcat(buff,tmp); sprintf(tmp,"\tSWIN %10.6f\n", *swin); strcat(buff,tmp); sprintf(tmp,"\tSDENS %10.6f\n", *sdens); strcat(buff,tmp); sprintf(tmp,"\tTEMP %10.6f\n", *kelvin); strcat(buff,tmp); strcat(buff,"END\n\n"); /* Solvated */ strcat(buff,"ELEC NAME SOLVATED\n"); sprintf(tmp,"\t%s\n",pbsoln); strcat(buff,tmp); sprintf(tmp,"\t%s\n",pbtype); strcat(buff,tmp); sprintf(tmp,"\tDIME\t%3i %3i %3i\n",dime[0],dime[1],dime[2]); strcat(buff,tmp); // MG-AUTO if (strcmp(pbsoln,"MG-AUTO") == 0) { sprintf(tmp,"\tCGLEN %10.6f %10.6f %10.6f\n", dime[0]*cgrid[0], dime[1]*cgrid[1], dime[2]*cgrid[2]); strcat(buff,tmp); sprintf(tmp,"\tCGCENT %10.6f %10.6f %10.6f\n", cgcent[0], cgcent[1], cgcent[2]); strcat(buff,tmp); sprintf(tmp,"\tFGLEN %10.6f %10.6f %10.6f\n", dime[0]*fgrid[0], dime[1]*fgrid[1], dime[2]*fgrid[2]); strcat(buff,tmp); sprintf(tmp,"\tFGCENT %10.6f %10.6f %10.6f\n", fgcent[0], fgcent[1], fgcent[2]); strcat(buff,tmp); } else { // MG-MANUAL sprintf(tmp,"\tGLEN %10.6f %10.6f %10.6f\n", dime[0]*grid[0], dime[1]*grid[1], dime[2]*grid[2]); strcat(buff,tmp); sprintf(tmp,"\tGCENT %10.6f %10.6f %10.6f\n", gcent[0], gcent[1], gcent[2]); strcat(buff,tmp); } strcat(buff,"\tMOL\t1\n"); sprintf(tmp,"\tBCFL\t%s\n", bcfl); strcat(buff,tmp); sprintf(tmp,"\tPDIE %10.6f\n", *pdie); strcat(buff,tmp); sprintf(tmp,"\tSDIE %10.6f\n", *sdie); strcat(buff,tmp); sprintf(tmp,"\tCHGM\t%s\n", chgm); strcat(buff,tmp); sprintf(tmp,"\tSRFM\t%s\n", srfm); strcat(buff,tmp); sprintf(tmp,"\tSRAD %10.6f\n", *srad); strcat(buff,tmp); sprintf(tmp,"\tSWIN %10.6f\n", *swin); strcat(buff,tmp); sprintf(tmp,"\tSDENS %10.6f\n", *sdens); strcat(buff,tmp); sprintf(tmp,"\tTEMP %10.6f\n", *kelvin); strcat(buff,tmp); for (i=0; i < *ionn; i++) { sprintf(tmp,"\tION\t%2i %10.6f %10.6f\n", ionq[i], ionc[i], ionr[i]); strcat(buff,tmp); } strcat(buff,"END\n"); strcat(buff,"\nQUIT\n"); /* Misc. initializations */ for (i=0; iatoms = Vmem_malloc(alist[0]->vmem, *natom, (sizeof(Vatom))); alist[0]->number = *natom; } /* Read Tinker input data into Vatom instances */ for (i=0; i < alist[0]->number; i++){ atom = Valist_getAtom(alist[0],i); Vatom_setAtomID(atom, i); Vatom_setPosition(atom, x[i]); Vatom_setRadius(atom, rad[i]); charge = rpole[i][0]; Vatom_setCharge(atom, charge); dipole[0] = rpole[i][1]; dipole[1] = rpole[i][2]; dipole[2] = rpole[i][3]; Vatom_setDipole(atom, dipole); quad[0] = rpole[i][4]; quad[1] = rpole[i][5]; quad[2] = rpole[i][6]; quad[3] = rpole[i][7]; quad[4] = rpole[i][8]; quad[5] = rpole[i][9]; quad[6] = rpole[i][10]; quad[7] = rpole[i][11]; quad[8] = rpole[i][12]; Vatom_setQuadrupole(atom, quad); /* Useful check printf(" %i %f (%f,%f,%f)\n",i,rad[i], x[i][0], x[i][1], x[i][2]); printf(" %f\n %f,%f,%f\n", charge, dipole[0], dipole[1], dipole[2]); printf(" %f\n", quad[0]); printf(" %f %f\n", quad[3], quad[4]); printf(" %f %f %f\n", quad[6], quad[7], quad[8]); */ energy[i] = 0.0; for (j=0;j<3;j++){ fld[i][j] = 0.0; rff[i][j] = 0.0; rft[i][j] = 0.0; } } nosh->nmol = 1; Valist_getStatistics(alist[0]); /* Only call setupCalc routine once, so we can reuse this nosh object */ if (nosh->ncalc < 2) { if (NOsh_setupElecCalc(nosh, alist) != 1) { printf("Error setting up calculations\n"); exit(-1); } } /* Solve the LPBE for the homogeneous and then solvated states */ for (i=0; i<2; i++) { /* Useful local variables */ mgparm = nosh->calc[i]->mgparm; pbeparm = nosh->calc[i]->pbeparm; /* Just to be robust */ if (!MGparm_check(mgparm)){ printf("MGparm Check failed\n"); printMGPARM(mgparm, realCenter); exit(-1); } if (!PBEparm_check(pbeparm)){ printf("PBEparm Check failed\n"); printPBEPARM(pbeparm); exit(-1); } /* Set up the problem */ mgparm->chgs = VCM_PERMANENT; if (!initMG(i, nosh, mgparm, pbeparm, realCenter, pbe, alist, dielXMap, dielYMap, dielZMap, kappaMap, chargeMap, pmgp, pmg, potMap)) { Vnm_tprint( 2, "Error setting up MG calculation!\n"); return; } /* Solve the PDE */ if (solveMG(nosh, pmg[i], mgparm->type) != 1) { Vnm_tprint(2, "Error solving PDE!\n"); return; } /* Set partition information for observables and I/O */ /* Note that parallel operation has NOT been tested */ if (setPartMG(nosh, mgparm, pmg[i]) != 1) { Vnm_tprint(2, "Error setting partition info!\n"); return; } nx = pmg[i]->pmgp->nx; ny = pmg[i]->pmgp->ny; nz = pmg[i]->pmgp->nz; hx = pmg[i]->pmgp->hx; hy = pmg[i]->pmgp->hy; hzed = pmg[i]->pmgp->hzed; xmin = pmg[i]->pmgp->xmin; ymin = pmg[i]->pmgp->ymin; zmin = pmg[i]->pmgp->zmin; /* Save dielectric/kappa maps into Vgrids, then change the nosh * data structure to think it read these maps in from a file; * The goal is to save setup time during convergence of the * induced dipoles. This is under consideration... */ /* // X (shifted) data = Vmem_malloc(mem, nx*ny*nz, sizeof(double)); Vpmg_fillArray(pmg[i], data, VDT_DIELX, 0.0, pbeparm->pbetype); dielXMap[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed, xmin + 0.5*hx,ymin,zmin,data); dielXMap[i]->readdata = 1; // Y (shifted) data = Vmem_malloc(mem, nx*ny*nz, sizeof(double)); Vpmg_fillArray(pmg[i], data, VDT_DIELY, 0.0, pbeparm->pbetype); dielYMap[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed, xmin,ymin + 0.5*hy,zmin,data); dielYMap[i]->readdata = 1; // Z (shifted) data = Vmem_malloc(mem, nx*ny*nz, sizeof(double)); Vpmg_fillArray(pmg[i], data, VDT_DIELZ, 0.0, pbeparm->pbetype); dielZMap[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed, xmin,ymin,zmin + 0.5*hzed,data); dielZMap[i]->readdata = 1; // Kappa data = Vmem_malloc(mem, nx*ny*nz, sizeof(double)); Vpmg_fillArray(pmg[i], data, VDT_KAPPA, 0.0, pbeparm->pbetype); kappaMap[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin,data); kappaMap[i]->readdata = 1; // Update the pbeparam structure, since we now have // dielectric and kappap maps pbeparm->useDielMap = 1; pbeparm->dielMapID = i + 1; pbeparm->useKappaMap = 1; pbeparm->kappaMapID = i + 1; */ data = Vmem_malloc(mem, nx*ny*nz, sizeof(double)); Vpmg_fillArray(pmg[i], data, VDT_POT, 0.0, pbeparm->pbetype, pbeparm); permU[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin,data); permU[i]->readdata = 1; // set readdata flag to have the dtor to free data if (i == 0){ sign = -1.0; } else { sign = 1.0; } /* Calculate observables */ for (j=0; j < alist[0]->number; j++){ energy[j] += sign * Vpmg_qfPermanentMultipoleEnergy(pmg[i], j); Vpmg_fieldSpline4(pmg[i], j, field); fld[j][0] += sign * field[0]; fld[j][1] += sign * field[1]; fld[j][2] += sign * field[2]; } if (!pmg[i]->pmgp->nonlin && (pmg[i]->surfMeth == VSM_SPLINE || pmg[i]->surfMeth == VSM_SPLINE3 || pmg[i]->surfMeth == VSM_SPLINE4)) { for (j=0; j < alist[0]->number; j++){ Vpmg_qfPermanentMultipoleForce(pmg[i], j, force, torque); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; rft[j][0] += sign * torque[0]; rft[j][1] += sign * torque[1]; rft[j][2] += sign * torque[2]; } kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 * 1.0/4.184; epsp = Vpbe_getSoluteDiel(pmg[i]->pbe); epsw = Vpbe_getSolventDiel(pmg[i]->pbe); if (VABS(epsp-epsw) > VPMGSMALL) { for (j=0; j < alist[0]->number; j++){ Vpmg_dbPermanentMultipoleForce(pmg[i], j, force); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; } } zkappa2 = Vpbe_getZkappa2(pmg[i]->pbe); if (zkappa2 > VPMGSMALL) { for (j=0; j < alist[0]->number; j++) { Vpmg_ibPermanentMultipoleForce(pmg[i], j, force); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; } } } } //nosh->ndiel = 2; //nosh->nkappa = 2; /* printf("Energy (multipole) %f Kcal/mol\n", *energy); printf("Energy (volume) %f Kcal/mol\n", evol * 0.5 * kT); */ /* Convert results into kcal/mol units */ kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 * 1.0/4.184; /* Electric converts from electron**2/Angstrom to kcal/mol */ electric = 332.063709; *total = 0.0; for (i=0; inumber; i++){ /* starting with the field in KT/e/Ang^2 multiply by kcal/mol/KT the field is then divided by "electric" to convert to e/Ang^2 */ energy[i] *= 0.5 * kT; *total += energy[i]; fld[i][0] *= kT / electric; fld[i][1] *= kT / electric; fld[i][2] *= kT / electric; rff[i][0] *= kT; rff[i][1] *= kT; rff[i][2] *= kT; rft[i][0] *= kT; rft[i][1] *= kT; rft[i][2] *= kT; } killMG(nosh, pbe, pmgp, pmg); } /*********************************************************************** apbsinduce is called from Tinker during SCRF convergence to: (1) Solve the PBE given induced dipoles as the source term (2) Save the solution potential for later polarization force calc (3) Return the induced reaction field to Tinker ***********************************************************************/ void apbsinduce_ (double uind[maxatm][3], double fld[maxatm][3]){ Vpmg *pmg[NOSH_MAXCALC]; Vpmgp *pmgp[NOSH_MAXCALC]; Vpbe *pbe[NOSH_MAXCALC]; MGparm *mgparm = VNULL; PBEparm *pbeparm = VNULL; Vatom *atom = VNULL; /* Observables and unit conversion */ double field[3]; double sign,kT,electric; /* Potential Vgrid construction */ double nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin; double *data; /* Loop variables */ int i,j; VASSERT(nosh != VNULL); for (i=0; inumber; i++){ atom = Valist_getAtom(alist[0],i); Vatom_setInducedDipole(atom, uind[i]); for (j=0;j<3;j++){ fld[i][j] = 0.0; } } /* Solve the LPBE for the homogeneous system, then solvated */ for (i=0; i<2; i++) { pmg[i] = VNULL; pmgp[i] = VNULL; pbe[i] = VNULL; /* Useful local variables */ mgparm = nosh->calc[i]->mgparm; pbeparm = nosh->calc[i]->pbeparm; if (!MGparm_check(mgparm)){ printf("MGparm Check failed\n"); exit(-1); } if (!PBEparm_check(pbeparm)){ printf("PBEparm Check failed\n"); exit(-1); } /* Set up problem */ mgparm->chgs = VCM_INDUCED; if (!initMG(i, nosh, mgparm, pbeparm, realCenter, pbe, alist, dielXMap, dielYMap, dielZMap, kappaMap, chargeMap, pmgp, pmg, potMap)) { Vnm_tprint( 2, "Error setting up MG calculation!\n"); return; } /* Solve the PDE */ if (solveMG(nosh, pmg[i], mgparm->type) != 1) { Vnm_tprint(2, "Error solving PDE!\n"); return; } /* Set partition information for observables and I/O */ if (setPartMG(nosh, mgparm, pmg[i]) != 1) { Vnm_tprint(2, "Error setting partition info!\n"); return; } /* Save the potential due to local induced dipoles */ nx = pmg[i]->pmgp->nx; ny = pmg[i]->pmgp->ny; nz = pmg[i]->pmgp->nz; hx = pmg[i]->pmgp->hx; hy = pmg[i]->pmgp->hy; hzed = pmg[i]->pmgp->hzed; xmin = pmg[i]->pmgp->xmin; ymin = pmg[i]->pmgp->ymin; zmin = pmg[i]->pmgp->zmin; if (indU[i] == VNULL) { data = Vmem_malloc(mem, nx*ny*nz, sizeof(double)); Vpmg_fillArray(pmg[i], data, VDT_POT, 0.0, pbeparm->pbetype, pbeparm); indU[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin,data); indU[i]->readdata = 1; // set readdata flag to have the dtor to free data } else { data = indU[i]->data; Vpmg_fillArray(pmg[i], data, VDT_POT, 0.0, pbeparm->pbetype, pbeparm); } if (i == 0){ sign = -1.0; } else { sign = 1.0; } for (j=0; j < alist[0]->number; j++){ Vpmg_fieldSpline4(pmg[i], j, field); fld[j][0] += sign * field[0]; fld[j][1] += sign * field[1]; fld[j][2] += sign * field[2]; } } /* load results into the return arrays in electron**2/Ang */ /* value of kT is in kcal/mol */ kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 / 4.184; /* electric is conversion from electron**2/Ang to Kcal/mol */ electric = 332.063713; for (i=0; inumber; i++){ // starting with the field in KT/e/Ang^2 multiply by Kcal/mol/KT // (conversion to e/Ang^2, which are Tinker field units) fld[i][0] *= kT / electric; fld[i][1] *= kT / electric; fld[i][2] *= kT / electric; } killMG(nosh, pbe, pmgp, pmg); } /*********************************************************************** apbsnlinduce is called from Tinker during SCRF convergence to: (1) Solve the PBE given non-local induced dipoles as the source term (2) Save the solution potential for later polarization force calc (3) Return the nonlocal induced dipole reaction field to Tinker ************************************************************************/ void apbsnlinduce_ (double uinp[maxatm][3], double fld[maxatm][3]){ /* Misc. pointers to APBS data structures */ Vpmg *pmg[NOSH_MAXCALC]; Vpmgp *pmgp[NOSH_MAXCALC]; Vpbe *pbe[NOSH_MAXCALC]; MGparm *mgparm = VNULL; PBEparm *pbeparm = VNULL; Vatom *atom = VNULL; /* Observables and unit conversion */ double field[3]; double sign,kT,electric; /* Potential Vgrid construction */ double nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin; double *data; /* Loop variables */ int i,j; VASSERT(nosh != VNULL); for (i=0; inumber; i++){ atom = Valist_getAtom(alist[0],i); Vatom_setNLInducedDipole(atom, uinp[i]); for (j=0;j<3;j++){ fld[i][j] = 0.0; } } /* Solve the LPBE for the homogeneous system, then solvated */ for (i=0; i<2; i++) { pmg[i] = VNULL; pmgp[i] = VNULL; pbe[i] = VNULL; /* Useful local variables */ mgparm = nosh->calc[i]->mgparm; pbeparm = nosh->calc[i]->pbeparm; if (!MGparm_check(mgparm)){ printf("MGparm Check failed\n"); exit(-1); } if (!PBEparm_check(pbeparm)){ printf("PBEparm Check failed\n"); exit(-1); } /* Set up problem */ mgparm->chgs = VCM_NLINDUCED; if (!initMG(i, nosh, mgparm, pbeparm, realCenter, pbe, alist, dielXMap, dielYMap, dielZMap, kappaMap, chargeMap, pmgp, pmg, potMap)) { Vnm_tprint( 2, "Error setting up MG calculation!\n"); return; } /* Solve the PDE */ if (solveMG(nosh, pmg[i], mgparm->type) != 1) { Vnm_tprint(2, "Error solving PDE!\n"); return; } /* Set partition information for observables and I/O */ if (setPartMG(nosh, mgparm, pmg[i]) != 1) { Vnm_tprint(2, "Error setting partition info!\n"); return; } /* Save the potential due to non-local induced dipoles */ nx = pmg[i]->pmgp->nx; ny = pmg[i]->pmgp->ny; nz = pmg[i]->pmgp->nz; hx = pmg[i]->pmgp->hx; hy = pmg[i]->pmgp->hy; hzed = pmg[i]->pmgp->hzed; xmin = pmg[i]->pmgp->xmin; ymin = pmg[i]->pmgp->ymin; zmin = pmg[i]->pmgp->zmin; if (nlIndU[i] == VNULL) { data = Vmem_malloc(VNULL, nx*ny*nz, sizeof(double)); Vpmg_fillArray(pmg[i], data, VDT_POT, 0.0, pbeparm->pbetype, pbeparm); nlIndU[i] = Vgrid_ctor(nx,ny,nz,hx,hy,hzed,xmin,ymin,zmin,data); nlIndU[i]->readdata = 1; // set readata flag to have dtor free data } else { data = nlIndU[i]->data; Vpmg_fillArray(pmg[i], data, VDT_POT, 0.0, pbeparm->pbetype, pbeparm); } if (i == 0){ sign = -1.0; } else { sign = 1.0; } for (j=0; j < alist[0]->number; j++){ Vpmg_fieldSpline4(pmg[i], j, field); fld[j][0] += sign * field[0]; fld[j][1] += sign * field[1]; fld[j][2] += sign * field[2]; } } /* load results into the return arrays in electron**2/Angstrom */ /* value of kT is in kcal/mol */ kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 / 4.184; /* electric is conversion from electron**2/Angstrom to Kcal/mol */ electric = 332.063713; for (i=0; inumber; i++){ fld[i][0] *= kT / electric; fld[i][1] *= kT / electric; fld[i][2] *= kT / electric; } killMG(nosh, pbe, pmgp, pmg); } /*********************************************************************** pbdirectpolforce is called from Tinker to: (1) compute direct polarization forces and torques using saved potentials ***********************************************************************/ void pbdirectpolforce_ (double uind[maxatm][3], double uinp[maxatm][3], double rff[maxatm][3], double rft[maxatm][3]) { Vpmg *pmg[NOSH_MAXCALC]; Vpmgp *pmgp[NOSH_MAXCALC]; Vpbe *pbe[NOSH_MAXCALC]; MGparm *mgparm = VNULL; PBEparm *pbeparm = VNULL; Vatom *atom = VNULL; double kT, force[3], torque[3]; double sign, zkappa2, epsp, epsw; int i,j; for (i=0; inumber; i++){ atom = Valist_getAtom(alist[0],i); Vatom_setInducedDipole(atom, uind[i]); Vatom_setNLInducedDipole(atom, uinp[i]); for (j=0;j<3;j++){ rff[i][j] = 0.0; rft[i][j] = 0.0; } } for (i=0; i<2; i++) { VASSERT(permU[i] != VNULL); VASSERT(indU[i] != VNULL); VASSERT(nlIndU[i] != VNULL); pmg[i] = VNULL; pmgp[i] = VNULL; pbe[i] = VNULL; /* Useful local variables */ mgparm = nosh->calc[i]->mgparm; pbeparm = nosh->calc[i]->pbeparm; /* Set up problem */ if (!initMG(i, nosh, mgparm, pbeparm, realCenter, pbe, alist, dielXMap, dielYMap, dielZMap, kappaMap, chargeMap, pmgp, pmg, potMap)) { Vnm_tprint( 2, "Error setting up MG calculation!\n"); return; } if (i == 0) { sign = -1.0; } else { sign = 1.0; } // Q-Phi Force & Torque if (!pmg[i]->pmgp->nonlin && (pmg[i]->surfMeth == VSM_SPLINE || pmg[i]->surfMeth == VSM_SPLINE3 || pmg[i]->surfMeth == VSM_SPLINE4)) { for (j=0; j < alist[0]->number; j++){ Vpmg_qfDirectPolForce(pmg[i], permU[i], indU[i], j, force, torque); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; rft[j][0] += sign * torque[0]; rft[j][1] += sign * torque[1]; rft[j][2] += sign * torque[2]; Vpmg_qfNLDirectPolForce(pmg[i], permU[i], nlIndU[i], j,force,torque); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; rft[j][0] += sign * torque[0]; rft[j][1] += sign * torque[1]; rft[j][2] += sign * torque[2]; } // Dieletric Boundary Force epsp = Vpbe_getSoluteDiel(pmg[i]->pbe); epsw = Vpbe_getSolventDiel(pmg[i]->pbe); if (VABS(epsp-epsw) > VPMGSMALL) { for (j=0; j < alist[0]->number; j++){ Vpmg_dbDirectPolForce(pmg[i], permU[i], indU[i], j, force); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; Vpmg_dbNLDirectPolForce(pmg[i], permU[i], nlIndU[i], j, force); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; } } // Ionic Boundary Force zkappa2 = Vpbe_getZkappa2(pmg[i]->pbe); if (zkappa2 > VPMGSMALL) { for (j=0; j < alist[0]->number; j++){ Vpmg_ibDirectPolForce(pmg[i], permU[i], indU[i], j, force); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; Vpmg_ibNLDirectPolForce(pmg[i], permU[i], nlIndU[i], j, force); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; } } } } // kT in kcal/mol kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 / 4.184; for (i=0; inumber; i++){ rff[i][0] *= kT; rff[i][1] *= kT; rff[i][2] *= kT; rft[i][0] *= kT; rft[i][1] *= kT; rft[i][2] *= kT; } killMG(nosh, pbe, pmgp, pmg); } /*********************************************************************** pbmutualpolforce is called from Tinker to: (1) compute mutual polarization forces using saved potentials ***********************************************************************/ void pbmutualpolforce_ (double uind[maxatm][3], double uinp[maxatm][3], double rff[maxatm][3]) { Vpmg *pmg[NOSH_MAXCALC]; Vpmgp *pmgp[NOSH_MAXCALC]; Vpbe *pbe[NOSH_MAXCALC]; MGparm *mgparm = VNULL; PBEparm *pbeparm = VNULL; Vatom *atom = VNULL; double kT, force[3]; double sign, zkappa2, epsp, epsw; int i,j; for (i=0; inumber; i++){ atom = Valist_getAtom(alist[0],i); Vatom_setInducedDipole(atom, uind[i]); Vatom_setNLInducedDipole(atom, uinp[i]); for (j=0;j<3;j++){ rff[i][j] = 0.0; } } for (i=0; i<2; i++) { VASSERT(indU[i] != VNULL); VASSERT(nlIndU[i] != VNULL); pmg[i] = VNULL; pmgp[i] = VNULL; pbe[i] = VNULL; /* Useful local variables */ mgparm = nosh->calc[i]->mgparm; pbeparm = nosh->calc[i]->pbeparm; /* Set up problem */ if (!initMG(i, nosh, mgparm, pbeparm, realCenter, pbe, alist, dielXMap, dielYMap, dielZMap, kappaMap, chargeMap, pmgp, pmg, potMap)) { Vnm_tprint( 2, "Error setting up MG calculation!\n"); return; } if (i == 0) { sign = -1.0; } else { sign = 1.0; } for (j=0; j < alist[0]->number; j++){ Vpmg_qfMutualPolForce(pmg[i], indU[i], nlIndU[i], j, force); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; } epsp = Vpbe_getSoluteDiel(pmg[i]->pbe); epsw = Vpbe_getSolventDiel(pmg[i]->pbe); if (VABS(epsp-epsw) > VPMGSMALL) { for (j=0; j < alist[0]->number; j++){ Vpmg_dbMutualPolForce(pmg[i], indU[i], nlIndU[i], j, force); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; } } zkappa2 = Vpbe_getZkappa2(pmg[i]->pbe); if (zkappa2 > VPMGSMALL) { for (j=0; j < alist[0]->number; j++){ Vpmg_ibMutualPolForce(pmg[i], indU[i], nlIndU[i], j, force); rff[j][0] += sign * force[0]; rff[j][1] += sign * force[1]; rff[j][2] += sign * force[2]; } } } // kT in kcal/mol kT = Vunit_kb * (1e-3) * Vunit_Na * 298.15 / 4.184; for (i=0; inumber; i++){ rff[i][0] *= kT; rff[i][1] *= kT; rff[i][2] *= kT; } killMG(nosh, pbe, pmgp, pmg); } /*********************************************************************** apbsfinal is called from Tinker to: (1) clean up at the end of an APBS calculation ***********************************************************************/ void apbsfinal_() { unsigned long int bytesTotal, highWater; int i; VASSERT(nosh != VNULL); /* Kill the saved potential Vgrids */ for (i=0; i<2; i++){ Vgrid_dtor(&permU[i]); Vgrid_dtor(&indU[i]); Vgrid_dtor(&nlIndU[i]); } Valist_dtor(&alist[0]); /* Saving the kappa and dielectric maps is under consideration killKappaMaps(nosh, kappaMap); killDielMaps(nosh, dielXMap, dielYMap, dielZMap); */ NOsh_dtor(&nosh); /* Clean up MALOC structures */ bytesTotal = Vmem_bytesTotal(); highWater = Vmem_highWaterTotal(); /* printf(" Final APBS memory usage: %4.3f MB total, %4.3f MB high water\n\n", (double)(bytesTotal)/(1024.*1024.),(double)(highWater)/(1024.*1024.)); */ Vmem_dtor(&mem); Vnm_tstop(APBS_TIMER_WALL_CLOCK, "APBS WALL CLOCK"); Vcom_finalize(); Vcom_dtor(&com); } /* This file is an interface between Tinker Fortran code and a Java Server used for socket based communication. */ #include #include #include #include /* * Below we define aliases to allow Tinker Fortran code * to call the C routines in this file when linking on * Windows under the Intel compiler * * Replace __ICL with _WIN32 or _WIN64 to cause these * definitions to always be used on Windows machines * * Also use the -Qlowercase flag to deal with the Intel * compiler's name mangling on Windows; underscores are * used by default on Linux and macOS, but not Windows */ #ifdef __ICL #define createjvm_ CREATEJVM #define destroyjvm_ DESTROYJVM #define getmonitor_ GETMONITOR #define releasemonitor_ RELEASEMONITOR #define createserver_ CREATESERVER #define destroyserver_ DESTROYSERVER #define needupdate_ NEEDUPDATE #define setupdated_ SETUPDATED #define createsystem_ CREATESYSTEM #define createupdate_ CREATEUPDATE #define setcoordinates_ SETCOORDINATES #define setconnectivity_ SETCONNECTIVITY #define setvdw_ SETVDW #define setcharge_ SETCHARGE #define setmass_ SETMASS #define setatomic_ SETATOMIC #define setatomtypes_ SETATOMTYPES #define setname_ SETNAME #define setstory_ SETSTORY #define setkeyword_ SETKEYWORD #define setforcefield_ SETFORCEFIELD #define settime_ SETTIME #define setenergy_ SETENERGY #define setstep_ SETSTEP #define settype_ SETTYPE #define setfile_ SETFILE #define setvelocity_ SETVELOCITY #define setacceleration_ SETACCELERATION #define setinduced_ SETINDUCED #define setgradients_ SETGRADIENTS #endif /* Some global variables */ JNIEnv* env = 0; jobject serverobject = 0; jclass serverclass = 0; jobject systemobject = 0; jclass systemclass = 0; jobject updateobject = 0; jclass updateclass = 0; jboolean InitializeJVM() { JavaVMInitArgs args; JavaVMOption options[1]; JavaVM *vm; jint numOptions = 1; jint r; char *classpath; char *def; classpath = getenv("CLASSPATH"); if (classpath == NULL) { return JNI_FALSE; } //printf("%s\n", classpath); def = (char *) malloc(strlen(classpath) + 20); sprintf(def, "-Djava.class.path=%s", classpath); options[0].optionString = def; args.version = JNI_VERSION_1_6; args.nOptions = numOptions; args.options = options; args.ignoreUnrecognized = JNI_TRUE; r = JNI_CreateJavaVM(&vm, (void **) &env, &args); if (r == JNI_OK) { //printf("JNI_CreateJavaVM Success: %i\n", r); return JNI_TRUE; } else { //printf("JNI_CreateJavaVM Error: %i\n", r); return JNI_FALSE; } } void chksocket_(int *flag) { *flag = 1; return; } void createjvm_(int *flag) { if (!InitializeJVM()) { *flag = 0; return; } *flag = 1; return; } void destroyjvm_() { JavaVM *vm; (*env)->GetJavaVM(env, &vm); (*vm)->DestroyJavaVM(vm); } void getmonitor_() { (*env)->MonitorEnter(env, updateobject); } void releasemonitor_() { (*env)->MonitorExit(env, updateobject); } void createserver_(jint *flag) { jmethodID methodID; jobject temp; // Find the Java ffe.tinker.TinkerServer class serverclass = (*env)->FindClass(env, "ffe/tinker/TinkerServer"); if (serverclass == 0) { printf("Could not find ffe.tinker.TinkerServer\n"); *flag = 0; return; } methodID = (*env)->GetMethodID(env, serverclass, "", "(Lffe/tinker/TinkerSystem;)V"); temp = (*env)->NewObject(env, serverclass, methodID, systemobject); methodID = (*env)->GetMethodID(env, serverclass, "start", "()V"); (*env)->CallVoidMethod(env, temp, methodID, "()V"); serverobject = (*env)->NewGlobalRef(env, temp); (*env)->DeleteLocalRef(env, temp); *flag = 1; return; } void destroyserver_() { jmethodID methodID; jboolean jffe = JNI_FALSE; // Tell the server to close down methodID = (*env)->GetMethodID(env, serverclass, "stop", "()V"); (*env)->CallVoidMethod(env, serverobject, methodID, "()V"); // Wait while it closes any clients methodID = (*env)->GetMethodID(env, serverclass, "isAlive", "()Z"); while ((*env)->CallBooleanMethod(env, serverobject, methodID, "()Z")) { } (*env)->DeleteGlobalRef(env, serverobject); return; } void needupdate_(int *status) { jmethodID methodID; jboolean ret; methodID = (*env)->GetMethodID(env, serverclass, "needUpdate", "()Z"); ret = (*env)->CallBooleanMethod(env, serverobject, methodID, "()Z"); if (ret) *status = 1; else *status = 0; return; } void setupdated_() { jmethodID methodID; methodID = (*env)->GetMethodID(env, serverclass, "setUpdated", "()V"); (*env)->CallVoidMethod(env, serverobject, methodID, "()V"); return; } jstring char2jstring(const char *str, int len) { jstring result; jbyteArray bytes = 0; jmethodID methodID; jclass class; if ((*env)->EnsureLocalCapacity(env, 2) < 0) { printf("Out of memory\n"); exit(-1); } bytes = (*env)->NewByteArray(env, len); if (bytes != NULL) { (*env)->SetByteArrayRegion(env, bytes, 0, len, (jbyte *)str); class = (*env)->FindClass(env, "Ljava/lang/String;"); methodID = (*env)->GetMethodID(env, class, "", "([B)V"); result = (*env)->NewObject(env, class, methodID, bytes); (*env)->DeleteLocalRef(env, bytes); if (result != NULL) return result; } /* else fall through */ printf("Problem creating java string for: %s\nLength: %i", str, len); exit(-1); } void createsystem_(jint *atoms, jint *keywords, jint* flag) { jmethodID methodID; jobject temp; systemclass = (*env)->FindClass(env, "ffe/tinker/TinkerSystem"); if (systemclass == 0) { printf("Could not find ffe.tinker.TinkerSystem\n"); *flag = 0; return; } methodID = (*env)->GetMethodID(env, systemclass, "", "(II)V"); temp = (*env)->NewObject(env, systemclass, methodID, *atoms, *keywords); systemobject = (*env)->NewGlobalRef(env, temp); (*env)->DeleteLocalRef(env, temp); *flag = 1; return; } void createupdate_(jint *n, jint *type, jint* amoeba, jint* flag) { jmethodID methodID; jobject temp; jboolean jbool; updateclass = (*env)->FindClass(env, "ffe/tinker/TinkerUpdate"); if (updateclass == 0) { printf("Could not find ffe.tinker.TinkerUpdate\n"); *flag = 0; return; } methodID = (*env)->GetMethodID(env, updateclass, "", "(IIZ)V"); if (amoeba == 0) jbool = JNI_FALSE; else jbool = JNI_TRUE; temp = (*env)->NewObject(env, updateclass, methodID, *n, *type, jbool); updateobject = (*env)->NewGlobalRef(env, temp); (*env)->DeleteLocalRef(env, temp); methodID = (*env)->GetMethodID(env,serverclass,"loadUpdate", "(Lffe/tinker/TinkerUpdate;)V"); (*env)->CallObjectMethod(env, serverobject, methodID, updateobject); *flag = 1; return; } void setcoordinates_(jint *n, jdouble *x, jdouble *y, jdouble *z) { jfieldID fieldID; jobjectArray coords; jdoubleArray jx; jobject object; jclass class; object = updateobject; class = updateclass; if (updateobject == 0) { object = systemobject; class = systemclass; } fieldID = (*env)->GetFieldID(env, class, "coordinates", "[[D"); coords = (*env)->GetObjectField(env, object, fieldID); jx = (*env)->GetObjectArrayElement(env, coords, 0); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, x); jx = (*env)->GetObjectArrayElement(env, coords, 1); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, y); jx = (*env)->GetObjectArrayElement(env, coords, 2); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, z); } void setconnectivity_(jint *n, jint *a, jint *b, jint *c, jint *d) { jfieldID fieldID; jobjectArray connect; jintArray ci; fieldID = (*env)->GetFieldID(env, systemclass, "connectivity", "[[I"); connect = (*env)->GetObjectField(env, systemobject, fieldID); ci = (*env)->GetObjectArrayElement(env, connect, 0); (*env)->SetIntArrayRegion(env, ci, 0, *n, a); ci = (*env)->GetObjectArrayElement(env, connect, 1); (*env)->SetIntArrayRegion(env, ci, 0, *n, b); ci = (*env)->GetObjectArrayElement(env, connect, 2); (*env)->SetIntArrayRegion(env, ci, 0, *n, c); ci = (*env)->GetObjectArrayElement(env, connect, 3); (*env)->SetIntArrayRegion(env, ci, 0, *n, d); } /* void setvdw_(jint *n, jdouble *vdw) { jfieldID fieldID; jdoubleArray jvdw; fieldID = (*env)->GetFieldID(env, systemclass, "vdw", "[D"); jvdw = (*env)->GetObjectField(env, systemobject, fieldID); (*env)->SetDoubleArrayRegion(env, jvdw, 0, *n, *vdw); } */ void setcharge_(jint *n, jdouble *charge) { jfieldID fieldID; jdoubleArray jcharge; fieldID = (*env)->GetFieldID(env, systemclass, "charge", "[D"); jcharge = (*env)->GetObjectField(env, systemobject, fieldID); (*env)->SetDoubleArrayRegion(env, jcharge, 0, *n, charge); } void setmass_(jint *n, jdouble *mass) { jfieldID fieldID; jdoubleArray jmass; fieldID = (*env)->GetFieldID(env, systemclass, "mass", "[D"); jmass = (*env)->GetObjectField(env, systemobject, fieldID); (*env)->SetDoubleArrayRegion(env, jmass, 0, *n, mass); } void setatomic_(jint *n, jint *atomic) { jfieldID fieldID; jintArray jatomic; fieldID = (*env)->GetFieldID(env, systemclass, "atomic", "[I"); jatomic = (*env)->GetObjectField(env, systemobject, fieldID); (*env)->SetIntArrayRegion(env, jatomic, 0, *n, atomic); } void setatomtypes_(jint *n, jint *t) { jfieldID fieldID; jintArray types; fieldID = (*env)->GetFieldID(env, systemclass, "types", "[I"); types = (*env)->GetObjectField(env, systemobject, fieldID); (*env)->SetIntArrayRegion(env, types, 0, *n, t); } void setname_(jint *num, char *s, jint len) { jfieldID fieldID; jstring string; jobjectArray name; jint index; index = (*num) - 1; if (index < 0) { printf("Negative index into name array\n"); exit(-1); } string = char2jstring(s, len); fieldID = (*env)->GetFieldID(env, systemclass, "name", "[Ljava/lang/String;"); name = (*env)->GetObjectField(env, systemobject, fieldID); (*env)->SetObjectArrayElement(env, name, index, string); } void setstory_(jint *num, char *s, jint len) { jfieldID fieldID; jstring string; jobjectArray story; jint index; index = (*num) - 1; if (index < 0) { printf("Negative index into story array\n"); exit(-1); } string = char2jstring(s, len); fieldID = (*env)->GetFieldID(env, systemclass, "story", "[Ljava/lang/String;"); story = (*env)->GetObjectField(env, systemobject, fieldID); (*env)->SetObjectArrayElement(env, story, index, string); } void setkeyword_(jint *num, char *keyword, jint len) { jfieldID fieldID; jstring string; jobjectArray keywords; jint index; index = (*num) - 1; if (index < 0) { printf("Negative index into keyword array\n"); exit(0); } string = char2jstring(keyword, len); fieldID = (*env)->GetFieldID(env, systemclass, "keywords", "[Ljava/lang/String;"); keywords = (*env)->GetObjectField(env, systemobject, fieldID); (*env)->SetObjectArrayElement(env, keywords, index, string); } void setforcefield_(char *forcefield, jint len) { jfieldID fieldID; jstring string; string = char2jstring(forcefield, len); fieldID = (*env)->GetFieldID(env, systemclass, "forcefield", "Ljava/lang/String;"); (*env)->SetObjectField(env, systemobject, fieldID, string); } void setmdtime_(jdouble *time) { jfieldID fieldID; fieldID = (*env)->GetFieldID(env, updateclass, "time", "D"); (*env)->SetDoubleField(env, updateobject, fieldID, *time); } void setenergy_(jdouble *e) { jfieldID fieldID; fieldID = (*env)->GetFieldID(env, updateclass, "energy", "D"); (*env)->SetDoubleField(env, updateobject, fieldID, *e); } void setstep_(jint *step) { jfieldID fieldID; fieldID = (*env)->GetFieldID(env, updateclass, "step", "I"); (*env)->SetIntField(env, updateobject, fieldID, *step); } void settype_(jint *type) { jfieldID fieldID; fieldID = (*env)->GetFieldID(env, updateclass, "type", "I"); (*env)->SetIntField(env, updateobject, fieldID, *type); } void setfile_(char *name, jint len) { jfieldID fieldID; jstring string; string = char2jstring(name, len); fieldID = (*env)->GetFieldID(env, systemclass, "file", "Ljava/lang/String;"); (*env)->SetObjectField(env, systemobject, fieldID, string); } void setvelocity_(jint *n, jdouble *x, jdouble *y, jdouble *z) { jfieldID fieldID; jobjectArray ind; jdoubleArray jx; fieldID = (*env)->GetFieldID(env, updateclass, "velocity", "[[D"); ind = (*env)->GetObjectField(env, updateobject, fieldID); jx = (*env)->GetObjectArrayElement(env, ind, 0); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, x); jx = (*env)->GetObjectArrayElement(env, ind, 1); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, y); jx = (*env)->GetObjectArrayElement(env, ind, 2); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, z); } void setacceleration_(jint *n, jdouble *x, jdouble *y, jdouble *z) { jfieldID fieldID; jobjectArray ind; jdoubleArray jx; fieldID = (*env)->GetFieldID(env, updateclass, "acceleration", "[[D"); ind = (*env)->GetObjectField(env, updateobject, fieldID); jx = (*env)->GetObjectArrayElement(env, ind, 0); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, x); jx = (*env)->GetObjectArrayElement(env, ind, 1); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, y); jx = (*env)->GetObjectArrayElement(env, ind, 2); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, z); } void setinduced_(jint *n, jdouble *x, jdouble *y, jdouble *z) { jfieldID fieldID; jobjectArray ind; jdoubleArray jx; fieldID = (*env)->GetFieldID(env, updateclass, "induced", "[[D"); ind = (*env)->GetObjectField(env, updateobject, fieldID); jx = (*env)->GetObjectArrayElement(env, ind, 0); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, x); jx = (*env)->GetObjectArrayElement(env, ind, 1); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, y); jx = (*env)->GetObjectArrayElement(env, ind, 2); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, z); } void setgradients_(jint *n, jdouble *x, jdouble *y, jdouble *z) { jfieldID fieldID; jobjectArray ind; jdoubleArray jx; fieldID = (*env)->GetFieldID(env, updateclass, "gradients", "[[D"); ind = (*env)->GetObjectField(env, updateobject, fieldID); jx = (*env)->GetObjectArrayElement(env, ind, 0); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, x); jx = (*env)->GetObjectArrayElement(env, ind, 1); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, y); jx = (*env)->GetObjectArrayElement(env, ind, 2); (*env)->SetDoubleArrayRegion(env, jx, 0, *n, z); }