hdiff output

r33142/benzgenrigid.f90 2017-08-08 12:30:09.330306619 +0100 r33141/benzgenrigid.f90 2017-08-08 12:30:13.390360899 +0100
  1: ! -----------------------------------------------------------------------------  1: ! dj337: Anisotropic potential for polycyclic aromatic hydrocarbons.
  2: ! dj337 
  3: ! Anisotropic potential for periodic benzene systems. Potential from: 
  4: ! T.S.Totton, A.J.Misquitta, M.Kraft, J. Chem. Theory Comput. 6 (2010) 683–695. 
  5:  
  6: ! Long-range electrostatic interactions are computed using Ewald summation.  2: ! Long-range electrostatic interactions are computed using Ewald summation.
  7:   3: ! Implemented within the GENRIGID framework.
  8: ! Implemented within the GENRIGID framework for rigid bodies. 
  9:  
 10: ! Gradients wrt lattice parameters are computed when BOXDERIV keyword used. This 
 11: ! subroutine is for triclinic systems. Use BENZGENRIGIDEWALD_ORTHO for orthorhombic 
 12: ! cells. 
 13: ! ----------------------------------------------------------------------------- 
 14:   4: 
 15:       SUBROUTINE BENZGENRIGIDEWALD(X, G, ENERGY, GTEST)  5:       SUBROUTINE BENZGENRIGIDEWALD(X, G, ENERGY, GTEST)
 16:   6: 
 17:       USE COMMONS, ONLY: NATOMS, NCARBON, RBSTLA, RHOCC0, RHOCC10, RHOCC20, &  7:       USE COMMONS, ONLY: NATOMS, NCARBON, RBSTLA, RHOCC0, RHOCC10, RHOCC20, &
 18:      &                   RHOHH0, RHOHH10, RHOHH20, RHOCH0, RHOC10H, RHOCH10, RHOC20H, &  8:      &                   RHOHH0, RHOHH10, RHOHH20, RHOCH0, RHOC10H, RHOCH10, RHOC20H, &
 19:      &                   RHOCH20, ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ, &  9:      &                   RHOCH20, ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ
 20:      &                   EWALDREALC, BOX_PARAMS, BOX_PARAMSGRAD 
 21:  10: 
 22:       ! adapted to the genrigid framework 11:       ! dj337: PAHA adapted to the genrigid framework
 23:       USE GENRIGID, ONLY: NRIGIDBODY, ATOMRIGIDCOORDT, TRANSFORMCTORIGID, NSITEPERBODY, & 12:       USE GENRIGID, ONLY: NRIGIDBODY, ATOMRIGIDCOORDT, TRANSFORMCTORIGID, NSITEPERBODY, &
 24:      &                    MAXSITE, SITESRIGIDBODY, TRANSFORMRIGIDTOC, TRANSFORMGRAD, INVERSEMATRIX 13:      &                    MAXSITE, SITESRIGIDBODY, TRANSFORMRIGIDTOC, TRANSFORMGRAD
 25:  14: 
 26:       ! use Ewald summation to compute electrostatics 15:       ! dj337: use Ewald summation to compute electrostatics
 27:       USE EWALD 16:       USE EWALD
 28:       ! fractional coordinates, triclinic cells, box derivatives 
 29:       USE CARTDIST 
 30:       USE BOX_DERIVATIVES 
 31:  17: 
 32:       IMPLICIT NONE 18:       IMPLICIT NONE
 33:  19: 
 34:       INTEGER          :: I, J, K, J1, J2, J3, J4, J5, J6, J7, J8, OFFSET, FCT(6), L, M, N, IDX 20:       INTEGER          :: I, J, K, J1, J2, J3, J4, J5, J6, J7, J8, OFFSET, FCT(6) 
 35:       INTEGER          :: NEWALDREAL(3) 
 36:       DOUBLE PRECISION :: X(3*NATOMS) 21:       DOUBLE PRECISION :: X(3*NATOMS)
 37:       DOUBLE PRECISION, INTENT(OUT) :: G(3*NATOMS) 22:       DOUBLE PRECISION, INTENT(OUT) :: G(3*NATOMS)
 38:       DOUBLE PRECISION :: XR(3*NATOMS), XC(3*NATOMS), G3C(3*NATOMS), G3(3*NATOMS) 23:       DOUBLE PRECISION :: XR(3*NATOMS), XC(3*NATOMS), G3C(3*NATOMS), G3(3*NATOMS), graddum(3*natoms)
 39:       DOUBLE PRECISION, INTENT(OUT) :: ENERGY 24:       DOUBLE PRECISION, INTENT(OUT) :: ENERGY
 40:       DOUBLE PRECISION :: R2, R6, ABSRIJ, DVDR, ENERGY1, ENERGY2, ENERGY3 25:       DOUBLE PRECISION :: R2, R6, ABSRIJ, DVDR, ENERGY1, ENERGY2, ENERGY3, diff, eplus, eminus
 41:       DOUBLE PRECISION :: DMPFCT_SHIFT, EXPFCT_SHIFT, VSHIFT1, VSHIFT2, EWALDREALC2 26:       DOUBLE PRECISION :: DMPFCT_SHIFT, EXPFCT_SHIFT, VSHIFT1, VSHIFT2, EWALDREALC2
 42:       DOUBLE PRECISION :: RI(3), RR(3), RSS(3), NR(3), P(3), EI(3), EJ(3), FRIJ(3), TIJ(3), TJI(3)  27:       DOUBLE PRECISION :: RI(3), RSS(3), RSSMIN(3), NR(3), P(3), EI(3), EJ(3), FRIJ(3), TIJ(3), TJI(3) 
 43:       DOUBLE PRECISION :: R(MAXSITE*NRIGIDBODY,3), E(3*MAXSITE*NRIGIDBODY,3), xdum(3*natoms) 28:       DOUBLE PRECISION :: R(MAXSITE*NRIGIDBODY,3), E(3*MAXSITE*NRIGIDBODY,3)
 44:       DOUBLE PRECISION :: DR1(MAXSITE*NRIGIDBODY,3), DR2(MAXSITE*NRIGIDBODY,3), DR3(MAXSITE*NRIGIDBODY,3) 29:       DOUBLE PRECISION :: DR1(MAXSITE*NRIGIDBODY,3), DR2(MAXSITE*NRIGIDBODY,3), DR3(MAXSITE*NRIGIDBODY,3)
 45:       DOUBLE PRECISION :: DE1(3*MAXSITE*NRIGIDBODY,3), DE2(3*MAXSITE*NRIGIDBODY,3), DE3(3*MAXSITE*NRIGIDBODY,3) 30:       DOUBLE PRECISION :: DE1(3*MAXSITE*NRIGIDBODY,3), DE2(3*MAXSITE*NRIGIDBODY,3), DE3(3*MAXSITE*NRIGIDBODY,3)
 46:       DOUBLE PRECISION :: RMI(3,3), DRMI1(3,3), DRMI2(3,3), DRMI3(3,3), DCADR(3), DCBDR(3) 31:       DOUBLE PRECISION :: RMI(3,3), DRMI1(3,3), DRMI2(3,3), DRMI3(3,3), DCADR(3), DCBDR(3)
 47:       DOUBLE PRECISION :: RHOCC, RHOHH, RHOCH, COSTA, COSTB, DMPFCT, DDMPDR, EXPFCT  32:       DOUBLE PRECISION :: RHOCC, RHOHH, RHOCH, COSTA, COSTB, DMPFCT, DDMPDR, EXPFCT 
 48:       DOUBLE PRECISION :: DRIJDPI(3), DRIJDPJ(3), DCADPI(3), DCBDPI(3), DCADPJ(3), DCBDPJ(3) 33:       DOUBLE PRECISION :: DRIJDPI(3), DRIJDPJ(3), DCADPI(3), DCBDPI(3), DCADPJ(3), DCBDPJ(3)
 49:       DOUBLE PRECISION :: H(3,3), H_grad(3,3,6), H_inverse(3,3), rrfrac(3), rssfracmin(3), rrcom(3), rcomfrac(3) 
 50:       double precision :: rrcomfrac(3), rcomfracmin(3), rssfrac(3), vol, v_fact, dv_fact(3), c(3), s(3) 
 51:       double precision :: reciplatvec(3,3), reciplatvec_grad(3,3,6) 
 52:       DOUBLE PRECISION, PARAMETER :: B = 1.6485D0 34:       DOUBLE PRECISION, PARAMETER :: B = 1.6485D0
 53:       double precision, parameter :: pi = 3.141592654d0 35:       LOGICAL          :: GTEST
 54:       integer, parameter          :: image_cutoff = 5 
 55:       LOGICAL          :: GTEST, keep_angles 
 56:  
 57:       ! check if combination of triclinic cell angles is realistic 
 58:       if (boxderivt) then 
 59:          keep_angles = check_angles(box_params(4:6)) 
 60:          if (.not.keep_angles) then 
 61:             ! reject the structure if unrealistic cell angles 
 62:             call reject(energy, g) 
 63:             return 
 64:          endif 
 65:       endif 
 66:  
 67:       call build_H(H, H_grad, gtest) ! H matrix 
 68:       call inversematrix(H, H_inverse) ! inverse of H matrix 
 69:       call get_volume(vol) ! cell volume 
 70:       call get_reciplatvec(reciplatvec,reciplatvec_grad, .false.) ! reciprocal lattice vectors 
 71:  
 72:       ! figure out how many lattice vectors to sum over 
 73:       newaldreal(1) = floor(ewaldrealc*dsqrt(sum(reciplatvec(1,:)**2))/(2.0d0*pi) + 0.5d0) 
 74:       newaldreal(2) = floor(ewaldrealc*dsqrt(sum(reciplatvec(2,:)**2))/(2.0d0*pi) + 0.5d0) 
 75:       newaldreal(3) = floor(ewaldrealc*dsqrt(sum(reciplatvec(3,:)**2))/(2.0d0*pi) + 0.5d0) 
 76:  
 77:       ! reject structure if would have to sum over more than five lattice vectors 
 78:       ! NOTE: this is because cells have tendency to flatten out... it takes a long time 
 79:       ! to compute these structures and there are probably equivalent ones of a more 
 80:       ! regular shape 
 81:       if (boxderivt) then 
 82:          if (.not. all(newaldreal.le.image_cutoff)) then 
 83:             call reject(energy, g) 
 84:             return 
 85:          endif 
 86:       endif 
 87:  36: 
 88:       ! factorials 37:       ! factorials
 89:       FCT(1) = 1; FCT(2) = 2; FCT(3) = 6; FCT(4) = 24; FCT(5) = 120; FCT(6) = 720 38:       FCT(1) = 1; FCT(2) = 2; FCT(3) = 6; FCT(4) = 24; FCT(5) = 120; FCT(6) = 720
 90:       ! initialize energy values 39:       ! initialize energy values
 91:       ! energy1 is due to short-range anisotropic interactions 40:       ! energy1 is due to short-range anisotropic interactions
 92:       ! energy2 is due to damped dispersion 41:       ! energy2 is due to damped dispersion
 93:       ! energy3 is due to long-range electrostatics (computed using Ewald) 42:       ! energy3 is due to long-range electrostatics (computed using Ewald)
 94:       ENERGY = 0.D0; ENERGY1 = 0.D0; ENERGY2 = 0.D0; ENERGY3 = 0.D0 43:       ENERGY = 0.D0; ENERGY1 = 0.D0; ENERGY2 = 0.D0; ENERGY3 = 0.D0
 95:  44: 
 96:       ! initialize gradient if GTEST true 45:       ! initialize gradient if GTEST true
 97:       IF (GTEST) G(:) = 0.D0 46:       IF (GTEST) G(:) = 0.D0
 98:       IF (GTEST) G3C(:) = 0.D0 47:       IF (GTEST) G3C(:) = 0.D0
 99:  48: 
100:       ! dj337: check if input coordinates are cartesian 49:       ! dj337: check if input coordinates are cartesian
101:       ! assumes ATOMRIGIDCOORDT is correct 50:       ! assumes ATOMRIGIDCOORDT is correct
102:       IF (ATOMRIGIDCOORDT) THEN ! if input is cartesian 51:       IF (ATOMRIGIDCOORDT) THEN ! if input is cartesian
103:          ! convert to rigidbody coordinates 52:          ! convert to rigidbody coordinates
104:          XR(:) = 0.D0 53:          XR(:) = 0.D0
105:          CALL TRANSFORMCTORIGID(X, XR) 54:          CALL TRANSFORMCTORIGID(X, XR)
106:          if (boxderivt) then 55:          X(:) = XR(:)
107:             call frac2cart_rb_tri(nrigidbody, xdum, xr, H) 
108:             x(:) = xdum(:) 
109:          else 
110:             x(:) = xr(:) 
111:          endif 
112:       ENDIF 56:       ENDIF
113:  57: 
114:       if (boxderivt) then 58:       EWALDREALC2 = EWALDREALC**2
115:          ! compute v factor 
116:          c(:) = dcos(box_params(4:6)) 
117:          s(:) = dsin(box_params(4:6)) 
118:          ! v_fact is factor related to volume 
119:          v_fact = dsqrt(1.0d0 - c(1)**2-c(2)**2-c(3)**2 + 2.0d0*c(1)*c(2)*c(3)) 
120:          dv_fact(1) = s(1)*(c(1) - c(2)*c(3))/v_fact 
121:          dv_fact(2) = s(2)*(c(2) - c(1)*c(3))/v_fact 
122:          dv_fact(3) = s(3)*(c(3) - c(1)*c(2))/v_fact 
123:       endif 
124:  
125:       EWALDREALC2 = EWALDREALC**2 ! real-space cutoff 
126:  59: 
127:       ! OFFSET is number of CoM coords (3*NRIGIDBODY) 60:       ! OFFSET is number of CoM coords (3*NRIGIDBODY)
128:       OFFSET     = 3*NRIGIDBODY 61:       OFFSET     = 3*NRIGIDBODY
129:  62: 
130:       ! Computing Cartesian coordinates for the system.   63:       ! Computing Cartesian coordinates for the system.  
131:       DO J1 = 1, NRIGIDBODY 64:       DO J1 = 1, NRIGIDBODY
132:  65: 
133:          J3 = 3*J1 66:          J3 = 3*J1
134:          J5 = OFFSET + J3 67:          J5 = OFFSET + J3
135:          ! CoM coords for rigid body J1 68:          ! CoM coords for rigid body J1
157:                ! calculate derivative wrt coordinates 90:                ! calculate derivative wrt coordinates
158:                DR1(J4,:) = MATMUL(DRMI1(:,:),SITESRIGIDBODY(J2,:,J1)) 91:                DR1(J4,:) = MATMUL(DRMI1(:,:),SITESRIGIDBODY(J2,:,J1))
159:                DR2(J4,:) = MATMUL(DRMI2(:,:),SITESRIGIDBODY(J2,:,J1)) 92:                DR2(J4,:) = MATMUL(DRMI2(:,:),SITESRIGIDBODY(J2,:,J1))
160:                DR3(J4,:) = MATMUL(DRMI3(:,:),SITESRIGIDBODY(J2,:,J1)) 93:                DR3(J4,:) = MATMUL(DRMI3(:,:),SITESRIGIDBODY(J2,:,J1))
161:  94: 
162:                ! calculate derivative wrt local axis 95:                ! calculate derivative wrt local axis
163:                DE1(J4,:) = MATMUL(DRMI1(:,:),RBSTLA(J2,:)) 96:                DE1(J4,:) = MATMUL(DRMI1(:,:),RBSTLA(J2,:))
164:                DE2(J4,:) = MATMUL(DRMI2(:,:),RBSTLA(J2,:)) 97:                DE2(J4,:) = MATMUL(DRMI2(:,:),RBSTLA(J2,:))
165:                DE3(J4,:) = MATMUL(DRMI3(:,:),RBSTLA(J2,:)) 98:                DE3(J4,:) = MATMUL(DRMI3(:,:),RBSTLA(J2,:))
166:  99: 
167:             ENDIF ! gtest100:             ENDIF
168: 101: 
169:          ENDDO ! sites102:          ENDDO
170: 103: 
171:       ENDDO ! rigid bodies104:       ENDDO
172: 105: 
173:       ! Now compute the actual potential.106:       ! Now compute the actual potential.
174:       ! loop over rigid bodies (A)107:       ! loop over rigid bodies (A)
175:       DO J1 = 1, NRIGIDBODY - 1108:       DO J1 = 1, NRIGIDBODY - 1
176: 109: 
177:          J3 = 3*J1110:          J3 = 3*J1
178:          J5 = OFFSET + J3111:          J5 = OFFSET + J3
179:          ! CoM coords for rigid body J1112:          ! CoM coords for rigid body J1
180:          RI(:)  = X(J3-2:J3)113:          RI(:)  = X(J3-2:J3)
181: 114: 
193:                J4 = 3*J2126:                J4 = 3*J2
194:                J6 = OFFSET + J4127:                J6 = OFFSET + J4
195: 128: 
196:                ! loop over sites in the rigid body J2129:                ! loop over sites in the rigid body J2
197:                DO J = 1, NSITEPERBODY(J2)130:                DO J = 1, NSITEPERBODY(J2)
198: 131: 
199:                   ! J8 is index for site J132:                   ! J8 is index for site J
200:                   J8     = MAXSITE*(J2-1) + J133:                   J8     = MAXSITE*(J2-1) + J
201:                   ! EJ is Z-axis for site J134:                   ! EJ is Z-axis for site J
202:                   EJ(:)  = E(J8,:)135:                   EJ(:)  = E(J8,:)
203:                   rr(:) = r(j7,:) - r(j8,:)136:                   RSS(:) = R(J7,:) - R(J8,:)
204:                   ! convert to fractional coordinates 
205:                   rrfrac(:) = matmul(H_inverse, rr(:)) 
206:                   ! minimum image convention137:                   ! minimum image convention
207:                   rssfracmin(1) = rrfrac(1) - anint(rrfrac(1))138:                   RSSMIN(1) = RSS(1) - BOXLX*ANINT(RSS(1)/BOXLX)
208:                   rssfracmin(2) = rrfrac(2) - anint(rrfrac(2))139:                   RSSMIN(2) = RSS(2) - BOXLY*ANINT(RSS(2)/BOXLY)
209:                   rssfracmin(3) = rrfrac(3) - anint(rrfrac(3))140:                   RSSMIN(3) = RSS(3) - BOXLZ*ANINT(RSS(3)/BOXLZ)
210: 141:                   R2     = DOT_PRODUCT(RSSMIN(:),RSSMIN(:))
211:                   if (gtest.and.boxderivt) then142:                   ! check if distance within cutoff
212:                      ! get center of mass separation vector143:                   IF (R2 < EWALDREALC2) THEN
213:                      rrcom(:) = x(j3-2:j3) - x(j4-2:j4)144:                      !print *, j7, j8
214:                      ! convert to fractional coordinates145:                      !print *, 'r: ', rss(:3)
215:                      rrcomfrac(:) = matmul(H_inverse, rrcom(:))146:                      !print *, 'rmin: ', rssmin(:3)
216:                      ! minimum image convention147:                      ! ABSRIJ is site-site separation between I and J
217:                      rcomfracmin(1) = rrcomfrac(1) - anint(rrfrac(1))148:                      ABSRIJ = DSQRT(R2)
218:                      rcomfracmin(2) = rrcomfrac(2) - anint(rrfrac(2))149:                      ! NR is unit site-site vector from sites I to J
219:                      rcomfracmin(3) = rrcomfrac(3) - anint(rrfrac(3))150:                      NR(:)  = RSSMIN(:)/ABSRIJ
220:                   endif151:                      R2     = 1.D0/R2
221: 152:                      R6     = R2*R2*R2
222:                   ! sum over lattice vectors153:    
223:                   do l = -newaldreal(1), newaldreal(1)154: !     CALCULATE THE DISPERSION DAMPING FACTOR
224:                   rssfrac(1) = rssfracmin(1) + l155:    
225: 156:                      ! initialize sum for the damping function and vertical shift
226:                      do m = -newaldreal(2), newaldreal(2)157:                      DMPFCT = 1.D0
227:                      rssfrac(2) = rssfracmin(2) + m158:                      DMPFCT_SHIFT = 1.D0
228: 159:                      ! initialize sum for the derivative of damping function
229:                         do n = -newaldreal(3), newaldreal(3)160:                      DDMPDR = B
230:                         rssfrac(3) = rssfracmin(3) + n161:    
231: 162:                      ! calculate sums
232:                         ! convert to absolute coordinates163:                      DO K = 1, 6
233:                         rss(:) = matmul(H, rssfrac(:))164:    
234: 165:                         DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K))
235:                         ! get COM vector166:                         DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K))
236:                         if (gtest.and.boxderivt) then167:                         IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1))
237:                            rcomfrac(1) = rcomfracmin(1) + l168:    
238:                            rcomfrac(2) = rcomfracmin(2) + m169:                      END DO
239:                            rcomfrac(3) = rcomfracmin(3) + n170:    
240:                         endif171:                      EXPFCT = DEXP(-B*ABSRIJ)
 172:                      EXPFCT_SHIFT = DEXP(-B*EWALDREALC)
 173:                      ! DDMPDR is derivative of damping function with factor 1/Rab
 174:                      DDMPDR = (B*EXPFCT*DMPFCT - EXPFCT*DDMPDR)/ABSRIJ
 175:                      ! DMPFCT is damping function
 176:                      DMPFCT = 1.D0 - EXPFCT*DMPFCT
 177:                      ! DMPFCT_SHIFT is vertical shift for damping function
 178:                      DMPFCT_SHIFT = 1.D0 - EXPFCT_SHIFT*DMPFCT_SHIFT
 179:    
 180: !     NOW CALCULATE RHOAB
 181:    
 182:                      ! calculate cos(theta) 
 183:                      COSTA      =-DOT_PRODUCT(NR(:),EI(:))
 184:                      COSTB      = DOT_PRODUCT(NR(:),EJ(:))
 185:    
 186:                      ! calculate terms relevant to derivatives
 187:                      IF (GTEST) THEN
 188:    
 189:                         ! derivative of cos(theta) wrt r_ij
 190:                         DCADR(:)   =-EI(:)/ABSRIJ - COSTA*R2*RSSMIN(:)
 191:                         DCBDR(:)   = EJ(:)/ABSRIJ - COSTB*R2*RSSMIN(:)
 192:    
 193:                         ! derivative of r_ij wrt pi
 194:                         DRIJDPI(1) = DOT_PRODUCT(RSSMIN(:),DR1(J7,:))
 195:                         DRIJDPI(2) = DOT_PRODUCT(RSSMIN(:),DR2(J7,:))
 196:                         DRIJDPI(3) = DOT_PRODUCT(RSSMIN(:),DR3(J7,:))
 197:    
 198:                         ! derivative of r_ij wrt pj
 199:                         DRIJDPJ(1) =-DOT_PRODUCT(RSSMIN(:),DR1(J8,:))
 200:                         DRIJDPJ(2) =-DOT_PRODUCT(RSSMIN(:),DR2(J8,:))
 201:                         DRIJDPJ(3) =-DOT_PRODUCT(RSSMIN(:),DR3(J8,:))
 202:    
 203:                         ! derivative of cos(theta) wrt pi
 204:                         DCADPI(1)  =-DOT_PRODUCT(DR1(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE1(J7,:)) & 
 205:                                    - COSTA*R2*DRIJDPI(1)
 206:                         DCADPI(2)  =-DOT_PRODUCT(DR2(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE2(J7,:)) &
 207:                                    - COSTA*R2*DRIJDPI(2)
 208:                         DCADPI(3)  =-DOT_PRODUCT(DR3(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE3(J7,:)) &
 209:                                    - COSTA*R2*DRIJDPI(3)
 210:                         DCBDPI(1)  = DOT_PRODUCT(DR1(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(1)
 211:                         DCBDPI(2)  = DOT_PRODUCT(DR2(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(2)
 212:                         DCBDPI(3)  = DOT_PRODUCT(DR3(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(3)
 213:                    
 214:                         ! derivative of cos(theta) wrt pj
 215:                         DCADPJ(1)  = DOT_PRODUCT(DR1(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(1)
 216:                         DCADPJ(2)  = DOT_PRODUCT(DR2(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(2)
 217:                         DCADPJ(3)  = DOT_PRODUCT(DR3(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(3)
 218:    
 219:                         DCBDPJ(1)  =-DOT_PRODUCT(DR1(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE1(J8,:)) &
 220:                                    - COSTB*R2*DRIJDPJ(1)
 221:                         DCBDPJ(2)  =-DOT_PRODUCT(DR2(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE2(J8,:)) &
 222:                                    - COSTB*R2*DRIJDPJ(2)
 223:                         DCBDPJ(3)  =-DOT_PRODUCT(DR3(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE3(J8,:)) &
 224:                                    - COSTB*R2*DRIJDPJ(3)
 225:    
 226:                      ENDIF
 227:      
 228:                      ! calculate if I and J are both carbons 
 229:                      IF (I <= NCARBON .AND. J <= NCARBON) THEN
 230:    
 231:                         ! calculate rho_cc
 232:                         RHOCC   = RHOCC0 + RHOCC10*(COSTA + COSTB) + RHOCC20*(1.5D0*COSTA*COSTA & 
 233:                                 + 1.5D0*COSTB*COSTB - 1.D0)
 234:                         ! ENERGY1 is energy due to short-range anisotropic interactions
 235:                         ! calculate vertical shift for first term
 236:                         EXPFCT  = KKJ*DEXP(-ALPHACC*(ABSRIJ - RHOCC))
 237:                         VSHIFT1 = KKJ*DEXP(-ALPHACC*(EWALDREALC - RHOCC))
 238:                         ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1
 239:                         ! ENERGY2 is energy due to damped dispersion
 240:                         ! calculate vertical shift for second term
 241:                         VSHIFT2 = DC6CC*DMPFCT_SHIFT/(EWALDREALC**6)
 242:                         !print *, 'energy: ', dc6cc*dmpfct*r6
 243:                         ENERGY2 = ENERGY2 - DC6CC*DMPFCT*R6 + VSHIFT2
 244:    
 245:                         IF (GTEST) THEN
 246:    
 247:                            ! DVDR is derivative of dispersion damping factor energy with factor 1/Rab
 248:                            DVDR    = 6.D0*DC6CC*R6*R2*DMPFCT - DC6CC*R6*DDMPDR 
 249:                            !print *, 'grad: ', dvdr
 250:                            ! FRIJ is derivative of ENERGY1 wrt r_ij with factor 1/Rab
 251:                            FRIJ(:) = ALPHACC*EXPFCT*(-NR(:) + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADR(:) &
 252:                                    + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDR(:))
 253:                            ! TIJ is derivative of ENERGY1 wrt pi with factor 1/Rab
 254:                            TIJ(:)  = ALPHACC*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPI(:) &
 255:                                    + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPI(:))
 256:                            ! TJI is derivative of ENERGY1 wrt pj with factor 1/Rab
 257:                            TJI(:)  = ALPHACC*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPJ(:) &
 258:                                    + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPJ(:)) 
 259:    
 260:                         ENDIF
 261:    
 262:                      ! calculate if I and J are both hydorgens
 263:                      ELSEIF (I > NCARBON .AND. J > NCARBON) THEN
 264:    
 265:                         RHOHH  = RHOHH0 + RHOHH10*(COSTA + COSTB) + RHOHH20*(1.5D0*COSTA*COSTA      &
 266:                                + 1.5D0*COSTB*COSTB - 1.D0) 
 267:                         EXPFCT  = KKJ*DEXP(-ALPHAHH*(ABSRIJ - RHOHH))
 268:                         VSHIFT1 = KKJ*DEXP(-ALPHAHH*(EWALDREALC - RHOHH))
 269:                         ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1
 270:                         VSHIFT2 = DC6HH*DMPFCT_SHIFT/(EWALDREALC**6)
 271:                         !print *, 'energy: ', dc6hh*dmpfct*r6
 272:                         ENERGY2 = ENERGY2 - DC6HH*DMPFCT*R6 + VSHIFT2
 273:    
 274:                         IF (GTEST) THEN
 275:    
 276:                            DVDR    = 6.D0*DC6HH*R6*R2*DMPFCT - DC6HH*R6*DDMPDR 
 277:                            !print *, 'grad: ', dvdr
 278:                            FRIJ(:) = ALPHAHH*EXPFCT*(-NR(:) + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADR(:) &
 279:                                    + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDR(:))
 280:                            TIJ(:)  = ALPHAHH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPI(:) &
 281:                                    + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPI(:))
 282:                            TJI(:)  = ALPHAHH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPJ(:) &
 283:                                    + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPJ(:))
 284:    
 285:                         ENDIF
 286:    
 287:                      ! calculate if I is carbon and J is hydrogen
 288:                      ELSE IF (I <= NCARBON .AND. J > NCARBON) THEN 
 289:    
 290:                         RHOCH  = RHOCH0 + RHOC10H*COSTA + RHOCH10*COSTB + RHOC20H*(1.5D0*COSTA*COSTA &
 291:                                - 0.5D0) + RHOCH20*(1.5D0*COSTB*COSTB - 0.5D0)
 292:                         EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH))
 293:                         VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH))
 294:                         ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1
 295:                         VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6)
 296:                         !print *, 'energy: ', dc6ch*dmpfct*r6
 297:                         ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2
 298:    
 299:                         IF (GTEST) THEN
241:                      300:                      
242:                         R2     = DOT_PRODUCT(RSS(:),RSS(:))301:                            DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR 
243:                         ! check if distance within cutoff302:                            !print *, 'grad: ', dvdr
244:                         IF (R2 < EWALDREALC2) THEN303:                            FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) &
245:                            ! ABSRIJ is site-site separation between I and J304:                                    + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:))
246:                            ABSRIJ = DSQRT(R2)305:                            TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) &
247:                            ! NR is unit site-site vector from sites I to J306:                                    + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:))
248:                            NR(:)  = RSS(:)/ABSRIJ307:                            TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) &
249:                            R2     = 1.D0/R2308:                                    + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:))
250:                            R6     = R2*R2*R2309:    
251:          310:                         ENDIF
252:       !     CALCULATE THE DISPERSION DAMPING FACTOR311:    
253:          312:                      ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN
254:                            ! initialize sum for the damping function and vertical shift313:    
255:                            DMPFCT = 1.D0314:                         RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA &
256:                            DMPFCT_SHIFT = 1.D0315:                                - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0)
257:                            ! initialize sum for the derivative of damping function316:                         EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH))
258:                            DDMPDR = B317:                         VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH))
259:          318:                         ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1
260:                            ! calculate sums319:                         VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6)
261:                            DO K = 1, 6320:                         !print *, 'energy: ', dc6ch*dmpfct*r6
262:          321:                         ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2
263:                               DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K))322:    
264:                               DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K)) 
265:                               IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1)) 
266:           
267:                            END DO 
268:           
269:                            EXPFCT = DEXP(-B*ABSRIJ) 
270:                            EXPFCT_SHIFT = DEXP(-B*EWALDREALC) 
271:                            ! DDMPDR is derivative of damping function with factor 1/Rab 
272:                            DDMPDR = (B*EXPFCT*DMPFCT - EXPFCT*DDMPDR)/ABSRIJ 
273:                            ! DMPFCT is damping function 
274:                            DMPFCT = 1.D0 - EXPFCT*DMPFCT 
275:                            ! DMPFCT_SHIFT is vertical shift for damping function 
276:                            DMPFCT_SHIFT = 1.D0 - EXPFCT_SHIFT*DMPFCT_SHIFT 
277:           
278:       !     NOW CALCULATE RHOAB 
279:           
280:                            ! calculate cos(theta)  
281:                            COSTA      =-DOT_PRODUCT(NR(:),EI(:)) 
282:                            COSTB      = DOT_PRODUCT(NR(:),EJ(:)) 
283:           
284:                            ! calculate terms relevant to derivatives 
285:                            IF (GTEST) THEN 
286:           
287:                               ! derivative of cos(theta) wrt r_ij 
288:                               DCADR(:)   =-EI(:)/ABSRIJ - COSTA*R2*RSS(:) 
289:                               DCBDR(:)   = EJ(:)/ABSRIJ - COSTB*R2*RSS(:) 
290:           
291:                               ! derivative of r_ij wrt pi 
292:                               DRIJDPI(1) = DOT_PRODUCT(RSS(:),DR1(J7,:)) 
293:                               DRIJDPI(2) = DOT_PRODUCT(RSS(:),DR2(J7,:)) 
294:                               DRIJDPI(3) = DOT_PRODUCT(RSS(:),DR3(J7,:)) 
295:           
296:                               ! derivative of r_ij wrt pj 
297:                               DRIJDPJ(1) =-DOT_PRODUCT(RSS(:),DR1(J8,:)) 
298:                               DRIJDPJ(2) =-DOT_PRODUCT(RSS(:),DR2(J8,:)) 
299:                               DRIJDPJ(3) =-DOT_PRODUCT(RSS(:),DR3(J8,:)) 
300:           
301:                               ! derivative of cos(theta) wrt pi 
302:                               DCADPI(1)  =-DOT_PRODUCT(DR1(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE1(J7,:)) &  
303:                                          - COSTA*R2*DRIJDPI(1) 
304:                               DCADPI(2)  =-DOT_PRODUCT(DR2(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE2(J7,:)) & 
305:                                          - COSTA*R2*DRIJDPI(2) 
306:                               DCADPI(3)  =-DOT_PRODUCT(DR3(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE3(J7,:)) & 
307:                                          - COSTA*R2*DRIJDPI(3) 
308:                               DCBDPI(1)  = DOT_PRODUCT(DR1(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(1) 
309:                               DCBDPI(2)  = DOT_PRODUCT(DR2(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(2) 
310:                               DCBDPI(3)  = DOT_PRODUCT(DR3(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(3) 
311:                           
312:                               ! derivative of cos(theta) wrt pj 
313:                               DCADPJ(1)  = DOT_PRODUCT(DR1(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(1) 
314:                               DCADPJ(2)  = DOT_PRODUCT(DR2(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(2) 
315:                               DCADPJ(3)  = DOT_PRODUCT(DR3(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(3) 
316:           
317:                               DCBDPJ(1)  =-DOT_PRODUCT(DR1(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE1(J8,:)) & 
318:                                          - COSTB*R2*DRIJDPJ(1) 
319:                               DCBDPJ(2)  =-DOT_PRODUCT(DR2(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE2(J8,:)) & 
320:                                          - COSTB*R2*DRIJDPJ(2) 
321:                               DCBDPJ(3)  =-DOT_PRODUCT(DR3(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE3(J8,:)) & 
322:                                          - COSTB*R2*DRIJDPJ(3) 
323:           
324:                            ENDIF 
325:             
326:                            ! calculate if I and J are both carbons  
327:                            IF (I <= NCARBON .AND. J <= NCARBON) THEN 
328:           
329:                               ! calculate rho_cc 
330:                               RHOCC   = RHOCC0 + RHOCC10*(COSTA + COSTB) + RHOCC20*(1.5D0*COSTA*COSTA &  
331:                                       + 1.5D0*COSTB*COSTB - 1.D0) 
332:                               ! ENERGY1 is energy due to short-range anisotropic interactions 
333:                               ! calculate vertical shift for first term 
334:                               EXPFCT  = KKJ*DEXP(-ALPHACC*(ABSRIJ - RHOCC)) 
335:                               VSHIFT1 = KKJ*DEXP(-ALPHACC*(EWALDREALC - RHOCC)) 
336:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
337:                               ! ENERGY2 is energy due to damped dispersion 
338:                               ! calculate vertical shift for second term 
339:                               VSHIFT2 = DC6CC*DMPFCT_SHIFT/(EWALDREALC**6) 
340:                               ENERGY2 = ENERGY2 - DC6CC*DMPFCT*R6 + VSHIFT2 
341:           
342:                               IF (GTEST) THEN 
343:           
344:                                  ! DVDR is derivative of dispersion damping factor energy with factor 1/Rab 
345:                                  DVDR    = 6.D0*DC6CC*R6*R2*DMPFCT - DC6CC*R6*DDMPDR  
346:                                  ! FRIJ is derivative of ENERGY1 wrt r_ij with factor 1/Rab 
347:                                  FRIJ(:) = ALPHACC*EXPFCT*(-NR(:) + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADR(:) & 
348:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDR(:)) 
349:                                  ! TIJ is derivative of ENERGY1 wrt pi with factor 1/Rab 
350:                                  TIJ(:)  = ALPHACC*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPI(:) & 
351:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPI(:)) 
352:                                  ! TJI is derivative of ENERGY1 wrt pj with factor 1/Rab 
353:                                  TJI(:)  = ALPHACC*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPJ(:) & 
354:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPJ(:))  
355:           
356:                               ENDIF 
357:           
358:                            ! calculate if I and J are both hydorgens 
359:                            ELSEIF (I > NCARBON .AND. J > NCARBON) THEN 
360:           
361:                               RHOHH  = RHOHH0 + RHOHH10*(COSTA + COSTB) + RHOHH20*(1.5D0*COSTA*COSTA      & 
362:                                      + 1.5D0*COSTB*COSTB - 1.D0)  
363:                               EXPFCT  = KKJ*DEXP(-ALPHAHH*(ABSRIJ - RHOHH)) 
364:                               VSHIFT1 = KKJ*DEXP(-ALPHAHH*(EWALDREALC - RHOHH)) 
365:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
366:                               VSHIFT2 = DC6HH*DMPFCT_SHIFT/(EWALDREALC**6) 
367:                               ENERGY2 = ENERGY2 - DC6HH*DMPFCT*R6 + VSHIFT2 
368:           
369:                               IF (GTEST) THEN 
370:           
371:                                  DVDR    = 6.D0*DC6HH*R6*R2*DMPFCT - DC6HH*R6*DDMPDR  
372:                                  FRIJ(:) = ALPHAHH*EXPFCT*(-NR(:) + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADR(:) & 
373:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDR(:)) 
374:                                  TIJ(:)  = ALPHAHH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPI(:) & 
375:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPI(:)) 
376:                                  TJI(:)  = ALPHAHH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPJ(:) & 
377:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPJ(:)) 
378:           
379:                               ENDIF 
380:           
381:                            ! calculate if I is carbon and J is hydrogen 
382:                            ELSE IF (I <= NCARBON .AND. J > NCARBON) THEN  
383:           
384:                               RHOCH  = RHOCH0 + RHOC10H*COSTA + RHOCH10*COSTB + RHOC20H*(1.5D0*COSTA*COSTA & 
385:                                      - 0.5D0) + RHOCH20*(1.5D0*COSTB*COSTB - 0.5D0) 
386:                               EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
387:                               VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
388:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
389:                               VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
390:                               ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
391:           
392:                               IF (GTEST) THEN 
393:                             
394:                                  DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
395:                                  FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) & 
396:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:)) 
397:                                  TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) & 
398:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:)) 
399:                                  TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) & 
400:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:)) 
401:           
402:                               ENDIF 
403:           
404:                            ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN 
405:           
406:                               RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA & 
407:                                      - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0) 
408:                               EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
409:                               VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
410:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
411:                               VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
412:                               ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
413:           
414:                               IF (GTEST) THEN 
415:           
416:                                  DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
417:                                  FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) & 
418:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:)) 
419:                                  TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) & 
420:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:)) 
421:                                  TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) & 
422:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:)) 
423:           
424:                               ENDIF 
425:           
426:                            ENDIF 
427:           
428:                            IF (GTEST) THEN 
429:           
430:                               ! total gradient wrt CoM coords for rigid body J1 
431:                               G(J3-2:J3) = G(J3-2:J3) + DVDR*RSS(:) + FRIJ(:) 
432:                               ! total gradient wrt CoM coords for rigid body J2 
433:                               G(J4-2:J4) = G(J4-2:J4) - DVDR*RSS(:) - FRIJ(:) 
434:  
435:                               ! total gradient wrt AA coords for rigid body J1 
436:                               G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPI(:) + TIJ(:) 
437:                               ! total gradient wrt AA coords for rigid body J2 
438:                               G(J6-2:J6) = G(J6-2:J6) + DVDR*DRIJDPJ(:) + TJI(:) 
439:  
440:                               ! gradients wrt cell parameters 
441:                               if (boxderivt) then 
442:                                  do idx = 1, 6 
443:                                     box_paramsgrad(idx) = box_paramsgrad(idx) + dot_product((dvdr*rss(1:3) + frij(1:3)), matmul(H_grad(:,:,idx), rcomfrac(:))) 
444:                                  enddo 
445:                               endif ! box derivatives 
446:  
447:                            ENDIF ! gtest 
448:        
449:                         ENDIF ! within cutoff 
450:  
451:                      enddo ! n 
452:                   enddo ! m 
453:                enddo ! l 
454:  
455:                ENDDO ! sites j 
456:  
457:             ENDDO ! rigid bodies J 
458:   
459:          ENDDO ! sites i 
460:  
461:       ENDDO ! rigid bodies I 
462:  
463: ! INCLUDE CONTRIBUTION OF RIGID BODY WITH PERIODIC IMAGE OF ITSELF 
464:  
465:       ! loop over rigidbodies 
466:       do j1 = 1, nrigidbody 
467:          j3 = 3*j1 
468:          j5 = offset + j3 
469:          ri(:) = x(j3-2:j3) 
470:  
471:          ! loop over sites i 
472:          do i = 1, nsiteperbody(j1) 
473:             j7 = maxsite*(j1-1) + i 
474:             ei(:) = e(j7,:) 
475:  
476:             ! loop over sites j 
477:             do j = 1, nsiteperbody(j1) 
478:                j8 = maxsite*(j1-1) + j 
479:                ej(:) = e(j8,:) 
480:  
481:                ! site-site separation vector 
482:                rr(:) = r(j7,:) - r(j8,:) 
483:                ! convert to fractional 
484:                rrfrac(:) = matmul(H_inverse, rr(:)) 
485:  
486:                ! sum over lattice vectors 
487:                do l = -newaldreal(1), newaldreal(1) 
488:                   do m = -newaldreal(2), newaldreal(2) 
489:                      do n = -newaldreal(3), newaldreal(3) 
490:  
491:                      ! if not on same rigid body 
492:                      if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
493:  
494:                         rssfrac(1) = rrfrac(1) + l 
495:                         rssfrac(2) = rrfrac(2) + m 
496:                         rssfrac(3) = rrfrac(3) + n 
497:                         ! convert back to absolute 
498:                         rss(:) = matmul(H, rssfrac(:)) 
499:  
500:                         ! get vector between COM 
501:                         if (gtest.and.boxderivt) then 
502:                            rcomfrac(1) = l 
503:                            rcomfrac(2) = m 
504:                            rcomfrac(3) = n 
505:                         endif 
506:  
507:                         r2 = dot_product(rss(:), rss(:)) 
508:                         if (r2 < ewaldrealc2) then 
509:  
510:                         ! absolute site-site distance 
511:                         absrij = dsqrt(r2) 
512:                         nr(:) = rss(:)/absrij 
513:                         r2 = 1.d0/r2 
514:                         r6 = r2*r2*r2 
515:  
516:                         ! CALCULATE DISPERSION DAMPING FACTOR 
517:  
518:                         ! initialize sum for the damping function and vertical shift 
519:                         DMPFCT = 1.D0 
520:                         DMPFCT_SHIFT = 1.D0 
521:                         ! initialize sum for the derivative of damping function 
522:                         DDMPDR = B 
523:  
524:                         ! calculate sums 
525:                         DO K = 1, 6 
526:  
527:                            DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K)) 
528:                            DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K)) 
529:                            IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1)) 
530:  
531:                         END DO 
532:  
533:                         EXPFCT = DEXP(-B*ABSRIJ) 
534:                         EXPFCT_SHIFT = DEXP(-B*EWALDREALC) 
535:                         ! DDMPDR is derivative of damping function with factor 1/Rab 
536:                         DDMPDR = (B*EXPFCT*DMPFCT - EXPFCT*DDMPDR)/ABSRIJ 
537:                         ! DMPFCT is damping function 
538:                         DMPFCT = 1.D0 - EXPFCT*DMPFCT 
539:                         ! DMPFCT_SHIFT is vertical shift for damping function 
540:                         DMPFCT_SHIFT = 1.D0 - EXPFCT_SHIFT*DMPFCT_SHIFT 
541:  
542:                         ! CALCULATE RHOAB 
543:                         ! calculate cos(theta)  
544:                         COSTA      =-DOT_PRODUCT(NR(:),EI(:)) 
545:                         COSTB      = DOT_PRODUCT(NR(:),EJ(:)) 
546:  
547:                         ! calculate terms relevant to derivatives 
548:                         IF (GTEST) THEN323:                         IF (GTEST) THEN
549: 324:    
550:                            ! derivative of cos(theta) wrt r_ij325:                            DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR 
551:                            DCADR(:)   =-EI(:)/ABSRIJ - COSTA*R2*RSS(:)326:                            !print *, 'grad: ', dvdr
552:                            DCBDR(:)   = EJ(:)/ABSRIJ - COSTB*R2*RSS(:)327:                            FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) &
553: 328:                                    + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:))
554:                            ! derivative of r_ij wrt pi329:                            TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) &
555:                            DRIJDPI(1) = DOT_PRODUCT(RSS(:),DR1(J7,:))330:                                    + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:))
556:                            DRIJDPI(2) = DOT_PRODUCT(RSS(:),DR2(J7,:))331:                            TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) &
557:                            DRIJDPI(3) = DOT_PRODUCT(RSS(:),DR3(J7,:))332:                                    + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:))
558: 333:    
559:                            ! derivative of r_ij wrt pj 
560:                            DRIJDPJ(1) =-DOT_PRODUCT(RSS(:),DR1(J8,:)) 
561:                            DRIJDPJ(2) =-DOT_PRODUCT(RSS(:),DR2(J8,:)) 
562:                            DRIJDPJ(3) =-DOT_PRODUCT(RSS(:),DR3(J8,:)) 
563:  
564:                            ! derivative of cos(theta) wrt pi 
565:                            DCADPI(1)  =-DOT_PRODUCT(DR1(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE1(J7,:)) &  
566:                                       - COSTA*R2*DRIJDPI(1) 
567:                            DCADPI(2)  =-DOT_PRODUCT(DR2(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE2(J7,:)) & 
568:                                       - COSTA*R2*DRIJDPI(2) 
569:                            DCADPI(3)  =-DOT_PRODUCT(DR3(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE3(J7,:)) & 
570:                                       - COSTA*R2*DRIJDPI(3) 
571:                            DCBDPI(1)  = DOT_PRODUCT(DR1(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(1) 
572:                            DCBDPI(2)  = DOT_PRODUCT(DR2(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(2) 
573:                            DCBDPI(3)  = DOT_PRODUCT(DR3(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(3) 
574:  
575:                            ! derivative of cos(theta) wrt pj 
576:                            DCADPJ(1)  = DOT_PRODUCT(DR1(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(1) 
577:                            DCADPJ(2)  = DOT_PRODUCT(DR2(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(2) 
578:                            DCADPJ(3)  = DOT_PRODUCT(DR3(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(3) 
579:  
580:                            DCBDPJ(1)  =-DOT_PRODUCT(DR1(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE1(J8,:)) & 
581:                                       - COSTB*R2*DRIJDPJ(1) 
582:                            DCBDPJ(2)  =-DOT_PRODUCT(DR2(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE2(J8,:)) & 
583:                                       - COSTB*R2*DRIJDPJ(2) 
584:                            DCBDPJ(3)  =-DOT_PRODUCT(DR3(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE3(J8,:)) & 
585:                                       - COSTB*R2*DRIJDPJ(3) 
586:  
587:                         ENDIF334:                         ENDIF
 335:    
 336:                      ENDIF
 337:    
 338:                      IF (GTEST) THEN
 339:    
 340:                         ! total gradient wrt CoM coords for rigid body J1
 341:                         G(J3-2:J3) = G(J3-2:J3) + DVDR*RSSmin(:) + FRIJ(:)
 342:                         ! total gradient wrt CoM coords for rigid body J2
 343:                         G(J4-2:J4) = G(J4-2:J4) - DVDR*RSSmin(:) - FRIJ(:)
 344:    
 345:                         ! total gradient wrt AA coords for rigid body J1
 346:                         G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPI(:) + TIJ(:)
 347:                         ! total gradient wrt AA coords for rigid body J2
 348:                         G(J6-2:J6) = G(J6-2:J6) + DVDR*DRIJDPJ(:) + TJI(:)
 349:    
 350:                      ENDIF
588: 351: 
589:                         ! calculate if I and J are both carbons 352:                   ENDIF
590:                         IF (I <= NCARBON .AND. J <= NCARBON) THEN 
591: 353: 
592:                            ! calculate rho_cc354:                ENDDO
593:                            RHOCC   = RHOCC0 + RHOCC10*(COSTA + COSTB) + RHOCC20*(1.5D0*COSTA*COSTA &  
594:                                    + 1.5D0*COSTB*COSTB - 1.D0) 
595:                            ! ENERGY1 is energy due to short-range anisotropic interactions 
596:                            ! calculate vertical shift for first term 
597:                            EXPFCT  = KKJ*DEXP(-ALPHACC*(ABSRIJ - RHOCC)) 
598:                            VSHIFT1 = KKJ*DEXP(-ALPHACC*(EWALDREALC - RHOCC)) 
599:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
600:                            ! ENERGY2 is energy due to damped dispersion 
601:                            ! calculate vertical shift for second term 
602:                            VSHIFT2 = DC6CC*DMPFCT_SHIFT/(EWALDREALC**6) 
603:                            ENERGY2 = ENERGY2 - DC6CC*DMPFCT*R6 + VSHIFT2 
604:  
605:                            IF (GTEST) THEN 
606:  
607:                               ! DVDR is derivative of dispersion damping factor energy with factor 1/Rab 
608:                               DVDR    = 6.D0*DC6CC*R6*R2*DMPFCT - DC6CC*R6*DDMPDR  
609:                               ! FRIJ is derivative of ENERGY1 wrt r_ij with factor 1/Rab 
610:                               FRIJ(:) = ALPHACC*EXPFCT*(-NR(:) + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADR(:) & 
611:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDR(:)) 
612:                               ! TIJ is derivative of ENERGY1 wrt pi with factor 1/Rab 
613:                               TIJ(:)  = ALPHACC*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPI(:) & 
614:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPI(:)) 
615:                               ! TJI is derivative of ENERGY1 wrt pj with factor 1/Rab 
616:                               TJI(:)  = ALPHACC*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPJ(:) & 
617:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPJ(:))  
618:  
619:                            ENDIF 
620:  
621:                         ! calculate if I and J are both hydorgens 
622:                         ELSEIF (I > NCARBON .AND. J > NCARBON) THEN 
623:  
624:                            RHOHH  = RHOHH0 + RHOHH10*(COSTA + COSTB) + RHOHH20*(1.5D0*COSTA*COSTA      & 
625:                                   + 1.5D0*COSTB*COSTB - 1.D0) 
626:                            EXPFCT  = KKJ*DEXP(-ALPHAHH*(ABSRIJ - RHOHH)) 
627:                            VSHIFT1 = KKJ*DEXP(-ALPHAHH*(EWALDREALC - RHOHH)) 
628:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
629:                            VSHIFT2 = DC6HH*DMPFCT_SHIFT/(EWALDREALC**6) 
630:                            ENERGY2 = ENERGY2 - DC6HH*DMPFCT*R6 + VSHIFT2 
631:  
632:                            IF (GTEST) THEN 
633:  
634:                               DVDR    = 6.D0*DC6HH*R6*R2*DMPFCT - DC6HH*R6*DDMPDR  
635:                               FRIJ(:) = ALPHAHH*EXPFCT*(-NR(:) + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADR(:) & 
636:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDR(:)) 
637:                               TIJ(:)  = ALPHAHH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPI(:) & 
638:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPI(:)) 
639:                               TJI(:)  = ALPHAHH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPJ(:) & 
640:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPJ(:)) 
641:  
642:                            ENDIF 
643:  
644:                         ! calculate if I is carbon and J is hydrogen 
645:                         ELSE IF (I <= NCARBON .AND. J > NCARBON) THEN  
646:  
647:                            RHOCH  = RHOCH0 + RHOC10H*COSTA + RHOCH10*COSTB + RHOC20H*(1.5D0*COSTA*COSTA & 
648:                                   - 0.5D0) + RHOCH20*(1.5D0*COSTB*COSTB - 0.5D0) 
649:                            EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
650:                            VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
651:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
652:                            VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
653:                            ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
654:  
655:                            IF (GTEST) THEN 
656:  
657:                               DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
658:                               FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) & 
659:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:)) 
660:                               TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) & 
661:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:)) 
662:                               TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) & 
663:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:)) 
664:  
665:                            ENDIF 
666:  
667:                         ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN 
668:  
669:                            RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA & 
670:                                   - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0) 
671:                            EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
672:                            VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
673:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
674:                            VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
675:                            ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
676:  
677:                            IF (GTEST) THEN 
678:  
679:                               DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
680:                               FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) & 
681:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:)) 
682:                               TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) & 
683:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:)) 
684:                               TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) & 
685:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:)) 
686: 355: 
687:                            ENDIF356:             ENDDO
688: 357:  
689:                         ENDIF358:          ENDDO
690:  
691:  
692:                         IF (GTEST) THEN 
693: 359: 
694:                            ! total gradient wrt AA coords for rigid body J1360:       ENDDO
695:                            G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPI(:) + TIJ(:) 
696:                            ! total gradient wrt AA coords for rigid body J2 
697:                            G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPJ(:) + TJI(:) 
698:  
699:                            ! gradients wrt cell parameters 
700:                            if (boxderivt) then 
701:                               do idx = 1, 6 
702:                                     box_paramsgrad(idx) = box_paramsgrad(idx) + dot_product((dvdr*rss(1:3) + frij(1:3)), matmul(H_grad(:,:,idx), rcomfrac(:))) 
703:                               enddo 
704:                            endif ! box derivatives 
705:  
706:                         ENDIF ! gtest 
707:                         endif ! central box 
708:                     endif ! within cutoff 
709:                   enddo ! n 
710:                enddo ! m 
711:             enddo ! l 
712:             enddo ! sites j 
713:          enddo ! sites i 
714:       enddo ! rigid bodies 
715: 361: 
716:       ! convert to cartesian coordinates362:       ! convert to cartesian coordinates
717:       XC(:) = 0.D0363:       XC(:) = 0.D0
718:       if (boxderivt) then 
719:          xdum(:) = x(:) 
720:          call cart2frac_rb_tri(nrigidbody, xdum, x, H_inverse) 
721:       endif 
722:       CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XC, X)364:       CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XC, X)
723:       ! restore cartesian rigid body coordinates 
724:       if (boxderivt) x(:) = xdum(:) 
725: 365: 
726:       ! ENERGY3 and G3 are energy and gradient due to electrostatics366:       ! ENERGY3 and G3 are energy and gradient due to electrostatics
727:       ! computed using Ewald summation367:       ! computed using Ewald summation
728:       CALL EWALDSUM(1, XC, G3C, ENERGY3, GTEST)368:       CALL EWALDSUM(1, XC, G3C, ENERGY3, GTEST)
729: 369: 
 370: ! check analytical and numerical gradients of Ewald terms in cartesian coords
 371: !      diff = 1.0d-6
 372: !      print *, 'analytic and numerical gradients:'
 373: !      do j1=1, 3*natoms
 374: !         xc(j1) = xc(j1) + diff
 375: !         call ewaldsum(1, xc, graddum, eplus, .false.)
 376: !         xc(j1) = xc(j1) - 2.0d0*diff
 377: !         call ewaldsum(1, xc, graddum, eminus, .false.)
 378: !         xc(j1) = xc(j1) + diff
 379: !         if ((abs(g3c(j1)).ne.0.0d0).and.(100.0d0*abs(g3c(j1)-(eplus-eminus)/(2.0d0*diff))/abs(g3c(j1)).gt.1.0d0)) then
 380: !            print *, j1, g3c(j1), (eplus-eminus)/(2.0d0*diff)
 381: !         else
 382: !            print *, 'fine: ', j1, g3c(j1), (eplus-eminus)/(2.0d0*diff)
 383: !         endif
 384: !      enddo
 385: 
730:       ! convert Ewald contribution of gradient to rigidbody coordinates386:       ! convert Ewald contribution of gradient to rigidbody coordinates
731:       IF (GTEST) G3(:) = 0.D0387:       IF (GTEST) G3(:) = 0.D0
732:       CALL TRANSFORMGRAD(G3C, X, G3)388:       CALL TRANSFORMGRAD(G3C, X, G3)
733: 389: 
 390:       !energy = energy2*2625.499d0
 391:       !if (gtest) g(:) = g(:)*2625.499d0
 392:       !energy = (energy3)*2625.499d0
 393:       !if (gtest) g(:) = g3(:)*2625.499d0
 394:       ENERGY = (ENERGY1 + ENERGY2 + ENERGY3)*2625.499D0 
 395:       IF (GTEST) G(:) = (G(:) + G3(:))*2625.499D0
 396: 
734:       ! dj337: if input was cartesian, convert back to cartesian397:       ! dj337: if input was cartesian, convert back to cartesian
735:       ! assumes ATOMRIGIDCOORDT is correct398:       ! assumes ATOMRIGIDCOORDT is correct
736:       IF (ATOMRIGIDCOORDT) THEN399:       IF (ATOMRIGIDCOORDT) THEN
737: 400: 
738:          ! convert to cartesian coordinates401:          ! convert to cartesian coordinates
739:          if (boxderivt) then402:          XR(:) = 0.D0
740:             xdum(:) = x(:) 
741:             call cart2frac_rb_tri(nrigidbody, xdum, x, H_inverse) 
742:          endif 
743:          CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XR, X)403:          CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XR, X)
744:          X(:) = XR(:)404:          X(:) = XR(:)
745:       ENDIF 
746:  
747:       ! add WCA-style repulsion to keep cell volume away from zero 
748:       if (boxderivt) call constrain_volume(v_fact, dv_fact, energy1, box_paramsgrad(4:6), gtest) 
749: 405: 
750:       ! sum energies / gradients and convert to kJ/mol406:       ENDIF
751:       ENERGY = (ENERGY1 + ENERGY2 + ENERGY3)*2625.499D0 
752:       IF (GTEST) G(:) = (G(:) + G3(:))*2625.499D0 
753:       if (gtest) box_paramsgrad(1:6) = box_paramsgrad(1:6)*2625.499D0 
754: 407: 
755:       END SUBROUTINE BENZGENRIGIDEWALD408:       END SUBROUTINE BENZGENRIGIDEWALD
756: 409: 
757: !     ----------------------------------------------------------------------------------------------410: !     ----------------------------------------------------------------------------------------------
758: !411: !
759: !      SUBROUTINE DEFPAHARIGID()412: !      SUBROUTINE DEFPAHARIGID()
760: !413: !
761: !      USE COMMONS, ONLY: RHOCC0, RHOCC10, RHOCC20,  RHOHH0, RHOHH10, RHOHH20, RHOCH0, RHOC10H, RHOCH10, RHOC20H, RHOCH20, &414: !      USE COMMONS, ONLY: RHOCC0, RHOCC10, RHOCC20,  RHOHH0, RHOHH10, RHOHH20, RHOCH0, RHOC10H, RHOCH10, RHOC20H, RHOCH20, &
762: !                         ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ, CCKJ415: !                         ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ, CCKJ
763: !416: !


r33142/benzgenrigid_ortho.f90 2017-08-08 12:30:09.554309614 +0100 r33141/benzgenrigid_ortho.f90 2017-08-08 12:30:13.626364054 +0100
  1: ! -----------------------------------------------------------------------------  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/GMIN/source/benzgenrigid_ortho.f90' in revision 33141
  2: ! dj337 
  3: ! Anisotropic potential for periodic benzene systems. This subroutine is for 
  4: ! orthorhombic cells. See BENZGENRIGIDEWALD for more info. 
  5: ! ----------------------------------------------------------------------------- 
  6:  
  7:       SUBROUTINE BENZGENRIGIDEWALD_ORTHO(X, G, ENERGY, GTEST) 
  8:  
  9:       USE COMMONS, ONLY: NATOMS, NCARBON, RBSTLA, RHOCC0, RHOCC10, RHOCC20, & 
 10:      &                   RHOHH0, RHOHH10, RHOHH20, RHOCH0, RHOC10H, RHOCH10, RHOC20H, & 
 11:      &                   RHOCH20, ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ, & 
 12:      &                   EWALDREALC, BOX_PARAMS, BOX_PARAMSGRAD 
 13:  
 14:       ! adapted to the genrigid framework 
 15:       USE GENRIGID, ONLY: NRIGIDBODY, ATOMRIGIDCOORDT, TRANSFORMCTORIGID, NSITEPERBODY, & 
 16:      &                    MAXSITE, SITESRIGIDBODY, TRANSFORMRIGIDTOC, TRANSFORMGRAD 
 17:  
 18:       ! use Ewald summation to compute electrostatics 
 19:       USE EWALD 
 20:       USE CARTDIST 
 21:       USE BOX_DERIVATIVES 
 22:  
 23:       IMPLICIT NONE 
 24:  
 25:       INTEGER          :: I, J, K, J1, J2, J3, J4, J5, J6, J7, J8, OFFSET, FCT(6), L, M, N 
 26:       INTEGER          :: NEWALDREAL(3) 
 27:       DOUBLE PRECISION :: X(3*NATOMS) 
 28:       DOUBLE PRECISION, INTENT(OUT) :: G(3*NATOMS) 
 29:       DOUBLE PRECISION :: XR(3*NATOMS), XC(3*NATOMS), G3C(3*NATOMS), G3(3*NATOMS) 
 30:       DOUBLE PRECISION, INTENT(OUT) :: ENERGY 
 31:       DOUBLE PRECISION :: R2, R6, ABSRIJ, DVDR, ENERGY1, ENERGY2, ENERGY3 
 32:       DOUBLE PRECISION :: DMPFCT_SHIFT, EXPFCT_SHIFT, VSHIFT1, VSHIFT2, EWALDREALC2 
 33:       DOUBLE PRECISION :: RI(3), RR(3), RSS(3), NR(3), P(3), EI(3), EJ(3), FRIJ(3), TIJ(3), TJI(3)  
 34:       DOUBLE PRECISION :: R(MAXSITE*NRIGIDBODY,3), E(3*MAXSITE*NRIGIDBODY,3), xdum(3*natoms), rssmin(3) 
 35:       DOUBLE PRECISION :: DR1(MAXSITE*NRIGIDBODY,3), DR2(MAXSITE*NRIGIDBODY,3), DR3(MAXSITE*NRIGIDBODY,3) 
 36:       DOUBLE PRECISION :: DE1(3*MAXSITE*NRIGIDBODY,3), DE2(3*MAXSITE*NRIGIDBODY,3), DE3(3*MAXSITE*NRIGIDBODY,3) 
 37:       DOUBLE PRECISION :: RMI(3,3), DRMI1(3,3), DRMI2(3,3), DRMI3(3,3), DCADR(3), DCBDR(3) 
 38:       DOUBLE PRECISION :: RHOCC, RHOHH, RHOCH, COSTA, COSTB, DMPFCT, DDMPDR, EXPFCT, rcom(3), RRCOMMIN(3) 
 39:       DOUBLE PRECISION :: DRIJDPI(3), DRIJDPJ(3), DCADPI(3), DCBDPI(3), DCADPJ(3), DCBDPJ(3), rrcom(3) 
 40:       DOUBLE PRECISION, PARAMETER :: B = 1.6485D0 
 41:       integer, parameter          :: image_cutoff = 5 
 42:       LOGICAL          :: GTEST 
 43:  
 44:       ! figure out how many lattice vectors to sum over 
 45:       newaldreal(:) = floor(ewaldrealc/box_params(1:3) + 0.5d0) 
 46:  
 47:       ! reject structure if would have to sum over more than five lattice vectors 
 48:       if (boxderivt) then 
 49:          if (.not. all(newaldreal.le.image_cutoff)) then 
 50:             call reject(energy, g) 
 51:             return 
 52:          endif 
 53:       endif 
 54:  
 55:       ! factorials 
 56:       FCT(1) = 1; FCT(2) = 2; FCT(3) = 6; FCT(4) = 24; FCT(5) = 120; FCT(6) = 720 
 57:       ! initialize energy values 
 58:       ! energy1 is due to short-range anisotropic interactions 
 59:       ! energy2 is due to damped dispersion 
 60:       ! energy3 is due to long-range electrostatics (computed using Ewald) 
 61:       ENERGY = 0.D0; ENERGY1 = 0.D0; ENERGY2 = 0.D0; ENERGY3 = 0.D0 
 62:  
 63:       ! initialize gradient if GTEST true 
 64:       IF (GTEST) G(:) = 0.D0 
 65:       IF (GTEST) G3C(:) = 0.D0 
 66:  
 67:       ! dj337: check if input coordinates are cartesian 
 68:       ! assumes ATOMRIGIDCOORDT is correct 
 69:       IF (ATOMRIGIDCOORDT) THEN ! if input is cartesian 
 70:          ! convert to rigidbody coordinates 
 71:          XR(:) = 0.D0 
 72:          CALL TRANSFORMCTORIGID(X, XR) 
 73:          if (boxderivt) then 
 74:             call frac2cart_rb_ortho(nrigidbody, xdum, xr) 
 75:             x(:) = xdum(:) 
 76:          else 
 77:             x(:) = xr(:) 
 78:          endif 
 79:       ENDIF 
 80:  
 81:       EWALDREALC2 = EWALDREALC**2 ! real-space cutoff 
 82:  
 83:       ! OFFSET is number of CoM coords (3*NRIGIDBODY) 
 84:       OFFSET     = 3*NRIGIDBODY 
 85:  
 86:       ! Computing Cartesian coordinates for the system.   
 87:       DO J1 = 1, NRIGIDBODY 
 88:  
 89:          J3 = 3*J1 
 90:          J5 = OFFSET + J3 
 91:          ! CoM coords for rigid body J1 
 92:          RI = X(J3-2:J3) 
 93:          ! AA coords for rigid body J1 
 94:          P  = X(J5-2:J5) 
 95:  
 96:          ! calculates rotation matrix (RMI) 
 97:          ! also calculates derivatives if GTEST is true 
 98:          CALL RMDRVT(P, RMI, DRMI1, DRMI2, DRMI3, GTEST) 
 99:  
100:          ! loop over sites in the rigid body 
101:          DO J2 = 1, NSITEPERBODY(J1) 
102:  
103:             ! J4 is index for site J2 relative to a complete list of all sites in all rigid bodies 
104:             ! dj337: assumes that same number of sites per rigid body (i.e. NSITEPERBODY(J1) == MAXSITE) 
105:             J4      = MAXSITE*(J1-1) + J2 
106:             ! R(J4,:) contains Cartesian coordinates for site J4 
107:             R(J4,:) = RI(:) + MATMUL(RMI(:,:),SITESRIGIDBODY(J2,:,J1)) 
108:             ! E(J4,:) contains Z-axis in local axis system for site J4  
109:             E(J4,:) = MATMUL(RMI(:,:),RBSTLA(J2,:)) 
110:  
111:             IF (GTEST) THEN 
112:  
113:                ! calculate derivative wrt coordinates 
114:                DR1(J4,:) = MATMUL(DRMI1(:,:),SITESRIGIDBODY(J2,:,J1)) 
115:                DR2(J4,:) = MATMUL(DRMI2(:,:),SITESRIGIDBODY(J2,:,J1)) 
116:                DR3(J4,:) = MATMUL(DRMI3(:,:),SITESRIGIDBODY(J2,:,J1)) 
117:  
118:                ! calculate derivative wrt local axis 
119:                DE1(J4,:) = MATMUL(DRMI1(:,:),RBSTLA(J2,:)) 
120:                DE2(J4,:) = MATMUL(DRMI2(:,:),RBSTLA(J2,:)) 
121:                DE3(J4,:) = MATMUL(DRMI3(:,:),RBSTLA(J2,:)) 
122:  
123:             ENDIF 
124:  
125:          ENDDO 
126:  
127:       ENDDO 
128:  
129:       ! Now compute the actual potential. 
130:       ! loop over rigid bodies (A) 
131:       DO J1 = 1, NRIGIDBODY - 1 
132:  
133:          J3 = 3*J1 
134:          J5 = OFFSET + J3 
135:          ! CoM coords for rigid body J1 
136:          RI(:)  = X(J3-2:J3) 
137:  
138:          ! loop over sites in the rigid body J1 
139:          DO I = 1, NSITEPERBODY(J1) 
140:  
141:             ! J7 is index for site I 
142:             J7    = MAXSITE*(J1-1) + I 
143:             ! EI is Z-axis for site I 
144:             EI(:) = E(J7,:) 
145:  
146:             ! loop over rigid bodies (B)    
147:             DO J2 = J1 + 1, NRIGIDBODY 
148:  
149:                J4 = 3*J2 
150:                J6 = OFFSET + J4 
151:  
152:                ! loop over sites in the rigid body J2 
153:                DO J = 1, NSITEPERBODY(J2) 
154:  
155:                   ! J8 is index for site J 
156:                   J8     = MAXSITE*(J2-1) + J 
157:                   ! EJ is Z-axis for site J 
158:                   EJ(:)  = E(J8,:) 
159:                   rr(:) = r(j7,:) - r(j8,:) 
160:                   ! minimum image convention 
161:                   rssmin(1) = rr(1) - box_params(1)*anint(rr(1)/box_params(1)) 
162:                   rssmin(2) = rr(2) - box_params(2)*anint(rr(2)/box_params(2)) 
163:                   rssmin(3) = rr(3) - box_params(3)*anint(rr(3)/box_params(3)) 
164:  
165:                   if (gtest.and.boxderivt) then 
166:                      ! get center of mass separation vector 
167:                      rrcom(:) = x(j3-2:j3) - x(j4-2:j4) 
168:                      ! minimum image convention 
169:                      rrcommin(1) = rrcom(1) - box_params(1)*anint(rr(1)/box_params(1)) 
170:                      rrcommin(2) = rrcom(2) - box_params(2)*anint(rr(2)/box_params(2)) 
171:                      rrcommin(3) = rrcom(3) - box_params(3)*anint(rr(3)/box_params(3)) 
172:                   endif 
173:  
174:                   ! sum over lattice vectors 
175:                   do l = -newaldreal(1), newaldreal(1) 
176:                   rss(1) = rssmin(1) + box_params(1)*l 
177:  
178:                      do m = -newaldreal(2), newaldreal(2) 
179:                      rss(2) = rssmin(2) + box_params(2)*m 
180:  
181:                         do n = -newaldreal(3), newaldreal(3) 
182:                         rss(3) = rssmin(3) + box_params(3)*n 
183:  
184:                         ! get COM vector 
185:                         if (gtest.and.boxderivt) then 
186:                            rcom(1) = rrcommin(1) + box_params(1)*l 
187:                            rcom(2) = rrcommin(2) + box_params(2)*m 
188:                            rcom(3) = rrcommin(3) + box_params(3)*n 
189:                         endif 
190:                       
191:                         R2     = DOT_PRODUCT(RSS(:),RSS(:)) 
192:                         ! check if distance within cutoff 
193:                         IF (R2 < EWALDREALC2) THEN 
194:                            ! ABSRIJ is site-site separation between I and J 
195:                            ABSRIJ = DSQRT(R2) 
196:                            ! NR is unit site-site vector from sites I to J 
197:                            NR(:)  = RSS(:)/ABSRIJ 
198:                            R2     = 1.D0/R2 
199:                            R6     = R2*R2*R2 
200:           
201:       !     CALCULATE THE DISPERSION DAMPING FACTOR 
202:           
203:                            ! initialize sum for the damping function and vertical shift 
204:                            DMPFCT = 1.D0 
205:                            DMPFCT_SHIFT = 1.D0 
206:                            ! initialize sum for the derivative of damping function 
207:                            DDMPDR = B 
208:           
209:                            ! calculate sums 
210:                            DO K = 1, 6 
211:           
212:                               DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K)) 
213:                               DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K)) 
214:                               IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1)) 
215:           
216:                            END DO 
217:           
218:                            EXPFCT = DEXP(-B*ABSRIJ) 
219:                            EXPFCT_SHIFT = DEXP(-B*EWALDREALC) 
220:                            ! DDMPDR is derivative of damping function with factor 1/Rab 
221:                            DDMPDR = (B*EXPFCT*DMPFCT - EXPFCT*DDMPDR)/ABSRIJ 
222:                            ! DMPFCT is damping function 
223:                            DMPFCT = 1.D0 - EXPFCT*DMPFCT 
224:                            ! DMPFCT_SHIFT is vertical shift for damping function 
225:                            DMPFCT_SHIFT = 1.D0 - EXPFCT_SHIFT*DMPFCT_SHIFT 
226:           
227:       !     NOW CALCULATE RHOAB 
228:           
229:                            ! calculate cos(theta)  
230:                            COSTA      =-DOT_PRODUCT(NR(:),EI(:)) 
231:                            COSTB      = DOT_PRODUCT(NR(:),EJ(:)) 
232:           
233:                            ! calculate terms relevant to derivatives 
234:                            IF (GTEST) THEN 
235:           
236:                               ! derivative of cos(theta) wrt r_ij 
237:                               DCADR(:)   =-EI(:)/ABSRIJ - COSTA*R2*RSS(:) 
238:                               DCBDR(:)   = EJ(:)/ABSRIJ - COSTB*R2*RSS(:) 
239:           
240:                               ! derivative of r_ij wrt pi 
241:                               DRIJDPI(1) = DOT_PRODUCT(RSS(:),DR1(J7,:)) 
242:                               DRIJDPI(2) = DOT_PRODUCT(RSS(:),DR2(J7,:)) 
243:                               DRIJDPI(3) = DOT_PRODUCT(RSS(:),DR3(J7,:)) 
244:           
245:                               ! derivative of r_ij wrt pj 
246:                               DRIJDPJ(1) =-DOT_PRODUCT(RSS(:),DR1(J8,:)) 
247:                               DRIJDPJ(2) =-DOT_PRODUCT(RSS(:),DR2(J8,:)) 
248:                               DRIJDPJ(3) =-DOT_PRODUCT(RSS(:),DR3(J8,:)) 
249:           
250:                               ! derivative of cos(theta) wrt pi 
251:                               DCADPI(1)  =-DOT_PRODUCT(DR1(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE1(J7,:)) &  
252:                                          - COSTA*R2*DRIJDPI(1) 
253:                               DCADPI(2)  =-DOT_PRODUCT(DR2(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE2(J7,:)) & 
254:                                          - COSTA*R2*DRIJDPI(2) 
255:                               DCADPI(3)  =-DOT_PRODUCT(DR3(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE3(J7,:)) & 
256:                                          - COSTA*R2*DRIJDPI(3) 
257:                               DCBDPI(1)  = DOT_PRODUCT(DR1(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(1) 
258:                               DCBDPI(2)  = DOT_PRODUCT(DR2(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(2) 
259:                               DCBDPI(3)  = DOT_PRODUCT(DR3(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(3) 
260:                           
261:                               ! derivative of cos(theta) wrt pj 
262:                               DCADPJ(1)  = DOT_PRODUCT(DR1(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(1) 
263:                               DCADPJ(2)  = DOT_PRODUCT(DR2(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(2) 
264:                               DCADPJ(3)  = DOT_PRODUCT(DR3(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(3) 
265:           
266:                               DCBDPJ(1)  =-DOT_PRODUCT(DR1(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE1(J8,:)) & 
267:                                          - COSTB*R2*DRIJDPJ(1) 
268:                               DCBDPJ(2)  =-DOT_PRODUCT(DR2(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE2(J8,:)) & 
269:                                          - COSTB*R2*DRIJDPJ(2) 
270:                               DCBDPJ(3)  =-DOT_PRODUCT(DR3(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE3(J8,:)) & 
271:                                          - COSTB*R2*DRIJDPJ(3) 
272:           
273:                            ENDIF 
274:             
275:                            ! calculate if I and J are both carbons  
276:                            IF (I <= NCARBON .AND. J <= NCARBON) THEN 
277:           
278:                               ! calculate rho_cc 
279:                               RHOCC   = RHOCC0 + RHOCC10*(COSTA + COSTB) + RHOCC20*(1.5D0*COSTA*COSTA &  
280:                                       + 1.5D0*COSTB*COSTB - 1.D0) 
281:                               ! ENERGY1 is energy due to short-range anisotropic interactions 
282:                               ! calculate vertical shift for first term 
283:                               EXPFCT  = KKJ*DEXP(-ALPHACC*(ABSRIJ - RHOCC)) 
284:                               VSHIFT1 = KKJ*DEXP(-ALPHACC*(EWALDREALC - RHOCC)) 
285:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
286:                               ! ENERGY2 is energy due to damped dispersion 
287:                               ! calculate vertical shift for second term 
288:                               VSHIFT2 = DC6CC*DMPFCT_SHIFT/(EWALDREALC**6) 
289:                               ENERGY2 = ENERGY2 - DC6CC*DMPFCT*R6 + VSHIFT2 
290:           
291:                               IF (GTEST) THEN 
292:           
293:                                  ! DVDR is derivative of dispersion damping factor energy with factor 1/Rab 
294:                                  DVDR    = 6.D0*DC6CC*R6*R2*DMPFCT - DC6CC*R6*DDMPDR  
295:                                  ! FRIJ is derivative of ENERGY1 wrt r_ij with factor 1/Rab 
296:                                  FRIJ(:) = ALPHACC*EXPFCT*(-NR(:) + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADR(:) & 
297:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDR(:)) 
298:                                  ! TIJ is derivative of ENERGY1 wrt pi with factor 1/Rab 
299:                                  TIJ(:)  = ALPHACC*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPI(:) & 
300:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPI(:)) 
301:                                  ! TJI is derivative of ENERGY1 wrt pj with factor 1/Rab 
302:                                  TJI(:)  = ALPHACC*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPJ(:) & 
303:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPJ(:))  
304:           
305:                               ENDIF 
306:           
307:                            ! calculate if I and J are both hydorgens 
308:                            ELSEIF (I > NCARBON .AND. J > NCARBON) THEN 
309:           
310:                               RHOHH  = RHOHH0 + RHOHH10*(COSTA + COSTB) + RHOHH20*(1.5D0*COSTA*COSTA      & 
311:                                      + 1.5D0*COSTB*COSTB - 1.D0)  
312:                               EXPFCT  = KKJ*DEXP(-ALPHAHH*(ABSRIJ - RHOHH)) 
313:                               VSHIFT1 = KKJ*DEXP(-ALPHAHH*(EWALDREALC - RHOHH)) 
314:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
315:                               VSHIFT2 = DC6HH*DMPFCT_SHIFT/(EWALDREALC**6) 
316:                               ENERGY2 = ENERGY2 - DC6HH*DMPFCT*R6 + VSHIFT2 
317:           
318:                               IF (GTEST) THEN 
319:           
320:                                  DVDR    = 6.D0*DC6HH*R6*R2*DMPFCT - DC6HH*R6*DDMPDR  
321:                                  FRIJ(:) = ALPHAHH*EXPFCT*(-NR(:) + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADR(:) & 
322:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDR(:)) 
323:                                  TIJ(:)  = ALPHAHH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPI(:) & 
324:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPI(:)) 
325:                                  TJI(:)  = ALPHAHH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPJ(:) & 
326:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPJ(:)) 
327:           
328:                               ENDIF 
329:           
330:                            ! calculate if I is carbon and J is hydrogen 
331:                            ELSE IF (I <= NCARBON .AND. J > NCARBON) THEN  
332:           
333:                               RHOCH  = RHOCH0 + RHOC10H*COSTA + RHOCH10*COSTB + RHOC20H*(1.5D0*COSTA*COSTA & 
334:                                      - 0.5D0) + RHOCH20*(1.5D0*COSTB*COSTB - 0.5D0) 
335:                               EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
336:                               VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
337:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
338:                               VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
339:                               ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
340:           
341:                               IF (GTEST) THEN 
342:                             
343:                                  DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
344:                                  FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) & 
345:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:)) 
346:                                  TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) & 
347:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:)) 
348:                                  TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) & 
349:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:)) 
350:           
351:                               ENDIF 
352:           
353:                            ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN 
354:           
355:                               RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA & 
356:                                      - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0) 
357:                               EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
358:                               VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
359:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
360:                               VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
361:                               ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
362:           
363:                               IF (GTEST) THEN 
364:           
365:                                  DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
366:                                  FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) & 
367:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:)) 
368:                                  TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) & 
369:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:)) 
370:                                  TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) & 
371:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:)) 
372:           
373:                               ENDIF 
374:           
375:                            ENDIF 
376:           
377:                            IF (GTEST) THEN 
378:           
379:                               ! total gradient wrt CoM coords for rigid body J1 
380:                               G(J3-2:J3) = G(J3-2:J3) + DVDR*RSS(:) + FRIJ(:) 
381:                               ! total gradient wrt CoM coords for rigid body J2 
382:                               G(J4-2:J4) = G(J4-2:J4) - DVDR*RSS(:) - FRIJ(:) 
383:  
384:                               ! total gradient wrt AA coords for rigid body J1 
385:                               G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPI(:) + TIJ(:) 
386:                               ! total gradient wrt AA coords for rigid body J2 
387:                               G(J6-2:J6) = G(J6-2:J6) + DVDR*DRIJDPJ(:) + TJI(:) 
388:  
389:                               ! gradients wrt cell lengths 
390:                               if (boxderivt) box_paramsgrad(1:3) = box_paramsgrad(1:3) + (dvdr*rss(1:3)+frij(1:3))*rcom(1:3)/box_params(1:3) 
391:  
392:                            ENDIF ! gtest 
393:        
394:                         ENDIF ! within cutoff 
395:  
396:                      enddo ! n 
397:                   enddo ! m 
398:                enddo ! l 
399:  
400:                ENDDO ! sites j 
401:  
402:             ENDDO ! rigid bodies J 
403:   
404:          ENDDO ! sites i 
405:  
406:       ENDDO ! rigid bodies I 
407:  
408: ! INCLUDE CONTRIBUTION OF RIGID BODY WITH PERIODIC IMAGE OF ITSELF 
409:  
410:       ! loop over rigidbodies 
411:       do j1 = 1, nrigidbody 
412:          j3 = 3*j1 
413:          j5 = offset + j3 
414:          ri(:) = x(j3-2:j3) 
415:  
416:          ! loop over sites i 
417:          do i = 1, nsiteperbody(j1) 
418:             j7 = maxsite*(j1-1) + i 
419:             ei(:) = e(j7,:) 
420:  
421:             ! loop over sites j 
422:             do j = 1, nsiteperbody(j1) 
423:                j8 = maxsite*(j1-1) + j 
424:                ej(:) = e(j8,:) 
425:  
426:                ! site-site separation vector 
427:                rr(:) = r(j7,:) - r(j8,:) 
428:  
429:                ! sum over lattice vectors 
430:                do l = -newaldreal(1), newaldreal(1) 
431:                   do m = -newaldreal(2), newaldreal(2) 
432:                      do n = -newaldreal(3), newaldreal(3) 
433:  
434:                      ! if not in same rigid body 
435:                      if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
436:  
437:                         rss(1) = rr(1) + box_params(1)*l 
438:                         rss(2) = rr(2) + box_params(2)*m 
439:                         rss(3) = rr(3) + box_params(3)*n 
440:  
441:                         ! get COM vector 
442:                         if (gtest.and.boxderivt) then 
443:                            rcom(1) = box_params(1)*l 
444:                            rcom(2) = box_params(2)*m 
445:                            rcom(3) = box_params(3)*n 
446:                         endif 
447:  
448:                         r2 = dot_product(rss(:), rss(:)) 
449:                         if (r2 < ewaldrealc2) then 
450:  
451:                         ! absolute site-site distance 
452:                         absrij = dsqrt(r2) 
453:                         nr(:) = rss(:)/absrij 
454:                         r2 = 1.d0/r2 
455:                         r6 = r2*r2*r2 
456:  
457:                         ! CALCULATE DISPERSION DAMPING FACTOR 
458:  
459:                         ! initialize sum for the damping function and vertical shift 
460:                         DMPFCT = 1.D0 
461:                         DMPFCT_SHIFT = 1.D0 
462:                         ! initialize sum for the derivative of damping function 
463:                         DDMPDR = B 
464:  
465:                         ! calculate sums 
466:                         DO K = 1, 6 
467:  
468:                            DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K)) 
469:                            DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K)) 
470:                            IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1)) 
471:  
472:                         END DO 
473:  
474:                         EXPFCT = DEXP(-B*ABSRIJ) 
475:                         EXPFCT_SHIFT = DEXP(-B*EWALDREALC) 
476:                         ! DDMPDR is derivative of damping function with factor 1/Rab 
477:                         DDMPDR = (B*EXPFCT*DMPFCT - EXPFCT*DDMPDR)/ABSRIJ 
478:                         ! DMPFCT is damping function 
479:                         DMPFCT = 1.D0 - EXPFCT*DMPFCT 
480:                         ! DMPFCT_SHIFT is vertical shift for damping function 
481:                         DMPFCT_SHIFT = 1.D0 - EXPFCT_SHIFT*DMPFCT_SHIFT 
482:  
483:                         ! CALCULATE RHOAB 
484:                         ! calculate cos(theta)  
485:                         COSTA      =-DOT_PRODUCT(NR(:),EI(:)) 
486:                         COSTB      = DOT_PRODUCT(NR(:),EJ(:)) 
487:  
488:                         ! calculate terms relevant to derivatives 
489:                         IF (GTEST) THEN 
490:  
491:                            ! derivative of cos(theta) wrt r_ij 
492:                            DCADR(:)   =-EI(:)/ABSRIJ - COSTA*R2*RSS(:) 
493:                            DCBDR(:)   = EJ(:)/ABSRIJ - COSTB*R2*RSS(:) 
494:  
495:                            ! derivative of r_ij wrt pi 
496:                            DRIJDPI(1) = DOT_PRODUCT(RSS(:),DR1(J7,:)) 
497:                            DRIJDPI(2) = DOT_PRODUCT(RSS(:),DR2(J7,:)) 
498:                            DRIJDPI(3) = DOT_PRODUCT(RSS(:),DR3(J7,:)) 
499:  
500:                            ! derivative of r_ij wrt pj 
501:                            DRIJDPJ(1) =-DOT_PRODUCT(RSS(:),DR1(J8,:)) 
502:                            DRIJDPJ(2) =-DOT_PRODUCT(RSS(:),DR2(J8,:)) 
503:                            DRIJDPJ(3) =-DOT_PRODUCT(RSS(:),DR3(J8,:)) 
504:  
505:                            ! derivative of cos(theta) wrt pi 
506:                            DCADPI(1)  =-DOT_PRODUCT(DR1(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE1(J7,:)) &  
507:                                       - COSTA*R2*DRIJDPI(1) 
508:                            DCADPI(2)  =-DOT_PRODUCT(DR2(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE2(J7,:)) & 
509:                                       - COSTA*R2*DRIJDPI(2) 
510:                            DCADPI(3)  =-DOT_PRODUCT(DR3(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE3(J7,:)) & 
511:                                       - COSTA*R2*DRIJDPI(3) 
512:                            DCBDPI(1)  = DOT_PRODUCT(DR1(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(1) 
513:                            DCBDPI(2)  = DOT_PRODUCT(DR2(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(2) 
514:                            DCBDPI(3)  = DOT_PRODUCT(DR3(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(3) 
515:  
516:                            ! derivative of cos(theta) wrt pj 
517:                            DCADPJ(1)  = DOT_PRODUCT(DR1(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(1) 
518:                            DCADPJ(2)  = DOT_PRODUCT(DR2(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(2) 
519:                            DCADPJ(3)  = DOT_PRODUCT(DR3(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(3) 
520:  
521:                            DCBDPJ(1)  =-DOT_PRODUCT(DR1(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE1(J8,:)) & 
522:                                       - COSTB*R2*DRIJDPJ(1) 
523:                            DCBDPJ(2)  =-DOT_PRODUCT(DR2(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE2(J8,:)) & 
524:                                       - COSTB*R2*DRIJDPJ(2) 
525:                            DCBDPJ(3)  =-DOT_PRODUCT(DR3(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE3(J8,:)) & 
526:                                       - COSTB*R2*DRIJDPJ(3) 
527:  
528:                         ENDIF 
529:  
530:                         ! calculate if I and J are both carbons  
531:                         IF (I <= NCARBON .AND. J <= NCARBON) THEN 
532:  
533:                            ! calculate rho_cc 
534:                            RHOCC   = RHOCC0 + RHOCC10*(COSTA + COSTB) + RHOCC20*(1.5D0*COSTA*COSTA &  
535:                                    + 1.5D0*COSTB*COSTB - 1.D0) 
536:                            ! ENERGY1 is energy due to short-range anisotropic interactions 
537:                            ! calculate vertical shift for first term 
538:                            EXPFCT  = KKJ*DEXP(-ALPHACC*(ABSRIJ - RHOCC)) 
539:                            VSHIFT1 = KKJ*DEXP(-ALPHACC*(EWALDREALC - RHOCC)) 
540:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
541:                            ! ENERGY2 is energy due to damped dispersion 
542:                            ! calculate vertical shift for second term 
543:                            VSHIFT2 = DC6CC*DMPFCT_SHIFT/(EWALDREALC**6) 
544:                            ENERGY2 = ENERGY2 - DC6CC*DMPFCT*R6 + VSHIFT2 
545:  
546:                            IF (GTEST) THEN 
547:  
548:                               ! DVDR is derivative of dispersion damping factor energy with factor 1/Rab 
549:                               DVDR    = 6.D0*DC6CC*R6*R2*DMPFCT - DC6CC*R6*DDMPDR  
550:                               ! FRIJ is derivative of ENERGY1 wrt r_ij with factor 1/Rab 
551:                               FRIJ(:) = ALPHACC*EXPFCT*(-NR(:) + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADR(:) & 
552:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDR(:)) 
553:                               ! TIJ is derivative of ENERGY1 wrt pi with factor 1/Rab 
554:                               TIJ(:)  = ALPHACC*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPI(:) & 
555:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPI(:)) 
556:                               ! TJI is derivative of ENERGY1 wrt pj with factor 1/Rab 
557:                               TJI(:)  = ALPHACC*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPJ(:) & 
558:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPJ(:))  
559:  
560:                            ENDIF 
561:  
562:                         ! calculate if I and J are both hydorgens 
563:                         ELSEIF (I > NCARBON .AND. J > NCARBON) THEN 
564:  
565:                            RHOHH  = RHOHH0 + RHOHH10*(COSTA + COSTB) + RHOHH20*(1.5D0*COSTA*COSTA      & 
566:                                   + 1.5D0*COSTB*COSTB - 1.D0) 
567:                            EXPFCT  = KKJ*DEXP(-ALPHAHH*(ABSRIJ - RHOHH)) 
568:                            VSHIFT1 = KKJ*DEXP(-ALPHAHH*(EWALDREALC - RHOHH)) 
569:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
570:                            VSHIFT2 = DC6HH*DMPFCT_SHIFT/(EWALDREALC**6) 
571:                            ENERGY2 = ENERGY2 - DC6HH*DMPFCT*R6 + VSHIFT2 
572:  
573:                            IF (GTEST) THEN 
574:  
575:                               DVDR    = 6.D0*DC6HH*R6*R2*DMPFCT - DC6HH*R6*DDMPDR  
576:                               FRIJ(:) = ALPHAHH*EXPFCT*(-NR(:) + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADR(:) & 
577:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDR(:)) 
578:                               TIJ(:)  = ALPHAHH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPI(:) & 
579:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPI(:)) 
580:                               TJI(:)  = ALPHAHH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPJ(:) & 
581:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPJ(:)) 
582:  
583:                            ENDIF 
584:  
585:                         ! calculate if I is carbon and J is hydrogen 
586:                         ELSE IF (I <= NCARBON .AND. J > NCARBON) THEN  
587:  
588:                            RHOCH  = RHOCH0 + RHOC10H*COSTA + RHOCH10*COSTB + RHOC20H*(1.5D0*COSTA*COSTA & 
589:                                   - 0.5D0) + RHOCH20*(1.5D0*COSTB*COSTB - 0.5D0) 
590:                            EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
591:                            VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
592:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
593:                            VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
594:                            ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
595:  
596:                            IF (GTEST) THEN 
597:  
598:                               DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
599:                               FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) & 
600:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:)) 
601:                               TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) & 
602:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:)) 
603:                               TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) & 
604:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:)) 
605:  
606:                            ENDIF 
607:  
608:                         ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN 
609:  
610:                            RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA & 
611:                                   - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0) 
612:                            EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
613:                            VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
614:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
615:                            VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
616:                            ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
617:  
618:                            IF (GTEST) THEN 
619:  
620:                               DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
621:                               FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) & 
622:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:)) 
623:                               TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) & 
624:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:)) 
625:                               TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) & 
626:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:)) 
627:  
628:                            ENDIF 
629:  
630:                         ENDIF 
631:  
632:  
633:                         IF (GTEST) THEN 
634:  
635:                            ! total gradient wrt AA coords for rigid body J1 
636:                            G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPI(:) + TIJ(:) 
637:                            ! total gradient wrt AA coords for rigid body J2 
638:                            G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPJ(:) + TJI(:) 
639:  
640:                            ! gradient wrt cell lengths 
641:                            if (boxderivt) box_paramsgrad(1:3) = box_paramsgrad(1:3) + (dvdr*rss(1:3)+frij(1:3))*rcom(1:3)/box_params(1:3) 
642:  
643:                         ENDIF ! gtest 
644:                         endif ! central box 
645:                     endif ! within cutoff 
646:                   enddo ! n 
647:                enddo ! m 
648:             enddo ! l 
649:             enddo ! sites j 
650:          enddo ! sites i 
651:       enddo ! rigid bodies 
652:  
653:       ! convert to cartesian coordinates 
654:       XC(:) = 0.D0 
655:       if (boxderivt) then 
656:          xdum(:) = x(:) 
657:          call cart2frac_rb_ortho(nrigidbody, xdum, x) 
658:       endif 
659:       CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XC, X) 
660:       ! restore cartesian rigid body coordinates 
661:       if (boxderivt) x(:) = xdum(:) 
662:  
663:       ! ENERGY3 and G3 are energy and gradient due to electrostatics 
664:       ! computed using Ewald summation 
665:       CALL EWALDSUM(1, XC, G3C, ENERGY3, GTEST) 
666:  
667:       ! convert Ewald contribution of gradient to rigidbody coordinates 
668:       IF (GTEST) G3(:) = 0.D0 
669:       CALL TRANSFORMGRAD(G3C, X, G3) 
670:  
671:       ! dj337: if input was cartesian, convert back to cartesian 
672:       ! assumes ATOMRIGIDCOORDT is correct 
673:       IF (ATOMRIGIDCOORDT) THEN 
674:  
675:          ! convert to cartesian coordinates 
676:          if (boxderivt) then 
677:             xdum(:) = x(:) 
678:             call cart2frac_rb_ortho(nrigidbody, xdum, x) 
679:          endif 
680:          CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XR, X) 
681:          X(:) = XR(:) 
682:       ENDIF 
683:  
684:       ! sum energies / gradients and convert to kJ/mol 
685:       ENERGY = (ENERGY1 + ENERGY2 + ENERGY3)*2625.499D0 
686:       IF (GTEST) G(:) = (G(:) + G3(:))*2625.499D0 
687:       if (gtest) box_paramsgrad(1:3) = box_paramsgrad(1:3)*2625.499D0 
688:  
689:       END SUBROUTINE BENZGENRIGIDEWALD_ORTHO 
690:  
691: !     ---------------------------------------------------------------------------------------------- 


r33142/box_derivatives.f90 2017-08-08 12:30:09.774312555 +0100 r33141/box_derivatives.f90 2017-08-08 12:30:13.850367049 +0100
  1: module box_derivatives  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/GMIN/source/box_derivatives.f90' in revision 33141
  2: use commons, only: natoms, box_params, box_paramsgrad 
  3: use genrigid, only: degfreedoms, nrigidbody 
  4: use cartdist 
  5:  
  6: implicit none 
  7:  
  8: public :: check_angles 
  9:  
 10: ! dj337: module to convert gradient from absolute to  
 11: ! fractional coordinates to perform basin-hopping on 
 12: ! periodic systems with varying lattice parameters 
 13:  
 14: contains 
 15:  
 16: ! ----------------------------------------------------------------------------------- 
 17: ! VARIABLES 
 18: ! x: atomic positions in absolute coordinates 
 19: ! xfrac: atomic positions in fractional coordinates 
 20: ! grad: gradient of energy wrt absolute atomic positions 
 21: ! gradfrac: gradient of energy wrt fractional atomic positions 
 22:  
 23: ! xr: absolute rigid body (COM+AA) coordinates 
 24: ! xrfrac: fractional rigid body coordinates 
 25: ! gradr: gradient of energy wrt absolute rigid body coordinates 
 26: ! gradrfrac: gradient of energy wrt fractional rigid body coordinates 
 27: !!! NOTE: AA coordinates are the same in absolute and fractional coordinate systems 
 28:  
 29: ! box_params: unit cell lengths and angles, in radians (a, b, c, alpha, beta, gamma) 
 30: ! box_paramsgrad: gradient of energy wrt unit cell parameters 
 31:  
 32: ! H: matrix that transforms between fractional and absolute coordinates; 
 33: !    x = H*xfrac 
 34: !    first index corresponds to row, second to column 
 35: ! H_grad: derivatives of the H matrix wrt cell parameters; 
 36: !    first index corresponds to row, second to column, third to cell parameter 
 37: ! H_inverse: inverse of the H matrix 
 38: ! ----------------------------------------------------------------------------------- 
 39:  
 40: ! CONVERTS ATOMIC POSITIONS FROM ABSOLUTE TO FRACTIONAL COORDINATES. Wrapper subroutine 
 41: ! that calls appropriate subroutine depending on whether atomistic or rigidbody 
 42: ! coordinates, orthorhombic or tricilinc unit cell. 
 43:  
 44:       subroutine cart2frac(x, xfrac, H_inverse) 
 45:  
 46:       use commons, only: ortho 
 47:       use genrigid, only: rigidinit, atomrigidcoordt, inversematrix 
 48:  
 49:       implicit none 
 50:  
 51:       double precision, intent(in)           :: x(3*natoms) 
 52:       double precision, intent(out)          :: xfrac(3*natoms) 
 53:       double precision, intent(in), optional :: H_inverse(3,3) 
 54:       double precision                       :: H(3,3), H_grad(3,3,6), H_inv(3,3) 
 55:  
 56:       ! orthorhombic cells 
 57:       if (ortho) then 
 58:          if (rigidinit.and.(.not.atomrigidcoordt)) then 
 59:             call cart2frac_rb_ortho(nrigidbody, x, xfrac) 
 60:          else 
 61:             call cart2frac_ortho(x, xfrac) 
 62:          endif 
 63:       ! triclinic cells 
 64:       else 
 65:          ! compute inverse of H matrix if not given 
 66:          if (present(H_inverse)) then 
 67:             H_inv = H_inverse 
 68:          else 
 69:             call build_H(H, H_grad, .false.) 
 70:             call inversematrix(H, H_inv) 
 71:          endif 
 72:          ! convert coordinates 
 73:          if (rigidinit.and.(.not.atomrigidcoordt)) then 
 74:             call cart2frac_rb_tri(nrigidbody, x, xfrac, H_inv) 
 75:          else 
 76:             call cart2frac_tri(x, xfrac, H_inv) 
 77:          endif 
 78:       endif 
 79:  
 80:       end subroutine cart2frac 
 81:  
 82: ! ----------------------------------------------------------------------------------- 
 83:  
 84: ! CONVERTS ATOMIC POSITIONS FROM FRACTIONAL TO ABSOLUTE COORDINATES. Wrapper subroutine 
 85: ! that calls appropriate subroutine depending on whether atomistic or rigidbody 
 86: ! coordinates, orthorhombic or tricilinc unit cell. 
 87:  
 88:       subroutine frac2cart(x, xfrac, H) 
 89:  
 90:       use commons, only: ortho 
 91:       use genrigid, only: rigidinit, atomrigidcoordt 
 92:  
 93:       implicit none 
 94:  
 95:       double precision, intent(in)           :: xfrac(3*natoms) 
 96:       double precision, intent(out)          :: x(3*natoms) 
 97:       double precision, intent(in), optional :: H(3,3) 
 98:       double precision                       :: H_mat(3,3), H_grad(3,3,6) 
 99:  
100:       ! orthorhombic cell 
101:       if (ortho) then 
102:          if (rigidinit.and.(.not.atomrigidcoordt)) then 
103:             call frac2cart_rb_ortho(nrigidbody, x, xfrac) 
104:          else 
105:             call frac2cart_ortho(x, xfrac) 
106:          endif 
107:       ! triclinic cell 
108:       else 
109:          ! compute H matrix if not given 
110:          if (present(H)) then 
111:             H_mat = H 
112:          else 
113:             call build_H(H_mat, H_grad, .false.) 
114:          endif 
115:          ! convert coordinates 
116:          if (rigidinit.and.(.not.atomrigidcoordt)) then 
117:             call frac2cart_rb_tri(nrigidbody, x, xfrac, H_mat) 
118:          else 
119:             call frac2cart_tri(x, xfrac, H_mat) 
120:          endif 
121:       endif 
122:  
123:       end subroutine frac2cart 
124:   
125: ! ----------------------------------------------------------------------------------- 
126:  
127: ! CONVERTS GRADIENT WRT ATOMIC POSITIONS FROM ABSOLUTE TO FRACTIONAL COORDINATES. 
128: ! Wrapper subroutine that calls appropriate subroutine depending on whether atomistic 
129: ! or rigidbody coordinates, orthorhombic or triclinic unit cell. 
130:  
131:       subroutine boxderiv(grad, gradfrac, H) 
132:  
133:       use commons, only: ortho 
134:       use genrigid, only: rigidinit, atomrigidcoordt 
135:  
136:       implicit none 
137:  
138:       double precision, intent(in)           :: grad(3*natoms) 
139:       double precision, intent(out)          :: gradfrac(3*natoms) 
140:       double precision, intent(in), optional :: H(3,3) 
141:       double precision                       :: H_mat(3,3), H_grad(3,3,6) 
142:  
143:       ! orthorhombic cell 
144:       if (ortho) then 
145:          if (rigidinit.and.(.not.atomrigidcoordt)) then 
146:             call boxderiv_rb_ortho(grad, gradfrac) 
147:          else 
148:             call boxderiv_ortho(grad, gradfrac) 
149:          endif 
150:       ! triclinic 
151:       else 
152:          ! compute H matrix if not given 
153:          if (present(H)) then 
154:             H_mat = H 
155:          else 
156:             call build_H(H_mat, H_grad, .false.) 
157:          endif 
158:          ! convert gradient 
159:          if (rigidinit.and.(.not.atomrigidcoordt)) then 
160:             call boxderiv_rb_tri(grad, gradfrac, H_mat) 
161:          else 
162:             call boxderiv_tri(grad, gradfrac, H_mat) 
163:          endif 
164:       endif 
165:  
166:       end subroutine boxderiv 
167:  
168: ! ----------------------------------------------------------------------------------- 
169: ! Assumes atomistic coordinates and an orthorhombic unit cell. 
170:  
171:        subroutine boxderiv_ortho(grad, gradfrac) 
172:  
173:        implicit none 
174:  
175:        integer                       :: j1, j3 
176:        double precision, intent(in)  :: grad(3*natoms) 
177:        double precision, intent(out) :: gradfrac(3*natoms) 
178:  
179:        gradfrac(:) = 0.0d0 
180:        !box_paramsgrad(:) = 0.0d0 
181:  
182:        ! iterate over atoms 
183:        do j1 = 1, natoms 
184:           j3 = 3*j1 
185:  
186:           ! convert gradient wrt atom positions from absolute to fractional 
187:           gradfrac(j3-2:j3) = grad(j3-2:j3)*box_params(1:3) 
188:  
189:           ! TODO: trying to compute box derivatives generally (doesn't work!!) 
190:           ! add contribution to gradient wrt cell lengths 
191:           ! box_paramsgrad(1:3) = box_paramsgrad(1:3) + xfrac(j3-2:j3)*gradfrac(j3-2:j3)/box_params(1:3) 
192:        enddo 
193:  
194:        end subroutine boxderiv_ortho 
195:  
196: ! ----------------------------------------------------------------------------------- 
197: ! Assumes atomistic coordinates and a triclinic unit cell. 
198:  
199:        subroutine boxderiv_tri(grad, gradfrac, H) 
200:  
201:        implicit none 
202:  
203:        integer                       :: j1, j3 
204:        double precision, intent(in)  :: grad(3*natoms), H(3,3) 
205:        double precision, intent(out) :: gradfrac(3*natoms) 
206:  
207:        gradfrac(:) = 0.0d0 
208:  
209:        do j1 = 1, natoms 
210:           j3 = 3*j1 
211:           ! convert from absolute to fractional 
212:           gradfrac(j3-2:j3) = matmul(grad(j3-2:j3), H) 
213:        enddo 
214:  
215:        end subroutine boxderiv_tri 
216:  
217: ! ----------------------------------------------------------------------------------- 
218: ! Assumes rigid body coordinates and an orthorhombic unit cell. 
219:  
220:        subroutine boxderiv_rb_ortho(gradr, gradrfrac) 
221:  
222:        implicit none 
223:  
224:        integer                       :: j1, j3 
225:        double precision, intent(in)  :: gradr(3*natoms) 
226:        double precision, intent(out) :: gradrfrac(3*natoms) 
227:  
228:        gradrfrac(:) = 0.0d0 
229:  
230:        do j1 = 1, nrigidbody 
231:           j3 = 3*j1 
232:           ! convert gradient wrt COM positions from absolute to fractional 
233:           gradrfrac(j3-2:j3) = gradr(j3-2:j3)*box_params(1:3) 
234:        enddo 
235:  
236:        ! gradient wrt AA coordinates are unchanged 
237:        gradrfrac(3*nrigidbody+1:degfreedoms) = gradr(3*nrigidbody+1:degfreedoms) 
238:  
239:        end subroutine boxderiv_rb_ortho 
240:  
241: ! ----------------------------------------------------------------------------------- 
242: ! Assumes rigid body coordinates and a triclinic unit cell. 
243:  
244:        subroutine boxderiv_rb_tri(gradr, gradrfrac, H) 
245:  
246:        implicit none 
247:  
248:        integer :: j1, j3 
249:        double precision, intent(in)  :: gradr(3*natoms), H(3,3) 
250:        double precision, intent(out) :: gradrfrac(3*natoms) 
251:  
252:        gradrfrac(:) = 0.0d0 
253:  
254:        do j1 = 1, nrigidbody 
255:           j3 = 3*j1 
256:           ! convert gradient wrt COM positions from absolute to fractional 
257:           gradrfrac(j3-2:j3) = matmul(gradr(j3-2:j3), H) 
258:        enddo 
259:  
260:        ! gradient wrt AA coordinates are unchanged 
261:        gradrfrac(3*nrigidbody+1:degfreedoms) = gradr(3*nrigidbody+1:degfreedoms) 
262:  
263:        end subroutine boxderiv_rb_tri 
264:  
265: ! ----------------------------------------------------------------------------------- 
266: ! TAKES A BASIN-HOPPING STEP by making uniformly random changes to the cell lengths 
267: ! and angles 
268:  
269:        subroutine bd_takestep(np) 
270:  
271:        use commons, only: ortho, box_params 
272:        use vec3, only: vec_random 
273:  
274:        integer, intent(in)         :: np 
275:        double precision            :: new_angles(3) 
276:        double precision, parameter :: max_length_step = 0.3d0 
277:        double precision, parameter :: max_angle_step = 0.1d0 
278:  
279:        ! generate new box lengths 
280:        box_params(1:3) = box_params(1:3) + vec_random() * max_length_step 
281:        ! if triclinic 
282:        if (.not.(ortho)) then 
283:           new_angles(:) = box_params(4:6) + vec_random() * max_angle_step 
284:           ! check to make sure combination of new angles is valid 
285:           do while (.not.check_angles(new_angles(:))) 
286:              new_angles(:) = box_params(4:6) + vec_random() * max_angle_step 
287:           enddo 
288:           box_params(4:6) = new_angles(:) 
289:        endif ! triclinic 
290:  
291:        end subroutine bd_takestep 
292:  
293: ! ----------------------------------------------------------------------------------- 
294: ! CHECKS SET OF TRICLINIC CELL ANGLES to make sure they are valid. Non-valid set of angles 
295: ! corresponds to a cell with zero or imaginary volume. Function returns True if the set 
296: ! of angles meets the criteria for valid cell angles. 
297:  
298:        pure logical function check_angles(angles) 
299:  
300:        implicit none 
301:  
302:        double precision, intent(in) :: angles(3) 
303:        double precision             :: sums(4) 
304:        double precision, parameter   :: pi = 3.141592654d0 
305:  
306:        ! calculate necessary sums 
307:        sums(1) =  angles(1) + angles(2) + angles(3) 
308:        sums(2) = -angles(1) + angles(2) + angles(3) 
309:        sums(3) =  angles(1) - angles(2) + angles(3) 
310:        sums(4) =  angles(1) + angles(2) - angles(3) 
311:  
312:        ! check all sums are between 0 and 2pi and all angles between 0 and pi 
313:        check_angles = all(sums.gt.0.0d0).and.all(sums.lt.2*pi).and.all(angles.gt.0.0d0).and.all(angles.lt.pi) 
314:        end function check_angles 
315:  
316: ! ----------------------------------------------------------------------------------- 
317: ! REJECTS structures that are invalid. Tricks the LBFGS minimizer by returning a very 
318: ! large energy and a very small gradient, so will the quench will immediately be  
319: ! considered converged but the structure will never be saved as a low-energy minimum. 
320:  
321:        subroutine reject(energy, grad) 
322:  
323:        implicit none 
324:  
325:        double precision, intent(out) :: energy, grad(3*natoms) 
326:  
327:        energy = 1.0d20 
328:        grad(:) = 1.0d-20 
329:  
330:        end subroutine reject 
331:  
332: ! ----------------------------------------------------------------------------------- 
333: ! ADDS WCA-STYLE REPULSION term to the energy and gradients to repel the cell away 
334: ! from having zero volume. 
335:  
336:        subroutine constrain_volume(v, v_deriv, energy, grad_angles, gtest) 
337:  
338:        implicit none 
339:  
340:        double precision, intent(in)    :: v, v_deriv(3) 
341:        double precision, intent(inout) :: energy, grad_angles(3) 
342:        logical, intent(in)             :: gtest 
343:        double precision, parameter     :: v_sigma = 3.0d-1 
344:        double precision, parameter     :: v_eps = 1.0d-3 
345:  
346:        if (v.lt.v_sigma**(1.0d0/6.d0)) then 
347:           ! add purely repulsive WCA energy term 
348:           energy = energy + 4.0d0*v_eps*((v_sigma/v)**12 - (v_sigma/v)**6) + v_eps 
349:  
350:           if (gtest) then 
351:              ! add gradient contribution 
352:              grad_angles(:) = grad_angles(:) + 24.0d0*v_eps/v_sigma*((v_sigma/v)**7 - 2.0d0*(v_sigma/v)**13)*v_deriv(:) 
353:           endif 
354:        endif 
355:  
356:        end subroutine constrain_volume 
357:  
358: ! --------------------------------------------------------------------------------- 
359: !  
360: ! Rotates all rigid bodies after a step is taken in the cell parameters. 
361: ! VARIABLES 
362: ! box_paramsold: unit cell lengths and angles from before the step was taken 
363: ! TODO: not sure this is working properly (or that the equations are even valid...) 
364:  
365:  
366: !       subroutine rotate_bodies(box_paramsold, xrfrac) 
367: ! 
368: !       use genrigid, only: transformctorigid, sitesrigidbody, maxsite, nsiteperbody, inversematrix 
369: ! 
370: !       integer                         :: j1, j3, j5, j2, j4, j6 
371: !       double precision, intent(in)    :: box_paramsold(6) 
372: !       double precision, intent(inout) :: xrfrac(3*natoms) 
373: !       double precision                :: H_old(3,3), H_grad(3,3,6), H_oldinverse(3,3), H_new(3,3) 
374: !       double precision                :: ri(3), p(3), xr(3*natoms), x(3*natoms), rot(3,3) 
375: !       double precision                :: rmi(3,3), drmi1(3,3), drmi2(3,3), drmi3(3,3), vol_new, vol_old 
376: ! 
377: !       print *, 'rotating!' 
378: ! 
379: !       !print *, 'xrfrac old: ', xrfrac(:degfreedoms) 
380: !       ! get H matrix from old box parameters 
381: !       call build_H(H_old, H_grad, .false., box_paramsold) 
382: !       !print *, 'H_old: ', H_old(:3,:3) 
383: !       call inversematrix(H_old, H_oldinverse) 
384: !       call get_volume(vol_old, box_paramsold) 
385: !       ! get H matrix from current box parameters 
386: !       call build_H(H_new, H_grad, .false.) 
387: !       call get_volume(vol_new) 
388: ! 
389: !       !print *, 'H_old: ', H_old(:3,:3) 
390: !       !print *, 'H_new: ', H_new(:3,:3) 
391: !  
392: !       call frac2cart_rb_tri(xr, xrfrac, H_old) 
393: ! 
394: !       do j1 = 1, 1!nrigidbody 
395: !          j3 = 3*j1 
396: !          j5 = 3*nrigidbody + j3 
397: ! 
398: !          ri(:) = xr(j3-2:j3) 
399: !          p(:) = xr(j5-2:j5) 
400: ! 
401: !          call rmdrvt(p, rmi, drmi1, drmi2, drmi3, .false.) 
402: !          ! get new rotation matrix 
403: !          rot(:,:) = (vol_old/vol_new)*matmul(H_new, matmul(H_oldinverse, rmi)) 
404: !          !print *, 'rmi: ', rmi(:3,:3) 
405: !          !print *, 'rot: ', rot(:3,:3) 
406: ! 
407: !          do j2 = 1, nsiteperbody(j1) 
408: !             j4 = maxsite*(j1-1) + j2 
409: !             j6 = 3*j4 
410: !             x(j6-2:j6) = ri(:) + matmul(rot(:,:), sitesrigidbody(j2,:,j1)) 
411: !          enddo 
412: !           
413: !          print *, 'reference geometry: ' 
414: !          do j2 = 1, nsiteperbody(j1) 
415: !             print *, sitesrigidbody(j2,:,j1) 
416: !          enddo 
417: !          print *, 'beginning rotation: ' 
418: !          do j2 = 1, nsiteperbody(j1) 
419: !             print *, (ri(:) + matmul(rmi, sitesrigidbody(j2,:,j1))) 
420: !          enddo 
421: !          print *, 'base rotation: ' 
422: !          do j2 = 1, nsiteperbody(j1) 
423: !             print *, (ri(:) + vol_old*matmul(matmul(H_oldinverse, rmi), sitesrigidbody(j2,:,j1))) 
424: !          enddo 
425: !          print *, 'end rotation: ' 
426: !          do j2 = 1, nsiteperbody(j1) 
427: !             print *, (ri(:) + matmul(rot, sitesrigidbody(j2,:,j1))) 
428: !          enddo 
429: ! 
430: !       enddo 
431: ! 
432: !       !print *, 'x         : ', x(:3*natoms) 
433: !       call transformctorigid(x, xrfrac) 
434: !       !print *, 'xrfrac new: ', xrfrac(:degfreedoms) 
435: ! 
436: !       end subroutine rotate_bodies 
437:  
438: ! ----------------------------------------------------------------------------------- 
439: end module 


r33142/cartdist.f90 2017-08-08 12:30:09.994315496 +0100 r33141/cartdist.f90 2017-08-08 12:30:14.070369990 +0100
  1: module cartdist  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/GMIN/source/cartdist.f90' in revision 33141
  2: use commons, only: natoms, box_params, box_paramsgrad 
  3:  
  4: implicit none 
  5:  
  6: ! dj337: util modules for converting between absolute and fractional coordinate 
  7: ! systems, building the H matrix, and computing the reciprocal lattice vectors 
  8:  
  9: contains 
 10:  
 11: ! ----------------------------------------------------------------------------------- 
 12: ! VARIABLES 
 13: ! x: atomic positions in absolute coordinates 
 14: ! xfrac: atomic positions in fractional coordinates 
 15:  
 16: ! xr: absolute rigid body (COM+AA) coordinates 
 17: ! xrfrac: fractional rigid body coordinates 
 18: !!! NOTE: AA coordinates are the same in absolute and fractional coordinate systems 
 19:  
 20: ! box_params: unit cell lengths and angles, in radians (a, b, c, alpha, beta, gamma) 
 21: ! box_paramsgrad: gradient of energy wrt unit cell parameters 
 22:  
 23: ! H: matrix that transforms between fractional and absolute coordinates; 
 24: !    x = H*xfrac 
 25: !    first index corresponds to row, second to column 
 26: ! H_grad: derivatives of the H matrix wrt cell parameters; 
 27: !    first index corresponds to row, second to column, third to cell parameter 
 28: ! H_inverse: inverse of the H matrix 
 29: ! ----------------------------------------------------------------------------------- 
 30: ! CONVERTS ATOMIC POSITIONS FROM ABSOLUTE TO FRACTIONAL COORDINATES. 
 31: ! ----------------------------------------------------------------------------------- 
 32: ! Assumes atomistic coordinates and an orthorhombic unit cell. 
 33:  
 34:        subroutine cart2frac_ortho(x, xfrac) 
 35:  
 36:        implicit none 
 37:  
 38:        integer                       :: j1, j3 
 39:        double precision, intent(in)  :: x(3*natoms) 
 40:        double precision, intent(out) :: xfrac(3*natoms) 
 41:  
 42:        xfrac(:) = 0.0d0 
 43:  
 44:        do j1 = 1, natoms 
 45:           j3 = 3*j1 
 46:           ! convert from absolute to fractional 
 47:           xfrac(j3-2:j3) = x(j3-2:j3)/box_params(1:3) 
 48:        enddo 
 49:  
 50:        end subroutine cart2frac_ortho 
 51:  
 52: ! ----------------------------------------------------------------------------------- 
 53: ! Assumes atomistic coordinates and a tricilinic unit cell. 
 54:  
 55:        subroutine cart2frac_tri(x, xfrac, H_inverse) 
 56:  
 57:        implicit none 
 58:  
 59:        integer                       :: j1, j3 
 60:        double precision, intent(in)  :: x(3*natoms), H_inverse(3,3) 
 61:        double precision, intent(out) :: xfrac(3*natoms) 
 62:  
 63:        xfrac(:) = 0.0d0 
 64:  
 65:        do j1 = 1, natoms 
 66:           j3 = 3*j1 
 67:           ! convert from absolute to fractional 
 68:           xfrac(j3-2:j3) = matmul(H_inverse, x(j3-2:j3)) 
 69:        enddo 
 70:  
 71:        end subroutine 
 72:  
 73: ! ----------------------------------------------------------------------------------- 
 74: ! Assumes rigid body coordinates and an orthorhombic unit cell. 
 75:  
 76:        subroutine cart2frac_rb_ortho(nrigidbody, xr, xrfrac) 
 77:  
 78:        implicit none 
 79:  
 80:        integer                       :: j1, j3, degfreedoms 
 81:        integer, intent(in)           :: nrigidbody 
 82:        double precision, intent(in)  :: xr(3*natoms) 
 83:        double precision, intent(out) :: xrfrac(3*natoms) 
 84:  
 85:        ! number of degrees of freedom 
 86:        degfreedoms = 6*nrigidbody 
 87:        xrfrac(:) = 0.0d0 
 88:  
 89:        do j1 = 1, nrigidbody 
 90:           j3 = 3*j1 
 91:           ! convert COM coordinates from absolute to fractional 
 92:           xrfrac(j3-2:j3) = xr(j3-2:j3)/box_params(1:3) 
 93:        enddo 
 94:  
 95:        ! AA coordinates are unchanged 
 96:        xrfrac(3*nrigidbody+1:degfreedoms) = xr(3*nrigidbody+1:degfreedoms) 
 97:  
 98:        end subroutine cart2frac_rb_ortho 
 99:  
100: ! ----------------------------------------------------------------------------------- 
101: ! Assumes rigid body coordinates an a triclinic unit cell. 
102:  
103:        subroutine cart2frac_rb_tri(nrigidbody, xr, xrfrac, H_inverse) 
104:  
105:        implicit none 
106:  
107:        integer                       :: j1, j3, degfreedoms 
108:        integer, intent(in)           :: nrigidbody 
109:        double precision, intent(in)  :: xr(3*natoms), H_inverse(3,3) 
110:        double precision, intent(out) :: xrfrac(3*natoms) 
111:  
112:        ! number of degrees of freedom 
113:        degfreedoms = 6*nrigidbody 
114:        xrfrac(:) = 0.0d0 
115:  
116:        do j1 = 1, nrigidbody 
117:           j3 = 3*j1 
118:           ! convert COM coordinates from absolute to fractional 
119:           xrfrac(j3-2:j3) = matmul(H_inverse, xr(j3-2:j3)) 
120:        enddo 
121:  
122:        ! AA coordinates are unchanged 
123:        xrfrac(3*nrigidbody+1:degfreedoms) = xr(3*nrigidbody+1:degfreedoms) 
124:  
125:        end subroutine cart2frac_rb_tri 
126:  
127: ! ----------------------------------------------------------------------------------- 
128: ! CONVERTS ATOMIC POSITIONS FROM FRACTIONAL TO ABSOLUTE COORDINATES. 
129: ! ----------------------------------------------------------------------------------- 
130: ! Assumes atomistic coordinates and an orthorhombic unit cell. 
131:  
132:        subroutine frac2cart_ortho(x, xfrac) 
133:  
134:        implicit none 
135:  
136:        integer                       :: j1, j3 
137:        double precision, intent(in)  :: xfrac(3*natoms) 
138:        double precision, intent(out) :: x(3*natoms) 
139:  
140:        x(:) = 0.0d0 
141:  
142:        do j1 = 1, natoms 
143:           j3 = 3*j1 
144:           ! convert from fractional to absolute 
145:           x(j3-2:j3) = xfrac(j3-2:j3)*box_params(1:3) 
146:        enddo 
147:  
148:        end subroutine frac2cart_ortho 
149:  
150: ! ----------------------------------------------------------------------------------- 
151: ! Assumes atomistic coordinates and a triclinic unit cell. 
152:  
153:        subroutine frac2cart_tri(x, xfrac, H) 
154:  
155:        implicit none 
156:  
157:        integer :: j1, j3 
158:        double precision, intent(in)  :: xfrac(3*natoms), H(3,3) 
159:        double precision, intent(out) :: x(3*natoms) 
160:  
161:        x(:) = 0.0d0 
162:  
163:        do j1 = 1, natoms 
164:           j3 = 3*j1 
165:           ! convert from fractional to absolute 
166:           x(j3-2:j3) = matmul(H, xfrac(j3-2:j3)) 
167:       enddo 
168:  
169:       end subroutine frac2cart_tri 
170:  
171: ! ----------------------------------------------------------------------------------- 
172: ! Assumes rigid body coordinates and an orthorhombic unit cell. 
173:  
174:        subroutine frac2cart_rb_ortho(nrigidbody, xr, xrfrac) 
175:  
176:        implicit none 
177:  
178:        integer                       :: j1, j3, degfreedoms 
179:        integer, intent(in)           :: nrigidbody 
180:        double precision, intent(in)  :: xrfrac(3*natoms) 
181:        double precision, intent(out) :: xr(3*natoms) 
182:  
183:        ! number of degfrees of freedom 
184:        degfreedoms = 6*nrigidbody 
185:        xr(:) = 0.0d0 
186:  
187:        do j1 = 1, nrigidbody 
188:           j3 = 3*j1 
189:           ! convert COM coordinates from fractional to absolute 
190:           xr(j3-2:j3) = xrfrac(j3-2:j3)*box_params(1:3) 
191:        enddo 
192:  
193:        ! AA coordinates are unchanged 
194:        xr(3*nrigidbody+1:degfreedoms) = xrfrac(3*nrigidbody+1:degfreedoms) 
195:  
196:        end subroutine frac2cart_rb_ortho 
197:  
198: ! ----------------------------------------------------------------------------------- 
199: ! Assumes rigid body coordinates and a triclinic unit cell. 
200:  
201:        subroutine frac2cart_rb_tri(nrigidbody, xr, xrfrac, H) 
202:  
203:        implicit none 
204:  
205:        integer                       :: j1, j3, degfreedoms 
206:        integer, intent(in)           :: nrigidbody 
207:        double precision, intent(in)  :: xrfrac(3*natoms), H(3,3) 
208:        double precision, intent(out) :: xr(3*natoms) 
209:  
210:        ! number of degrees of freedom 
211:        degfreedoms = 6*nrigidbody 
212:        xr(:) = 0.0d0 
213:  
214:        do j1 = 1, nrigidbody 
215:           j3 = 3*j1 
216:           ! convert COM coordinates from fractional to absolute 
217:           xr(j3-2:j3) = matmul(H, xrfrac(j3-2:j3)) 
218:        enddo 
219:  
220:        ! AA coordinates are unchanged 
221:        xr(3*nrigidbody+1:degfreedoms) = xrfrac(3*nrigidbody+1:degfreedoms) 
222:  
223:        end subroutine frac2cart_rb_tri 
224:  
225: ! ----------------------------------------------------------------------------------- 
226:  
227: ! BUILDS THE H MATRIX that transforms between fractional and absolute coordinates. 
228: ! If GTEST is true, computes the six derivative matrices of the H matrix with respects 
229: ! to the six cell parameters. This works for any triclinic unit cell. 
230:  
231:       subroutine build_H(H, H_grad, gtest) 
232:  
233:       implicit none 
234:  
235:       double precision, intent(out)          :: H(3,3), H_grad(3,3,6) 
236:       logical, intent(in)                    :: gtest 
237:       !double precision, intent(in), optional :: box_parameters 
238:       double precision                       :: box_lengths(3), box_angles(3) 
239:       double precision                       :: c(3), s(3), v 
240:  
241:       H(:,:) = 0.0d0 
242:       H_grad(:,:,:) = 0.0d0 
243:       box_lengths(:) = box_params(1:3) 
244:       box_angles(:) = box_params(4:6) 
245:  
246:       ! cosine of the angles 
247:       c(:) = dcos(box_angles(:)) 
248:       ! sine of the angles 
249:       s(:) = dsin(box_angles(:)) 
250:       ! factor that is related to the volume (but not quite volume) 
251:       v = dsqrt(1.0d0 - c(1)**2 - c(2)**2 - c(3)**2 + 2.0d0*c(1)*c(2)*c(3)) 
252:  
253:       ! define the H transformation matrix 
254:       ! first row of matrix 
255:       H(1,1) = box_lengths(1) 
256:       H(1,2) = box_lengths(2)*c(3) 
257:       H(1,3) = box_lengths(3)*c(2) 
258:       ! second row 
259:       H(2,2) = box_lengths(2)*s(3) 
260:       H(2,3) = box_lengths(3)*(c(1) - c(2)*c(3))/s(3) 
261:       ! third row 
262:       H(3,3) = box_lengths(3)*v/s(3) 
263:  
264:       ! compute derivatives of H matrix 
265:       if (gtest) then 
266:          ! wrt box length a 
267:          H_grad(1,1,1) = 1.0d0 
268:          ! wrt box length b 
269:          H_grad(1,2,2) = c(3) 
270:          H_grad(2,2,2) = s(3) 
271:          ! wrt box length c 
272:          H_grad(1,3,3) = c(2) 
273:          H_grad(2,3,3) = (c(1) - c(2)*c(3))/s(3) 
274:          H_grad(3,3,3) = v/s(3) 
275:          ! wrt box angle alpha 
276:          H_grad(2,3,4) = -box_lengths(3)*s(1)/s(3) 
277:          H_grad(3,3,4) = box_lengths(3)*(c(1)*s(1) - s(1)*c(2)*c(3))/(s(3)*v) 
278:          ! wrt box angle beta 
279:          H_grad(1,3,5) = -box_lengths(3)*s(2) 
280:          H_grad(2,3,5) = box_lengths(3)*s(2)*c(3)/s(3) 
281:          H_grad(3,3,5) = box_lengths(3)*s(2)*(c(2) - c(1)*c(3))/(s(3)*v) 
282:          ! wrt box angle gamma 
283:          H_grad(1,2,6) = -box_lengths(2)*s(3) 
284:          H_grad(2,2,6) = box_lengths(2)*c(3) 
285:          H_grad(2,3,6) = box_lengths(3)*(c(2) - c(1)*c(3))/s(3)**2 
286:          H_grad(3,3,6) = box_lengths(3)*((c(3) - c(1)*c(2))/v - v*c(3)/s(3)**2) 
287:       endif 
288:  
289:       return 
290:       end subroutine build_H 
291:  
292: ! ----------------------------------------------------------------------------------- 
293:  
294: ! COMPUTES CELL VOLUME. This works for any orthorhombic or triclinic unit cell. 
295: ! VARIABLES 
296: ! vol: cell volume 
297:  
298:        subroutine get_volume(vol) 
299:  
300:        use commons, only: ortho 
301:  
302:        implicit none 
303:  
304:        !double precision, intent(in), optional :: box_parameters(6) 
305:        double precision, intent(out)          :: vol 
306:        double precision                       :: box_lengths(3), box_angles(3), c(3) 
307:  
308:        box_lengths(:) = box_params(1:3) 
309:        box_angles(:) = box_params(4:6) 
310:  
311:        vol = box_lengths(1)*box_lengths(2)*box_lengths(3) 
312:        if (.not.ortho) then 
313:           c(:) = dcos(box_angles(:)) 
314:           vol = vol * dsqrt(1.0d0 - c(1)**2 - c(2)**2 - c(3)**2 + 2.0d0*c(1)*c(2)*c(3)) 
315:        endif 
316:  
317:        end subroutine get_volume 
318:  
319: ! ----------------------------------------------------------------------------------- 
320:  
321: ! BUILDS THE K MATRIX whose columns are the reciprocal lattice vectors. If GTEST is 
322: ! true, computes the six derivative matrices of the K matrix with respects to the six 
323: ! cell parameters. This works for any triclinic unit cell. 
324: ! VARIABLES 
325: ! reciplatvec: matrix whose columns are the reciprocal lattice vectors 
326: !    first index corresponds to row, second to column 
327: ! reciplatvec_grad: derivatives of the reciprocal lattice vector matrix wrt cell parameters 
328: !    first index corresponds to row, second to column, third to cell parameter 
329:  
330:       subroutine get_reciplatvec(reciplatvec, reciplatvec_grad, gtest) 
331:  
332:       implicit none 
333:  
334:       double precision, intent(out) :: reciplatvec(3,3), reciplatvec_grad(3,3,6) 
335:       logical, intent(in)           :: gtest 
336:       double precision              :: box_lengths(3), box_angles(3) 
337:       double precision              :: c(3), s(3), v, dv(3), cfact 
338:       double precision, parameter   :: pi = 3.141592654d0 
339:  
340:       reciplatvec(:,:) = 0.0d0 
341:       reciplatvec_grad(:,:,:) = 0.0d0 
342:       box_lengths(:) = box_params(1:3) 
343:       box_angles(:) = box_params(4:6) 
344:         
345:       ! cosine of the angles 
346:       c(:) = dcos(box_angles(:)) 
347:       ! sine of the angles 
348:       s(:) = dsin(box_angles(:)) 
349:       ! factor that is related to the volume (but not quite volume) 
350:       v = dsqrt(1.0d0 - c(1)**2 - c(2)**2 - c(3)**2 + 2.0d0*c(1)*c(2)*c(3)) 
351:  
352:       ! define the reciprocal lattice vector matrix 
353:       ! first row of matrix 
354:       reciplatvec(1,1) = 1.0d0/box_lengths(1) 
355:       ! second row 
356:       reciplatvec(2,1) = -c(3)/(box_lengths(1)*s(3)) 
357:       reciplatvec(2,2) = 1.0d0/(box_lengths(2)*s(3)) 
358:       ! third row 
359:       reciplatvec(3,1) = (c(3)*(c(1) - c(2)*c(3)) - c(2)*s(3)**2)/(box_lengths(1)*v*s(3)) 
360:       reciplatvec(3,2) = -(c(1) - c(2)*c(3))/(box_lengths(2)*v*s(3)) 
361:       reciplatvec(3,3) = s(3)/(box_lengths(3)*v) 
362:       ! multiply by 2*pi 
363:       reciplatvec(:,:) = 2.0d0*pi*reciplatvec(:,:) 
364:  
365:       ! compute derivatives of reciprocal lattice vector matrix 
366:       if (gtest) then 
367:          ! gradient of v wrt cell angles 
368:          dv(1) = s(1)*(c(1)-c(2)*c(3))/v 
369:          dv(2) = s(2)*(c(2)-c(1)*c(3))/v 
370:          dv(3) = s(3)*(c(3)-c(1)*c(2))/v 
371:          ! cosine factor: cos(alpha) - cos(beta)cos(gamma) 
372:          cfact = c(1)-c(2)*c(3) 
373:  
374:          ! wrt box length a 
375:          reciplatvec_grad(1,1,1) = -1.0d0/box_lengths(1)**2  
376:          reciplatvec_grad(2,1,1) = c(3)/(box_lengths(1)**2*s(3)) 
377:          reciplatvec_grad(3,1,1) = (c(2)*s(3) - c(3)*cfact/s(3))/(box_lengths(1)**2*v) 
378:          ! wrt box length b 
379:          reciplatvec_grad(2,2,2) = -1.0d0/(box_lengths(2)**2*s(3)) 
380:          reciplatvec_grad(3,2,2) = cfact/(box_lengths(2)**2*s(3)*v) 
381:          ! wrt box length c 
382:          reciplatvec_grad(3,3,3) = -s(3)/(box_lengths(3)**2*v) 
383:          ! wrt cell angle alpha 
384:          reciplatvec_grad(3,1,4) = (-c(3)*s(1)/s(3) - c(3)*cfact*dv(1)/(s(3)*v) + c(2)*s(3)*dv(1)/v)/(box_lengths(1)*v) 
385:          reciplatvec_grad(3,2,4) = (s(1) + cfact*dv(1)/v)/(box_lengths(2)*s(3)*v) 
386:          reciplatvec_grad(3,3,4) = -s(3)*dv(1)/(box_lengths(3)*v**2) 
387:          ! wrt cell angle beta 
388:          reciplatvec_grad(3,1,5) = ((s(2)*c(3)**2)/s(3) - c(3)*cfact*dv(2)/(s(3)*v) + & 
389:                                    s(2)*s(3) + c(2)*s(3)*dv(2)/v)/(box_lengths(1)*v) 
390:          reciplatvec_grad(3,2,5) = (-s(2)*c(3) + (cfact*dv(2)/v))/(box_lengths(2)*s(3)*v) 
391:          reciplatvec_grad(3,3,5) = -s(3)*dv(2)/(box_lengths(3)*v**2) 
392:          ! wrt cell angle gamma 
393:          reciplatvec_grad(2,1,6) = 1.0d0/(box_lengths(1)*s(3)**2) 
394:          reciplatvec_grad(2,2,6) = -c(3)/(box_lengths(2)*s(3)**2) 
395:          reciplatvec_grad(3,1,6) = (-cfact - c(3)**2*cfact/(s(3)**2) - c(3)*cfact*dv(3)/(s(3)*v) + & 
396:                                    c(2)*s(3)*dv(3)/v)/(box_lengths(1)*v) 
397:          reciplatvec_grad(3,2,6) = (-c(2)*s(3) + c(3)*cfact/s(3) + cfact*dv(3)/v)/(box_lengths(2)*s(3)*v) 
398:          reciplatvec_grad(3,3,6) = (c(3) - s(3)*dv(3)/v)/(box_lengths(3)*v) 
399:  
400:          ! multiply by 2*pi 
401:          reciplatvec_grad(:,:,:) = 2.0d0*pi*reciplatvec_grad(:,:,:) 
402:       endif 
403:  
404:       end subroutine get_reciplatvec 
405:  
406: ! ----------------------------------------------------------------------------------- 
407:  
408: end module 


r33142/checkd.f90 2017-08-08 12:30:10.214318435 +0100 r33141/checkd.f90 2017-08-08 12:30:14.314373252 +0100
  1:       SUBROUTINE CHECKD(X)  1:       SUBROUTINE CHECKD(X)
  2:   2: 
  3:       USE COMMONS, ONLY: NATOMS, COMPRESST, PERCOLATET, CHECKDID, GTHOMSONT, &  3:       USE COMMONS, ONLY: NATOMS, COMPRESST, PERCOLATET, CHECKDID, GTHOMSONT
  4:                          BOXDERIVT, ORTHO, BOX_PARAMS, BOX_PARAMSGRAD 
  5:       USE GENRIGID, ONLY: RIGIDINIT, ATOMRIGIDCOORDT, DEGFREEDOMS, TRANSFORMCTORIGID 
  6:   4: 
  7:       USE MODHESS  5:       USE MODHESS
  8:       IMPLICIT NONE  6:       IMPLICIT NONE
  9:   7: 
 10:       INTEGER          :: IVRNO, IVRNO1, IVRNO2, J1, J3, dof, doff  8:       INTEGER          :: IVRNO, IVRNO1, IVRNO2
 11:       DOUBLE PRECISION :: X(3*NATOMS), G(3*NATOMS), ENERGY, FM, FP, DFA, DFN, TMPCOORDS(3*NATOMS)  9:       DOUBLE PRECISION :: X(3*NATOMS), G(3*NATOMS), ENERGY, FM, FP, DFA, DFN, TMPCOORDS(3*NATOMS)
 12:       double precision :: box_paramsold(6) 
 13:       LOGICAL          :: GTEST, STEST, COMPON 10:       LOGICAL          :: GTEST, STEST, COMPON
 14:       DOUBLE PRECISION, PARAMETER :: ERRLIM = 1.D-04, DELX = 1.0D-6 11:       DOUBLE PRECISION, PARAMETER :: ERRLIM = 1.D-05, DELX = 1.D-06
 15:       COMMON /CO/ COMPON 12:       COMMON /CO/ COMPON
 16:  13: 
 17:       ! dj337: allow for rigid bodies 
 18:       if (rigidinit) then 
 19:          dof = degfreedoms 
 20:       else 
 21:          dof = 3*natoms 
 22:       endif 
 23:  
 24:       print *, 'DELX: ', DELX 
 25:  
 26: ! jwrm2> Turning compression on, if required 14: ! jwrm2> Turning compression on, if required
 27:       IF (COMPRESST .OR. PERCOLATET) COMPON = .TRUE. 15:       IF (COMPRESST .OR. PERCOLATET) COMPON = .TRUE.
 28:  16: 
 29: ! jwrm2> Converting GTHOMSON coordinates to polars 17: ! jwrm2> Converting GTHOMSON coordinates to polars
 30:       IF (GTHOMSONT) THEN 18:       IF (GTHOMSONT) THEN
 31:         CALL GTHOMSONCTOANG(X(1:3*NATOMS), TMPCOORDS(1:3*NATOMS), NATOMS) 19:         CALL GTHOMSONCTOANG(X(1:3*NATOMS), TMPCOORDS(1:3*NATOMS), NATOMS)
 32:         X(1:3*NATOMS) = TMPCOORDS(1:3*NATOMS) 20:         X(1:3*NATOMS) = TMPCOORDS(1:3*NATOMS)
 33:       END IF 21:       END IF
 34:  22: 
 35:       STEST = .FALSE. 23:       STEST = .FALSE.
 36:  24: 
 37:       IF (CHECKDID == 0) THEN 25:       IF (CHECKDID == 0) THEN
 38:          GTEST = .FALSE. 26:          GTEST = .FALSE.
 39:          CALL POTENTIAL (X, G, ENERGY, GTEST, STEST) 27:          CALL POTENTIAL (X, G, ENERGY, GTEST, STEST)
 40:          WRITE(*, *) 'Energy  = ', ENERGY 28:          WRITE(*, *) 'Energy  = ', ENERGY
 41:  29: 
 42:       ELSEIF (CHECKDID == 1) THEN 30:       ELSEIF (CHECKDID == 1) THEN
 43:  31: 
 44: !     Checks gradients 32: !     Checks gradients
 45:  33: 
 46:       ! check derivatives wrt atomic positions 34:       DO IVRNO = 1, 3*NATOMS
 47:       DO IVRNO = 1, DOF 
 48:          WRITE(*, *) IVRNO 
 49:  
 50:          ! dj337: make sure coordinates rigid body 
 51:          if (rigidinit.and.atomrigidcoordt) then 
 52:             call transformctorigid(x, tmpcoords) 
 53:             x(1:degfreedoms) = tmpcoords(1:degfreedoms) 
 54:             x(degfreedoms+1:3*natoms) = 0.0d0 
 55:             atomrigidcoordt = .false. 
 56:          endif 
 57:  35: 
 58:          !print *, 'x: ', x(ivrno) 36:          WRITE(*, *) IVRNO
 59:  37: 
 60:          GTEST = .FALSE. 38:          GTEST    = .FALSE.
 61:          X(IVRNO) = X(IVRNO) - DELX 39:          X(IVRNO) = X(IVRNO) - DELX
 62:          !print *, 'xplus1: ', x(ivrno) 40:          CALL POTENTIAL (X, G, FM, GTEST, STEST)
 63:          CALL POTENTIAL(X, G, FM, GTEST, STEST) 41:          WRITE(*, *) 'Energy minus = ', FM
 64:          !print *, 'xplus2: ', x(ivrno) 
 65:  
 66:          if (rigidinit.and.atomrigidcoordt) then 
 67:             call transformctorigid(x, tmpcoords) 
 68:             x(1:degfreedoms) = tmpcoords(1:degfreedoms) 
 69:             x(degfreedoms+1:3*natoms) = 0.0d0 
 70:             atomrigidcoordt = .false. 
 71:          endif 
 72:  42: 
 73:          X(IVRNO) = X(IVRNO) + 2.D0*DELX 43:          X(IVRNO) = X(IVRNO) + 2.D0*DELX
 74:          !print *, 'xminus1: ', x(ivrno) 44:          CALL POTENTIAL (X, G,  FP, GTEST, STEST)
 75:          CALL POTENTIAL(X, G, FP, GTEST, STEST) 45:          WRITE(*, *) 'Energy plus  = ', FP
 76:          !print *, 'xminus2: ', x(ivrno) 46: 
 77:       
 78:          if (rigidinit.and.atomrigidcoordt) then 
 79:             call transformctorigid(x, tmpcoords) 
 80:             x(1:degfreedoms) = tmpcoords(1:degfreedoms) 
 81:             x(degfreedoms+1:3*natoms) = 0.0d0 
 82:             atomrigidcoordt = .false.  
 83:          endif 
 84:   
 85:          GTEST = .TRUE. 47:          GTEST = .TRUE.
 86:          X(IVRNO) = X(IVRNO) - DELX 48:          X(IVRNO) = X(IVRNO) - DELX
 87:          CALL POTENTIAL(X, G, ENERGY, GTEST, STEST) 49:          CALL POTENTIAL (X, G, ENERGY, GTEST, STEST)
 88:          DFN = (FP - FM) / (2.D0*DELX) 50:          DFN = (FP - FM) / (2.D0*DELX)
 89:          IF (ABS(DFN).LT.1.0D-10) DFN = 0.D0 51:          IF (ABS(DFN) .LT. 1.0D-10) DFN = 0.D0
 90:          DFA = G(IVRNO) 52:          DFA = G(IVRNO)
 91:  53: 
 92:          WRITE(*, *) 'Gradient numerical  = ', DFN 54:          WRITE(*, *) 'Gradient numerical  = ', DFN
 93:          WRITE(*, *) 'Gradient analytical = ', DFA 55:          WRITE(*, *) 'Gradient analytical = ', DFA
 94:  56: 
 95:          IF (ABS(DFN - DFA) > ERRLIM) WRITE(*, *) IVRNO, DFN, DFA, ABS(DFN-DFA) 57:          IF (ABS(DFN - DFA) > ERRLIM) WRITE(*, *) IVRNO, DFN, DFA, ABS(DFN-DFA)
 96:       ENDDO 
 97:  
 98:       ! dj337: check lattice derivatives 
 99:       if (boxderivt) then 
100:          doff = 3 
101:          if (.not.ortho) doff = 6 
102:          DO IVRNO = 1, doff 
103:  
104:             if (rigidinit.and.atomrigidcoordt) then 
105:                call transformctorigid(x, tmpcoords) 
106:                x(1:degfreedoms) = tmpcoords(1:degfreedoms) 
107:                atomrigidcoordt = .false. 
108:             endif 
109:  
110:             WRITE(*, *) 'Box parameter ', IVRNO 
111:  
112:             GTEST = .FALSE. 
113:             BOX_PARAMS(IVRNO) = BOX_PARAMS(IVRNO) - DELX 
114:             CALL POTENTIAL(X, G, FM, GTEST, STEST) 
115:             WRITE(*, *) 'Energy minus = ', FM 
116:  
117:             BOX_PARAMS(IVRNO) = BOX_PARAMS(IVRNO) + 2.D0*DELX 
118:             CALL POTENTIAL(X, G, FP, GTEST, STEST) 
119:             WRITE(*, *) 'Energy plus  = ', FP 
120:  
121:             GTEST = .TRUE. 
122:             BOX_PARAMS(IVRNO) = BOX_PARAMS(IVRNO) - DELX 
123:             CALL POTENTIAL(X, G, ENERGY, GTEST, STEST) 
124:             DFN = (FP - FM) / (2.D0*DELX) 
125:             IF (ABS(DFN).LT.1.0D-10) DFN = 0.D0 
126:             DFA = BOX_PARAMSGRAD(IVRNO) 
127:  58: 
128:             WRITE(*, *) 'Box gradient numerical  = ', DFN 59:       ENDDO
129:             WRITE(*, *) 'Box gradient analytical = ', DFA 
130:  
131:             IF (ABS(DFN - DFA) > ERRLIM) WRITE(*, *) IVRNO, DFN, DFA, ABS(DFN-DFA) 
132:  
133:          ENDDO 
134:       endif 
135:  60: 
136:       ELSE IF (CHECKDID == 2) THEN 61:       ELSE IF (CHECKDID == 2) THEN
137:  62: 
138:          IF (.NOT. ALLOCATED(HESS)) ALLOCATE(HESS(3*NATOMS,3*NATOMS)) 63:          IF (.NOT. ALLOCATED(HESS)) ALLOCATE(HESS(3*NATOMS,3*NATOMS))
139:  64: 
140:          DO IVRNO1 = 1, 3*NATOMS 65:          DO IVRNO1 = 1, 3*NATOMS
141:             DO IVRNO2 = 1, 3*NATOMS 66:             DO IVRNO2 = 1, 3*NATOMS
142:                WRITE(*,*) IVRNO1, IVRNO2 67:                WRITE(*,*) IVRNO1, IVRNO2
143:                X(IVRNO1) = X(IVRNO1) - DELX 68:                X(IVRNO1) = X(IVRNO1) - DELX
144:                CALL POTENTIAL (X,G,ENERGY,.TRUE.,.FALSE.) 69:                CALL POTENTIAL (X,G,ENERGY,.TRUE.,.FALSE.)


r33142/commons.f90 2017-08-08 12:30:10.434321379 +0100 r33141/commons.f90 2017-08-08 12:30:14.546376358 +0100
 34:      &        BINARY_EXAB_FRQ, NRESMIN, USERES, EXEQ, NONEDAPBC, STRUC, CHEMSHIFTITER, GRIDSIZE, MFETRUNS, BESTINVERT, GCNATOMS, & 34:      &        BINARY_EXAB_FRQ, NRESMIN, USERES, EXEQ, NONEDAPBC, STRUC, CHEMSHIFTITER, GRIDSIZE, MFETRUNS, BESTINVERT, GCNATOMS, &
 35:      &        GCINT, GCRELAX, MTARGETS, & 35:      &        GCINT, GCRELAX, MTARGETS, &
 36:      &        INTCONSEP, INTREPSEP, NCONSTRAINTON, CPREPSEP, CPCONSEP, NCONGEOM, & 36:      &        INTCONSEP, INTREPSEP, NCONSTRAINTON, CPREPSEP, CPCONSEP, NCONGEOM, &
 37:      &        NCPREPULSIVE, NCPCONSTRAINT, MAXCONUSE, INTCONSTEPS, INTRELSTEPS, INTSTEPS1, INTLJSTEPS, & 37:      &        NCPREPULSIVE, NCPCONSTRAINT, MAXCONUSE, INTCONSTEPS, INTRELSTEPS, INTSTEPS1, INTLJSTEPS, &
 38:      &        NTRAPPOW, MAXINTIMAGE, CHECKREPINTERVAL, INTFREEZEMIN, INTNTRIESMAX, INTIMAGEINCR, & 38:      &        NTRAPPOW, MAXINTIMAGE, CHECKREPINTERVAL, INTFREEZEMIN, INTNTRIESMAX, INTIMAGEINCR, &
 39:      &        NCONSTRAINTFIX, INTIMAGECHECK, NREPULSIVEFIX, INTIMAGE, NREPULSIVE, & 39:      &        NCONSTRAINTFIX, INTIMAGECHECK, NREPULSIVEFIX, INTIMAGE, NREPULSIVE, &
 40:      &        NNREPULSIVE, NCONSTRAINT, INTMUPDATE, DUMPINTEOSFREQ, DUMPINTXYZFREQ, & 40:      &        NNREPULSIVE, NCONSTRAINT, INTMUPDATE, DUMPINTEOSFREQ, DUMPINTXYZFREQ, &
 41:      &        LOCALPERMNEIGH, LOCALPERMMAXSEP, MAXNACTIVE, QCIPERMCHECKINT, & 41:      &        LOCALPERMNEIGH, LOCALPERMMAXSEP, MAXNACTIVE, QCIPERMCHECKINT, &
 42:      &        MLPIN, MLPSTART, MLPOUT, MLPHIDDEN, MLPDATA, NMLP, DJWRBID, NHEXAMERS, QCIADDREP, QCIBONDS, QCISECOND, MQUNIT, & 42:      &        MLPIN, MLPSTART, MLPOUT, MLPHIDDEN, MLPDATA, NMLP, DJWRBID, NHEXAMERS, QCIADDREP, QCIBONDS, QCISECOND, MQUNIT, &
 43:      &        MLQIN, MLQSTART, MLQOUT, MLQDATA, NMLQ, NADDTARGET, NUMNN, SQNM_HISTMAX, SQNM_DEBUGRUN, SQNM_DEBUGLEVEL, & 43:      &        MLQIN, MLQSTART, MLQOUT, MLQDATA, NMLQ, NADDTARGET, NUMNN, SQNM_HISTMAX, SQNM_DEBUGRUN, SQNM_DEBUGLEVEL, &
 44:      &        SQNM_WRITEMAX, NEWALDREAL(3), NEWALDRECIP(3), EWALDN, MLPNEIGH, BOXSTEPFREQ 44:      &        SQNM_WRITEMAX, NEWALDREAL(3), NEWALDRECIP(3), EWALDN, MLPNEIGH
 45:       DOUBLE PRECISION RHO, GAMMA, SIG, SCEPS, SCC, TOLB, T12FAC, XMOVERENORM, RESIZE, QTSALLIS, & 45:       DOUBLE PRECISION RHO, GAMMA, SIG, SCEPS, SCC, TOLB, T12FAC, XMOVERENORM, RESIZE, QTSALLIS, &
 46:      &                 CQMAX, RADIUS, BQMAX,  MAXBFGS, DECAYPARAM, SYMTOL1, SYMTOL2, SYMTOL3, SYMTOL4, SYMTOL5, PGSYMTOLS(3),& 46:      &                 CQMAX, RADIUS, BQMAX,  MAXBFGS, DECAYPARAM, SYMTOL1, SYMTOL2, SYMTOL3, SYMTOL4, SYMTOL5, PGSYMTOLS(3),&
 47:      &                 ECONV, TOLD, TOLE, SYMREM(120,3,3), GMAX, CUTOFF, PCUT, EXPFAC, EXPD, CENTX, CENTY, CENTZ, & 47:      &                 ECONV, TOLD, TOLE, SYMREM(120,3,3), GMAX, CUTOFF, PCUT, EXPFAC, EXPD, CENTX, CENTY, CENTZ, &
 48:      &                 BOXLX, BOXLY, BOXLZ, BOX3D(3), PCUTOFF, SUPSTEP, SQUEEZER, SQUEEZED, COOPCUT, STOCKMU, STOCKLAMBDA, & 48:      &                 BOXLX, BOXLY, BOXLZ, BOX3D(3), PCUTOFF, SUPSTEP, SQUEEZER, SQUEEZED, COOPCUT, STOCKMU, STOCKLAMBDA, &
 49:      &                 TFAC(3), RMS, TEMPS, SACCRAT, CEIG, PNEWJUMP, EAMP, DISTFAC, ODDCHARGE, COULQ, COULSWAP, & 49:      &                 TFAC(3), RMS, TEMPS, SACCRAT, CEIG, PNEWJUMP, EAMP, DISTFAC, ODDCHARGE, COULQ, COULSWAP, &
 50:      &                 COULTEMP, APP, AMM, APM, XQP, XQM, ALPHAP, ALPHAM, ZSTAR, K_COMP, DGUESS, GUIDECUT, EFAC,& 50:      &                 COULTEMP, APP, AMM, APM, XQP, XQM, ALPHAP, ALPHAM, ZSTAR, K_COMP, DGUESS, GUIDECUT, EFAC,&
 51:      &                 TRENORM, HISTMIN, HISTMAX, HISTFAC, EPSSPHERE, FINALCUTOFF, SHELLPROB, RINGROTSCALE, & 51:      &                 TRENORM, HISTMIN, HISTMAX, HISTFAC, EPSSPHERE, FINALCUTOFF, SHELLPROB, RINGROTSCALE, &
 52:      &                 HISTFACMUL, HPERCENT, AVOIDDIST, MAXERISE, MAXEFALL, TSTART, MATDIFF, STICKYSIG, SDTOL, & 52:      &                 HISTFACMUL, HPERCENT, AVOIDDIST, MAXERISE, MAXEFALL, TSTART, MATDIFF, STICKYSIG, SDTOL, &
 53:      &                 MinimalTemperature, MaximalTemperature, SwapProb, hdistconstraint, COREFRAC, TSTAR, & 53:      &                 MinimalTemperature, MaximalTemperature, SwapProb, hdistconstraint, COREFRAC, TSTAR, &
 54:      &                 RK_R, RK_THETA,ARMA,ARMB, ExtrapolationPercent, lnHarmFreq, PTEMIN, PTEMAX, PTTMIN, PTTMAX, EXCHPROB, & 54:      &                 RK_R, RK_THETA,ARMA,ARMB, ExtrapolationPercent, lnHarmFreq, PTEMIN, PTEMAX, PTTMIN, PTTMAX, EXCHPROB, &
 79:      &                 MSTART,MFINISH,MBSTART1,MBFINISH1,MBSTART2,MBFINISH2,MBHEIGHT1,MBHEIGHT2,ME1,ME2,ME3, & 79:      &                 MSTART,MFINISH,MBSTART1,MBFINISH1,MBSTART2,MBFINISH2,MBHEIGHT1,MBHEIGHT2,ME1,ME2,ME3, &
 80:      &                 BSPTQMAX, BSPTQMIN, PFORCE, CSMNORM, CSMGUIDENORM, CSMEPS, PERCCUT, PERCGROUPCUT, & 80:      &                 BSPTQMAX, BSPTQMIN, PFORCE, CSMNORM, CSMGUIDENORM, CSMEPS, PERCCUT, PERCGROUPCUT, &
 81:      &                 LOWESTE, PERTSTEP, GCPLUS, & 81:      &                 LOWESTE, PERTSTEP, GCPLUS, &
 82:      &                 KINT, INTFREEZETOL, IMSEPMIN, IMSEPMAX, CONCUTABS, CONCUTFRAC, & 82:      &                 KINT, INTFREEZETOL, IMSEPMIN, IMSEPMAX, CONCUTABS, CONCUTFRAC, &
 83:      &                 LPDGEOMDIFFTOL, INTCONFRAC, MAXCONE, INTRMSTOL, BFGSTSTOL, ORBITTOL, & 83:      &                 LPDGEOMDIFFTOL, INTCONFRAC, MAXCONE, INTRMSTOL, BFGSTSTOL, ORBITTOL, &
 84:      &                 INTCONSTRAINTTOL, INTCONSTRAINTDEL, RBCUTOFF, INTCONSTRAINTREP, INTCONSTRAINREPCUT, & 84:      &                 INTCONSTRAINTTOL, INTCONSTRAINTDEL, RBCUTOFF, INTCONSTRAINTREP, INTCONSTRAINREPCUT, &
 85:      &                 INTLJTOL, INTLJDEL, INTLJEPS, REPCON, INTDGUESS, CHECKREPCUTOFF, INTMINFAC, FREEZETOL, & 85:      &                 INTLJTOL, INTLJDEL, INTLJEPS, REPCON, INTDGUESS, CHECKREPCUTOFF, INTMINFAC, FREEZETOL, &
 86:      &                 LOCALPERMCUT, LOCALPERMCUT2, INTCONCUT, QCIRADSHIFT, MLPLAMBDA, & 86:      &                 LOCALPERMCUT, LOCALPERMCUT2, INTCONCUT, QCIRADSHIFT, MLPLAMBDA, &
 87:      &                 CAPSIDRHO,CAPSIDEPS,SIGMAPENT,RADPENT,SIGMAHEX,RADHEX,SIGMAPH, KLIM, SCA, & 87:      &                 CAPSIDRHO,CAPSIDEPS,SIGMAPENT,RADPENT,SIGMAHEX,RADHEX,SIGMAPH, KLIM, SCA, &
 88:      &                 QCIADDREPCUT, QCIADDREPEPS, MLQLAMBDA, TANHFAC, LJADDCUTOFF,LJADDREFNORM, & 88:      &                 QCIADDREPCUT, QCIADDREPEPS, MLQLAMBDA, TANHFAC, LJADDCUTOFF,LJADDREFNORM, &
 89:      &                 ALPHAATT, NNCUTOFF, BOX_PARAMS(6), BOX_PARAMSGRAD(6), BOX_PARAMSO(6) 89:      &                 ALPHAATT, NNCUTOFF
 90:  90: 
 91:       LOGICAL DEBUG, TARGET, MORSET, CUTT, SEEDT, CENT, TSALLIST, FREEZECORE, NEWJUMP, RENORM, CAPSID, FREEZE, & 91:       LOGICAL DEBUG, TARGET, MORSET, CUTT, SEEDT, CENT, TSALLIST, FREEZECORE, NEWJUMP, RENORM, CAPSID, FREEZE, &
 92:      &        OTPT, LJMFT, STRANDT, PAHT, SWT, MSTRANST, STOCKT, STICKYT, BLNT, MYSDT, FREEZERES, CENTXY, & 92:      &        OTPT, LJMFT, STRANDT, PAHT, SWT, MSTRANST, STOCKT, STICKYT, BLNT, MYSDT, FREEZERES, CENTXY, &
 93:      &        MSORIGT, SQUEEZET, PERIODIC, SCT, MSCT, MGUPTAT, RESIZET, TIP, RIGID, CALCQT, MPIT, GBHT, JMT, LJCOULT, LJ_GAUSST, OPPT, SETCENT, & 93:      &        MSORIGT, SQUEEZET, PERIODIC, SCT, MSCT, MGUPTAT, RESIZET, TIP, RIGID, CALCQT, MPIT, GBHT, JMT, LJCOULT, LJ_GAUSST, OPPT, SETCENT, &
 94:      &        SORTT, HIT, SAVEQ, PARALLELT, FIXD, RKMIN, BSMIN, PERMDIST, PERMOPT, BSWL, BSPT, BSPTRESTART, & 94:      &        SORTT, HIT, SAVEQ, PARALLELT, FIXD, RKMIN, BSMIN, PERMDIST, PERMOPT, BSWL, BSPT, BSPTRESTART, &
 95:      &        SYMMETRIZE, SYMMETRIZECSM, PRINT_PTGRP, PRINT_MINDATA, DUMPT, NEON, ARGON, P46, NORESET, TABOOT, EVSTEPT, PACHECO, DL_POLY, QUCENTRE, & 95:      &        SYMMETRIZE, SYMMETRIZECSM, PRINT_PTGRP, PRINT_MINDATA, DUMPT, NEON, ARGON, P46, NORESET, TABOOT, EVSTEPT, PACHECO, DL_POLY, QUCENTRE, &
 96:      &        STAR, PLUS, TWOPLUS, GROUND, DIPOLE, DFTBT, DFTBCT, SW, SUPERSTEP, EAMLJT, PBGLUET, TRACKDATAT, & 96:      &        STAR, PLUS, TWOPLUS, GROUND, DIPOLE, DFTBT, DFTBCT, SW, SUPERSTEP, EAMLJT, PBGLUET, TRACKDATAT, &
 97:      &        EAMALT, ALGLUET, MGGLUET, GUPTAT, LJATT, FST, DECAY, COOP, FIXBIN, GAUSST, QUENCHDOS, FIXDIHEFLAG, & 97:      &        EAMALT, ALGLUET, MGGLUET, GUPTAT, LJATT, FST, DECAY, COOP, FIXBIN, GAUSST, QUENCHDOS, FIXDIHEFLAG, &
 98:      &        FRAUSIT, ANGST, SELFT, STEPOUT, WENZEL, THRESHOLDT, THOMSONT, MULLERBROWNT, CHARMMENERGIES, & 98:      &        FRAUSIT, ANGST, SELFT, STEPOUT, WENZEL, THRESHOLDT, THOMSONT, MULLERBROWNT, CHARMMENERGIES, &
 99:      &        PROJ, RGCL2, TOSI, WELCH, AXTELL, AMBER, FIXIMAGE, BINARY, SHIFTCUT, ARNO, TUNNELT, TWOD, & 99:      &        PROJ, RGCL2, TOSI, WELCH, AXTELL, AMBER, FIXIMAGE, BINARY, SHIFTCUT, ARNO, TUNNELT, TWOD, &
115:      &        RESERVOIRT, DISTOPT, ONEDAPBCT, ONEDPBCT, TWODAPBCT, TWODPBCT, THREEDAPBCT, THREEDPBCT, RATIOT, &115:      &        RESERVOIRT, DISTOPT, ONEDAPBCT, ONEDPBCT, TWODAPBCT, TWODPBCT, THREEDAPBCT, THREEDPBCT, RATIOT, &
116:      &        PTRANDOM, PTINTERVAL, PTSINGLE, PTSETS, CHEMSHIFT, CHEMSHIFT2, CSH, DEBUGss2029, UNIFORMMOVE, RANSEEDT, &116:      &        PTRANDOM, PTINTERVAL, PTSINGLE, PTSETS, CHEMSHIFT, CHEMSHIFT2, CSH, DEBUGss2029, UNIFORMMOVE, RANSEEDT, &
117:      &        TTM3T, NOINVERSION, RIGIDCONTOURT, UPDATERIGIDREFT, HYBRIDMINT, COMPRESSRIGIDT, MWFILMT, &117:      &        TTM3T, NOINVERSION, RIGIDCONTOURT, UPDATERIGIDREFT, HYBRIDMINT, COMPRESSRIGIDT, MWFILMT, &
118:      &        SUPPRESST, MFETT, POLIRT, QUIPT, SWPOTT, MWPOTT, REPMATCHT, GLJT, MLJT, READMASST, SPECMASST, NEWTSALLIST, &118:      &        SUPPRESST, MFETT, POLIRT, QUIPT, SWPOTT, MWPOTT, REPMATCHT, GLJT, MLJT, READMASST, SPECMASST, NEWTSALLIST, &
119:      &        PHI4MODELT, CUDAT, CUDATIMET, AMBER12T, ENERGY_DECOMPT, NEWMOVEST, DUMPMINT, MBPOLT, MOLECULART, GCBHT, SEMIGRAND_MUT, USEROT, &119:      &        PHI4MODELT, CUDAT, CUDATIMET, AMBER12T, ENERGY_DECOMPT, NEWMOVEST, DUMPMINT, MBPOLT, MOLECULART, GCBHT, SEMIGRAND_MUT, USEROT, &
120:      &        SAVEMULTIMINONLY, GRADPROBLEMT, INTLJT, CONDATT, QCIPERMCHECK, RIGIDMBPOLT, &120:      &        SAVEMULTIMINONLY, GRADPROBLEMT, INTLJT, CONDATT, QCIPERMCHECK, RIGIDMBPOLT, &
121:      &        INTCONSTRAINTT, INTFREEZET, CHECKCONINT, CONCUTABST, CONCUTFRACT, INTERPCOSTFUNCTION, &121:      &        INTCONSTRAINTT, INTFREEZET, CHECKCONINT, CONCUTABST, CONCUTFRACT, INTERPCOSTFUNCTION, &
122:      &        RBAAT, FREEZENODEST, DUMPINTEOS, DUMPINTXYZ, QCIPOTT, QCIPOT2T, INTSPRINGACTIVET, LPERMDIST, LOCALPERMDIST, QCIRADSHIFTT, &122:      &        RBAAT, FREEZENODEST, DUMPINTEOS, DUMPINTXYZ, QCIPOTT, QCIPOT2T, INTSPRINGACTIVET, LPERMDIST, LOCALPERMDIST, QCIRADSHIFTT, &
123:      &        MLP3T, MKTRAPT, MLPB3T, MLPB3NEWT, MULTIPOTT, QCIAMBERT, MLPNEWREG, DJWRBT, STEALTHYT, LJADDT, QCINOREPINT, RIGIDMDT, &123:      &        MLP3T, MKTRAPT, MLPB3T, MLPB3NEWT, MULTIPOTT, QCIAMBERT, MLPNEWREG, DJWRBT, STEALTHYT, LJADDT, QCINOREPINT, RIGIDMDT, &
124:      &        DUMPMQT, MLQT, MLQPROB, LJADD2T, MLPVB3T, NOREGBIAS, PYADDT, PYADD2T, LJADD3T, REORDERADDT,  LJADD4T, &124:      &        DUMPMQT, MLQT, MLQPROB, LJADD2T, MLPVB3T, NOREGBIAS, PYADDT, PYADD2T, LJADD3T, REORDERADDT,  LJADD4T, &
125:      &        SQNMT, SQNM_DEBUGT, SQNM_BIOT, BENZRIGIDEWALDT, ORTHO, EWALDT, WATERMETHANET, MLPVB3NNT, CLATHRATET, LJADD3GUIDET, &125:      &        SQNMT, SQNM_DEBUGT, SQNM_BIOT, BENZRIGIDEWALDT, ORTHO, EWALDT, WATERMETHANET, MLPVB3NNT, CLATHRATET, LJADD3GUIDET
126:      &        BOXDERIVT 
127: !126: !
128:       DOUBLE PRECISION, ALLOCATABLE :: SEMIGRAND_MU(:)127:       DOUBLE PRECISION, ALLOCATABLE :: SEMIGRAND_MU(:)
129:       DOUBLE PRECISION, ALLOCATABLE :: ATMASS(:)128:       DOUBLE PRECISION, ALLOCATABLE :: ATMASS(:)
130:       DOUBLE PRECISION, ALLOCATABLE :: SPECMASS(:)129:       DOUBLE PRECISION, ALLOCATABLE :: SPECMASS(:)
131: 130: 
132: ! dj337: Ewald summation variables131: ! dj337: Ewald summation variables
133:       DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: RERHOARRAY, IMRHOARRAY132:       DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: RERHOARRAY, IMRHOARRAY
134: 133: 
135: ! csw34> FREEZEGROUP variables134: ! csw34> FREEZEGROUP variables
136: !135: !


r33142/ewald.f90 2017-08-08 12:30:10.658324373 +0100 r33141/ewald.f90 2017-08-08 12:30:14.774379402 +0100
  1: module ewald  1: module ewald
  2: use commons, only: natoms, stchrg, ortho, boxderivt, box_params, box_paramsgrad, &  2: use commons
  3: &                  ewaldalpha, ewaldrealc, ewaldrecipc 
  4:  
  5: implicit none  3: implicit none
  6:   4: 
  7: contains  5: contains
  8:   6: 
  9: ! -----------------------------------------------------------------------------------  7: ! ---------------------------------------
 10: ! dj337  8: ! HELPER FUNCTIONS
   9: ! ---------------------------------------
  10: ! ---------------------------------------
  11: ! dj337: calculates volume of cell given lattice vectors
  12: ! ---------------------------------------
  13:       subroutine volume(vol)
  14: 
  15:       use commons
  16: 
  17:       implicit none
  18: 
  19:       double precision :: vol
  20: 
  21:       if (ortho) then
  22:          vol = boxlx*boxly*boxlz
  23:       else
  24:          ! TODO: implement volume for non-orthorhombic boxes
  25:          print *, 'Volume has not been implemented for non-orthorhombic boxes!'
  26:       endif
  27: 
  28:       return
  29:       end subroutine
 11:  30: 
 12: ! COMPUTES ENERGY AND GRADIENT OF POTENTIALS USING EWALD SUMMATION. 31: ! ---------------------------------------
  32: ! dj337: Computes the energy and gradient of potentials using Ewald summation.
 13: ! Usable for any potential that satifisfies the equation: 33: ! Usable for any potential that satifisfies the equation:
 14: ! U_n = (1/2)*sum_L(sum_i,j(B_ij/(rij+L)**n)) 34: ! U_n = (1/2)*sum_L(sum_i,j(B_ij/(rij+L)**n))
 15: ! where n is any integer and L are lattice vectors. 35: ! where n is any integer and L are lattice vectors.
 16: ! A separate subroutine is used to calculate the special case for the 36: ! A separate subroutine is used to calculate the special case for the
 17: ! Coulomb potential (when n=1). 37: ! Coulomb potential (when n=1).
 18:  38: !
 19: ! All equations for energy and gradient of Coulomb summation follow from: 39: ! All equations for Coulomb summation follow from:
 20: ! Karasawa, N. and Goddard III, W. A. J. Phys. Chem., 93, 7320-7327 (1989). 40: ! Karasawa, N. and Goddard III, W. A. J. Phys. Chem., 93, 7320-7327 (1989).
 21:   41: ! 
 22: ! All input / output are in absolute Cartesian coordinates. 42: ! All input / output are in Cartesian coordinates
 23:  43: !
 24: ! Assuming all units for length, charge, and energy are in atomic units. 44: ! Assuming all units for length, charge, and energy are in atomic units.
 25:  45: ! ---------------------------------------
 26: ! Works for either orthorhombic or triclinic unit cells. Computes energy gradient wrt 
 27: ! cell parameters when BOXDERIVT keyword is true. 
 28: ! ----------------------------------------------------------------------------------- 
 29:       subroutine ewaldsum(n, x, g, etot, gtest) 46:       subroutine ewaldsum(n, x, g, etot, gtest)
 30:  47: 
 31:       use cartdist, only: get_reciplatvec, build_H 48:       use commons
  49:       use genrigid
 32:  50: 
 33:       implicit none 51:       implicit none
 34:  52: 
 35:       integer, intent(in)           :: n 53:       integer                       :: n
 36:       integer                       :: newaldreal(3), newaldrecip(3) 54:       logical                       :: gtest
 37:       logical, intent(in)           :: gtest 
 38:       double precision, intent(in)  :: x(3*natoms) 55:       double precision, intent(in)  :: x(3*natoms)
 39:       double precision, intent(out) :: etot, g(3*natoms) 56:       double precision, intent(out) :: g(3*natoms)
 40:       double precision              :: H(3,3), H_grad(3,3,6) 57:       double precision, intent(out) :: etot
 41:       double precision              :: reciplatvec(3,3), reciplatvec_grad(3,3,6) 
 42:       double precision, parameter   :: pi = 3.141592654d0 
 43:  58: 
 44:       etot = 0.0d0 59:       etot = 0.0d0
 45:       g(:) = 0.0d0 60:       g(:) = 0.0d0
 46:  61: 
 47:       if (n > 1) then 62:       if (n > 1) then
 48:          ! TODO: implement general Ewald summation 63:          ! TODO: implement general Ewald summation
 49:          print *, 'Ewald summation not yet implemented for n > 1!' 64:          print *, 'Ewald summation not yet implemented for n > 1!'
 50:          return 65:          return
 51:       else 66:       else
 52:          ! orthorhombic unit cell 
 53:          if (ortho) then 67:          if (ortho) then
 54:             ! determine number of lattice vectors to sum over 68:             call coulombreal(x, etot)
 55:             newaldreal(:) = floor(ewaldrealc/box_params(1:3) + 0.5d0) 69:             call coulombrecip(x, etot)
 56:             ! compute real-space contribution to energy 
 57:             call coulombreal_ortho(x, newaldreal, etot) 
 58:  
 59:             ! determine number of reciprocal lattice vectors to sum over 
 60:             newaldrecip(:) = floor(ewaldrecipc*box_params(1:3)/(2.0d0*pi)) 
 61:             ! compute reciprocal-space contribution to energy 
 62:             call coulombrecip_ortho(x, newaldrecip, etot) 
 63:  
 64:             if (gtest) then 70:             if (gtest) then
 65:                ! compute real-space contribution to gradient 71:                call coulombrealgrad(x, g)
 66:                call coulombrealgrad_ortho(x, newaldreal, g) 72:                call coulombrecipgrad(x, g)
 67:  
 68:                ! compute reciprocal-space contribution to gradient 
 69:                call coulombrecipgrad_ortho(x, newaldrecip, g) 
 70:             endif 73:             endif
 71:          ! triclinic unit cell 
 72:          else 74:          else
 73:             ! get reciprocal lattice vectors 75:             ! TODO: implement Coulomb for non-orthogonal lattice vectors
 74:             call get_reciplatvec(reciplatvec, reciplatvec_grad, .false.) 76:             print *, 'Ewald sums for Coulomb not yet implemented for non-orthorhombic!'
 75:             ! determine number of lattice vectors to sum over 77:             return
 76:             newaldreal(1) = floor(ewaldrealc*dsqrt(sum(reciplatvec(1,:)**2))/(2.0d0*pi) + 0.5d0) 78:          endif
 77:             newaldreal(2) = floor(ewaldrealc*dsqrt(sum(reciplatvec(2,:)**2))/(2.0d0*pi) + 0.5d0) 79:       endif
 78:             newaldreal(3) = floor(ewaldrealc*dsqrt(sum(reciplatvec(3,:)**2))/(2.0d0*pi) + 0.5d0) 
 79:             ! compute real-space contribution to energy 
 80:             call coulombreal_tri(x, newaldreal, etot) 
 81:  
 82:             ! get lattice vectors 
 83:             call build_H(H, H_grad, .false.) 
 84:             ! determine number of reciprocal lattice vectors to sum over 
 85:             newaldrecip(1) = floor(ewaldrecipc*dsqrt(sum(H(1,:)**2))/(2.0d0*pi)) 
 86:             newaldrecip(2) = floor(ewaldrecipc*dsqrt(sum(H(2,:)**2))/(2.0d0*pi)) 
 87:             newaldrecip(3) = floor(ewaldrecipc*dsqrt(sum(H(3,:)**2))/(2.0d0*pi)) 
 88:             ! compute reciprocal-space contribution to energy 
 89:             call coulombrecip_tri(x, newaldrecip, etot) 
 90:  
 91:             if (gtest) then 
 92:                ! compute real-space contribution to gradient 
 93:                call coulombrealgrad_tri(x, newaldreal, g) 
 94:  
 95:                ! compute reciprocal-space contribution to gradient 
 96:                call coulombrecipgrad_tri(x, newaldrecip, g) 
 97:             endif 
 98:          endif ! ortho or triclinic 
 99:       endif ! n < 1 
100:  80: 
101:       return 81:       return
102:       end subroutine ewaldsum 82:       end subroutine
103:  
104: ! ----------------------------------------------------------------------------------- 
105: ! Calculates short-range contribution to Coulomb sum energy. Also includes the self- 
106: ! correction term and subtracts within-rigidbody interactions, if needed. 
107:  83: 
108: ! Assumes orthorhombic unit cell. 84: ! ---------------------------------------
109: ! ----------------------------------------------------------------------------------- 85: ! dj337: Calculates energy contributions to Coulomb sum due to real-space
110:       subroutine coulombreal_ortho(x, newaldreal, ereal) 86: ! sum (i.e. point charges screened by oppositely charged Gaussian cloud) 
  87: ! and self correction.
  88: !
  89: ! Assumes orthogonal lattice vectors.
  90: ! ---------------------------------------
  91:       subroutine coulombreal(x, ereal)
111:  92: 
112:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody 93:       use commons
  94:       use genrigid, only: nrigidbody, nsiteperbody
113:  95: 
114:       implicit none 96:       implicit none
115:  97: 
116:       integer                         :: j1, j3, j2, j4, l, m, n, i 98:       integer                         :: j1, j3, j2, j4, l, m, n, i
117:       integer, intent(in)             :: newaldreal(3) 
118:       double precision, intent(in)    :: x(3*natoms) 99:       double precision, intent(in)    :: x(3*natoms)
119:       double precision                :: rmin(3), r(3)100:       double precision                :: rmin(3), r(3)
120:       double precision                :: q1, q2, sumq2, dist, dist2, ewaldrealc2101:       double precision                :: q1, q2, sumq2, dist, dist2, ewaldrealc2
121:       double precision                :: vshift, esum, eself, ewrb102:       double precision                :: vshift, esum, eself, ewrb
122:       double precision, intent(inout) :: ereal103:       double precision, intent(inout) :: ereal
123:       double precision, parameter     :: pi = 3.141592654D0104:       double precision, parameter     :: pi = 3.141592654D0
124: 105: 
125:       ! real-space cutoff106:       ! real-space cutoff
126:       ewaldrealc2 = ewaldrealc**2107:       ewaldrealc2 = ewaldrealc**2
127:       esum = 0.0d0108:       esum = 0.0d0
136:          ! iterate over atoms i > j117:          ! iterate over atoms i > j
137:          do j2 = j1+1, natoms118:          do j2 = j1+1, natoms
138:             j4 = 3*j2119:             j4 = 3*j2
139:             q2 = stchrg(j2)120:             q2 = stchrg(j2)
140: 121: 
141:             ! get distance between atoms122:             ! get distance between atoms
142:             rmin(1) = x(j3-2)-x(j4-2)123:             rmin(1) = x(j3-2)-x(j4-2)
143:             rmin(2) = x(j3-1)-x(j4-1)124:             rmin(2) = x(j3-1)-x(j4-1)
144:             rmin(3) = x(j3)-x(j4)125:             rmin(3) = x(j3)-x(j4)
145:             ! minimum image convention126:             ! minimum image convention
146:             rmin(1) = rmin(1)-box_params(1)*anint(rmin(1)/box_params(1))127:             rmin(1) = rmin(1)-boxlx*anint(rmin(1)/boxlx)
147:             rmin(2) = rmin(2)-box_params(2)*anint(rmin(2)/box_params(2))128:             rmin(2) = rmin(2)-boxly*anint(rmin(2)/boxly)
148:             rmin(3) = rmin(3)-box_params(3)*anint(rmin(3)/box_params(3))129:             rmin(3) = rmin(3)-boxlz*anint(rmin(3)/boxlz)
149: 130: 
150:             ! calculate vertical shift131:             ! calculate vertical shift
151:             vshift = q1*q2*erfc(ewaldalpha*ewaldrealc)/ewaldrealc132:             vshift = q1*q2*erfc(ewaldalpha*ewaldrealc)/ewaldrealc
152: 133: 
153:             ! iterate over boxes134:             ! iterate over boxes
154:             do l = -newaldreal(1), newaldreal(1)135:             do l = -newaldreal(1),newaldreal(1)
155:                r(1) = rmin(1)+box_params(1)*l136:                r(1) = rmin(1)+boxlx*l
156:                do m = -newaldreal(2), newaldreal(2)137:                do m = -newaldreal(2),newaldreal(2)
157:                   r(2) = rmin(2)+box_params(2)*m138:                   r(2) = rmin(2)+boxly*m
158:                   do n = -newaldreal(3), newaldreal(3)139:                   do n = -newaldreal(3),newaldreal(3)
159:                      r(3) = rmin(3)+box_params(3)*n140:                      r(3) = rmin(3)+boxlz*n
160:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2141:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2
161:                      if (dist2 < ewaldrealc2) then142:                      if (dist2 < ewaldrealc2) then
162:                         dist = dsqrt(dist2)143:                         dist = dsqrt(dist2)
163:                         ! calculate short-range contribution144:                         ! calculate short-range contribution
164:                         ! note: don't need factor of 1/2 bc summing over j,i>j145:                         ! note: don't need factor of 1/2 bc summing over j,i>j
165:                         esum = esum + q1*q2*erfc(ewaldalpha*dist)/dist - vshift146:                         esum = esum + q1*q2*erfc(ewaldalpha*dist)/dist - vshift
166:                      endif ! within cutoff147:                      endif
167:                   enddo ! n148:                   enddo
168:                enddo ! m149:                enddo
169:             enddo ! l150:             enddo
170:          enddo ! atoms j151:          enddo
171:       enddo ! atoms i152:       enddo
172: 153: 
173:       ! include contribution due to interaction of j1 with periodic images of itself154:       ! include contribution due to interaction of j1 with periodic images of itself
174:       ! (separated due to efficiency)155:       ! (separated due to efficiency)
175:       ! U_periodic-self = 0.5*sum_L(erfc(alpha*rL)/rL)*sum_i(Qi**2)156:       ! U_periodic-self = 0.5*sum_L(erfc(alpha*rL)/rL)*sum_i(Qi**2)
176:       sumq2 = 0.0d0157:       sumq2 = 0.0d0
177:       do j1 = 1, natoms158:       do j1 = 1, natoms
178:         q1 = stchrg(j1)159:         q1 = stchrg(j1)
179:         sumq2 = sumq2 + q1*q1160:         sumq2 = sumq2 + q1*q1
180:       enddo161:       enddo
181: 162: 
182:       ! calculate vertical shift163:       ! calculate vertical shift
183:       vshift = erfc(ewaldalpha*ewaldrealc)/(2*ewaldrealc)164:       vshift = erfc(ewaldalpha*ewaldrealc)/(2*ewaldrealc)
184: 165: 
185:       eself = 0.0d0166:       eself = 0.0d0
186:       ! iterate over boxes167:       ! iterate over boxes
187:       do l = -newaldreal(1), newaldreal(1)168:       do l = -newaldreal(1),newaldreal(1)
188:          r(1) = box_params(1)*l169:          r(1) = boxlx*l
189:          do m = -newaldreal(2), newaldreal(2)170:          do m = -newaldreal(2),newaldreal(2)
190:             r(2) = box_params(2)*m171:             r(2) = boxly*m
191:             do n = -newaldreal(3), newaldreal(3)172:             do n = -newaldreal(3),newaldreal(3)
192:                r(3) = box_params(3)*n173:                r(3) = boxlz*n
193:                ! check not in central box174:                ! check not in central box
194:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then175:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
195:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2176:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2
196:                   if (dist2 < ewaldrealc2) then177:                   if (dist2 < ewaldrealc2) then
197:                      dist = dsqrt(dist2)178:                      dist = dsqrt(dist2)
198:                      ! calculate short-range contribution179:                      ! calculate short-range contribution
199:                      ! note: need factor of 1/2 to prevent double-counting180:                      ! note: need factor of 1/2 to prevent double-counting
200:                      eself = eself + erfc(ewaldalpha*dist)/(2.0d0*dist) - vshift181:                      eself = eself + erfc(ewaldalpha*dist)/(2.0d0*dist) - vshift
201:                   endif ! within cutoff182:                   endif
202:                endif ! not in central box183:                endif
203:             enddo ! n184:             enddo
204:          enddo ! m185:          enddo
205:       enddo ! l186:       enddo
206: 187: 
207:       esum = esum + sumq2*eself188:       esum = esum + sumq2*eself
208: 189: 
209:       ! compensate for within-rigidbody interactions190:       ! compensate for within-rigidbody interactions
210:       ! calculate within-rigidbody energy using exact Coulomb sum191:       ! calculate within-rigidbody energy using exact Coulomb sum
211:       ! U_wrb = sum_J(sum_i>j(Qij/rij))192:       ! U_wrb = sum_J(sum_i>j(Qij/rij))
212:       ! note: don't need factor of 1/2 because summing over i > j193:       ! note: don't need factor of 1/2 because summing over i > j
213:       if (rigidinit) then194:       ewrb = 0.0d0
214:          ewrb = 0.0d0195:       ! iterate over rigidbodies
215:          ! iterate over rigidbodies196:       do i = 1, nrigidbody
216:          do i = 1, nrigidbody197: 
217:    198:          ! iterate over atoms i
218:             ! iterate over atoms i199:          do j1 = 1, nsiteperbody(i)
219:             do j1 = 1, nsiteperbody(i)200:             j3 = 3*j1
220:                j3 = 3*j1201:             q1 = stchrg(j1)
221:                q1 = stchrg(j1)202: 
222:    203:             ! iterate over atoms i > j
223:                ! iterate over atoms i > j204:             do j2 = j1+1, nsiteperbody(i)
224:                do j2 = j1+1, nsiteperbody(i)205:                j4 = 3*j2
225:                   j4 = 3*j2206:                q2 = stchrg(j2)
226:                   q2 = stchrg(j2)207: 
227:    208:                ! calculate rij
228:                   ! calculate rij209:                r(1) = x(j3-2)-x(j4-2)
229:                   r(1) = x(j3-2)-x(j4-2)210:                r(2) = x(j3-1)-x(j4-1)
230:                   r(2) = x(j3-1)-x(j4-1)211:                r(3) = x(j3)-x(j4)
231:                   r(3) = x(j3)-x(j4)212:                dist2 = r(1)**2 + r(2)**2 + r(3)**2
232:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2213:                dist = dsqrt(dist2)
233:                   dist = dsqrt(dist2) 
234:     
235:                   ! calculate within-rigidbody contribution 
236:                   ewrb = ewrb + q1*q2/dist 
237:                enddo ! sites j 
238:             enddo ! sites i 
239:          enddo ! rigid bodies 
240:     
241:          ! subtract U_wrb 
242:          esum = esum - ewrb 
243:       endif ! rigidinit 
244:  
245:       ! compensate for contribution due to self-interaction 
246:       ! U_self-interaction = -alpha*sum_i(Qi**2)/sqrt(pi) 
247:       esum = esum - sumq2*ewaldalpha/dsqrt(pi) 
248:  
249:       ereal = ereal + esum 
250:  
251:       return 
252:       end subroutine coulombreal_ortho 
253: 214: 
254: ! -----------------------------------------------------------------------------------215:                ! calculate within-rigidbody contribution
255: ! Calculates short-range contribution to Coulomb sum energy. Also includes the self-216:                ewrb = ewrb + q1*q2/dist
256: ! correction term and subtracts within-rigidbody interactions, if needed.217:             enddo
257: 218:          enddo
258: ! Assumes triclinic unit cell. 
259: ! ----------------------------------------------------------------------------------- 
260:       subroutine coulombreal_tri(x, newaldreal, ereal) 
261:  
262:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, inversematrix 
263:       use cartdist, only: build_H 
264:  
265:       implicit none 
266:  
267:       integer                         :: j1, j3, j2, j4, l, m, n, i 
268:       integer, intent(in)             :: newaldreal(3) 
269:       double precision, intent(in)    :: x(3*natoms) 
270:       double precision                :: rr(3), rrfracmin(3), rfrac(3), r(3) 
271:       double precision                :: q1, q2, sumq2, dist, dist2, ewaldrealc2 
272:       double precision                :: vshift, esum, eself, ewrb 
273:       double precision                :: H(3,3), H_grad(3,3,6), H_inverse(3,3) 
274:       double precision, intent(inout) :: ereal 
275:       double precision, parameter     :: pi = 3.141592654D0 
276:  
277:       ! real-space cutoff 
278:       ewaldrealc2 = ewaldrealc**2 
279:       esum = 0.0d0 
280:  
281:       ! get H matrix and inverse 
282:       call build_H(H, H_grad, .false.) 
283:       call inversematrix(H, H_inverse) 
284:  
285:       ! compute real-space sum 
286:       ! U_real-space = sum_L,i>j(Qij*erfc(alpha*rij)/rij) 
287:       ! iterate over atoms j 
288:       do j1 = 1, natoms 
289:          j3 = 3*j1 
290:          q1 = stchrg(j1) 
291:  
292:          ! iterate over atoms i > j 
293:          do j2 = j1+1, natoms 
294:             j4 = 3*j2 
295:             q2 = stchrg(j2) 
296:  
297:             ! get distance between atoms 
298:             rr(:) = x(j3-2:j3) - x(j4-2:j4) 
299:             ! convert to fractional coordinates 
300:             rrfracmin(:) = matmul(H_inverse, rr(:)) 
301:             ! minimum image convention 
302:             rrfracmin(1) = rrfracmin(1) - anint(rrfracmin(1)) 
303:             rrfracmin(2) = rrfracmin(2) - anint(rrfracmin(2)) 
304:             rrfracmin(3) = rrfracmin(3) - anint(rrfracmin(3)) 
305:  
306:             ! calculate vertical shift 
307:             vshift = q1*q2*erfc(ewaldalpha*ewaldrealc)/ewaldrealc 
308:  
309:             ! iterate over boxes 
310:             do l = -newaldreal(1), newaldreal(1) 
311:                rfrac(1) = rrfracmin(1) + l 
312:                do m = -newaldreal(2), newaldreal(2) 
313:                   rfrac(2) = rrfracmin(2) + m 
314:                   do n = -newaldreal(3), newaldreal(3) 
315:                      rfrac(3) = rrfracmin(3) + n 
316:  
317:                      ! convert to absolute coordinates 
318:                      r(:) = matmul(H, rfrac(:)) 
319:  
320:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2 
321:                      if (dist2 < ewaldrealc2) then 
322:                         dist = dsqrt(dist2) 
323:                         ! calculate short-range contribution 
324:                         ! note: don't need factor of 1/2 bc summing over j,i>j 
325:                         esum = esum + q1*q2*erfc(ewaldalpha*dist)/dist - vshift 
326:                      endif ! within cutoff 
327:                   enddo ! n 
328:                enddo ! m 
329:             enddo ! l 
330:          enddo ! atoms j 
331:       enddo ! atoms i 
332:  
333:       ! include contribution due to interaction of j1 with periodic images of itself 
334:       ! (separated due to efficiency) 
335:       ! U_periodic-self = 0.5*sum_L(erfc(alpha*rL)/rL)*sum_i(Qi**2) 
336:       sumq2 = 0.0d0 
337:       do j1 = 1, natoms 
338:         q1 = stchrg(j1) 
339:         sumq2 = sumq2 + q1*q1 
340:       enddo219:       enddo
341: 220: 
342:       ! calculate vertical shift221:       ! subtract U_wrb
343:       vshift = erfc(ewaldalpha*ewaldrealc)/(2*ewaldrealc)222:       esum = esum - ewrb
344:  
345:       eself = 0.0d0 
346:       ! iterate over boxes 
347:       do l = -newaldreal(1), newaldreal(1) 
348:          rfrac(1) = l 
349:          do m = -newaldreal(2), newaldreal(2) 
350:             rfrac(2) = m 
351:             do n = -newaldreal(3), newaldreal(3) 
352:                rfrac(3) = n 
353:  
354:                ! check not in central box 
355:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
356:                   ! convert from fractional to absolute 
357:                   r(:) = matmul(H, rfrac(:)) 
358:  
359:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2 
360:                   if (dist2 < ewaldrealc2) then 
361:                      dist = dsqrt(dist2) 
362:                      ! calculate short-range contribution 
363:                      ! note: need factor of 1/2 to prevent double-counting 
364:                      eself = eself + erfc(ewaldalpha*dist)/(2.0d0*dist) - vshift 
365:                   endif ! within cutoff 
366:                endif ! not in central box 
367:             enddo ! n 
368:          enddo ! m 
369:       enddo ! l 
370:  
371:       esum = esum + sumq2*eself 
372:  
373:       ! compensate for within-rigidbody interactions 
374:       ! calculate within-rigidbody energy using exact Coulomb sum 
375:       ! U_wrb = sum_J(sum_i>j(Qij/rij)) 
376:       ! note: don't need factor of 1/2 because summing over i > j 
377:       if (rigidinit) then 
378:          ewrb = 0.0d0 
379:          ! iterate over rigidbodies 
380:          do i = 1, nrigidbody 
381:     
382:             ! iterate over atoms i 
383:             do j1 = 1, nsiteperbody(i) 
384:                j3 = 3*j1 
385:                q1 = stchrg(j1) 
386:     
387:                ! iterate over atoms i > j 
388:                do j2 = j1+1, nsiteperbody(i) 
389:                   j4 = 3*j2 
390:                   q2 = stchrg(j2) 
391:     
392:                   ! calculate rij 
393:                   r(1) = x(j3-2)-x(j4-2) 
394:                   r(2) = x(j3-1)-x(j4-1) 
395:                   r(3) = x(j3)-x(j4) 
396:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2 
397:                   dist = dsqrt(dist2) 
398:     
399:                   ! calculate within-rigidbody contribution 
400:                   ewrb = ewrb + q1*q2/dist 
401:                enddo ! sites j 
402:             enddo ! sites i 
403:          enddo ! rigidbodies 
404:     
405:          ! subtract U_wrb 
406:          esum = esum - ewrb 
407:       endif ! rigidinit 
408: 223: 
409:       ! compensate for contribution due to self-interaction224:       ! compensate for contribution due to self-interaction
410:       ! U_self-interaction = -alpha*sum_i(Qi**2)/sqrt(pi)225:       ! U_self-interaction = -alpha*sum_i(Qi**2)/sqrt(pi)
411:       esum = esum - sumq2*ewaldalpha/dsqrt(pi)226:       esum = esum - sumq2*ewaldalpha/dsqrt(pi)
412: 227: 
413:       ereal = ereal + esum228:       ereal = ereal + esum
414: 229: 
415:       return230:       return
416:       end subroutine coulombreal_tri231:       end subroutine
417: 232: 
418: ! -----------------------------------------------------------------------------------233: ! ---------------------------------------
419: ! Calculates and stores terms that are needed to calculate structure factors,234: ! dj337: Calculates and stores terms that are needed to calculate structure
420: ! S(k) and S(-k), to facilitate the computation of the reciprocal-space part of the 235: ! factors, S(k)S(-k). Because the coefficient of the Coulomb term satisfies 
421: ! Ewald sum.236: ! the geometric combination rule (i.e. Qij = sqrt(Qii*Qjj)), structure 
422: 237: ! factors can be used to greatly simplify the computation of the 
423: ! Because the coefficient of the Coulomb term satisfies the geometric combination rule,238: ! reciprocal-space contributions to the energy and gradient.
424: ! Q_ij = sqrt(Q_ii*Q_jj), a summation over two indices can be converted to two239: !
425: ! summations over one index.240: ! Assumes orthogonal lattice vectors.
426: 241: ! ---------------------------------------
427: ! Assumes orthorhombic unit cell.242:       subroutine ftdensity(x)
428: ! ----------------------------------------------------------------------------------- 
429:       subroutine ftdensity_ortho(x, newaldrecip) 
430: 243: 
431:       use commons, only: rerhoarray, imrhoarray 244:       use commons 
432: 245: 
433:       implicit none246:       implicit none
434: 247: 
435:       integer                      :: j1, j3, l, m, n, dims(3)248:       integer                      :: j1, j3, l, m, n
436:       integer, intent(in)          :: newaldrecip(3) 
437:       double precision, intent(in) :: x(3*natoms)249:       double precision, intent(in) :: x(3*natoms)
438:       double precision             :: k(3), r(3)250:       double precision             :: k(3), r(3)
439:       double precision             :: q1, k2, kdotr, rerho, imrho, ewaldrecipc2251:       double precision             :: q1, k2, kdotr, rerho, imrho, ewaldrecipc2
440:       double precision, parameter  :: pi = 3.141592654D0252:       double precision, parameter  :: pi = 3.141592654D0
441: 253: 
442:       ! reciprocal-space cutoff254:       ! reciprocal-space cutoff
443:       ewaldrecipc2 = ewaldrecipc**2255:       ewaldrecipc2 = ewaldrecipc**2
444: 256: 
445:       ! make sure allocated arrays for structure factors are the correct size 
446:       dims(:) = 2*newaldrecip(1:3)+1  
447:       if (.not.allocated(rerhoarray)) allocate(rerhoarray(dims(1), dims(2), dims(3))) 
448:       if (.not.allocated(imrhoarray)) allocate(imrhoarray(dims(1), dims(2), dims(3))) 
449:  
450:       if (.not.(size(rerhoarray,1).eq.dims(1).and.size(rerhoarray,2).eq.dims(2).and.size(rerhoarray,3).eq.dims(3))) then 
451:          deallocate(rerhoarray)  
452:          deallocate(imrhoarray) 
453:          allocate(rerhoarray(dims(1), dims(2), dims(3))) 
454:          allocate(imrhoarray(dims(1), dims(2), dims(3))) 
455:       endif 
456:  
457:       ! iterate over boxes and calculate reciprocal lattice vectors 
458:       ! note: because of anti/symmetry in sine and cosine functions, 
459:       ! only need to calculate terms for half of the k-values 
460:       do l = 0,newaldrecip(1) 
461:          k(1) = 2*pi*l/box_params(1) 
462:          do m = -newaldrecip(2), newaldrecip(2) 
463:             k(2) = 2*pi*m/box_params(2) 
464:             do n = -newaldrecip(3), newaldrecip(3) 
465:                k(3) = 2*pi*n/box_params(3) 
466:                ! check not in central box 
467:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
468:                   k2 = k(1)**2 + k(2)**2 + k(3)**2 
469:                   rerho=0.0d0 
470:                   imrho=0.0d0 
471:                   if (k2 < ewaldrecipc2) then 
472:                      ! iterate over atoms 
473:                      do j1 = 1, natoms 
474:                         j3 = 3*j1 
475:                         q1 = stchrg(j1) 
476:                         r(:) = x(j3-2:j3) 
477:                         ! dot product of k and ri 
478:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3) 
479:                         ! rerho = sum_i(Qi*cos(k*ri)) 
480:                         rerho = rerho + q1*dcos(kdotr) 
481:                         ! imrho = sum_i(Qi*sin(k*ri)) 
482:                         imrho = imrho + q1*dsin(kdotr) 
483:                      enddo ! atoms 
484:                   endif ! within cutoff 
485:                   ! store rerho and imrho values 
486:                   rerhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = rerho 
487:                   rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = rerho 
488:                   imrhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = -imrho 
489:                   imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = imrho 
490:                endif ! not in central box 
491:             enddo ! n 
492:          enddo ! m 
493:       enddo ! l 
494:  
495:       return 
496:       end subroutine ftdensity_ortho 
497:  
498: ! ----------------------------------------------------------------------------------- 
499: ! Calculates and stores terms that are needed to calculate structure factors, 
500: ! S(k) and S(-k) to facilitate the computation of the reciprocal-space part of the  
501: ! Ewald sum. 
502:  
503: ! Because the coefficient of the Coulomb term satisfies the geometric combination rule, 
504: ! Q_ij = sqrt(Q_ii*Q_jj), a summation over two indices can be converted to two 
505: ! summations over one index. 
506:  
507: ! Assumes triclinic unit cell. 
508: ! ----------------------------------------------------------------------------------- 
509:       subroutine ftdensity_tri(x, newaldrecip) 
510:  
511:       use commons, only: rerhoarray, imrhoarray  
512:       use cartdist, only: get_reciplatvec 
513:  
514:       implicit none 
515:  
516:       integer                      :: j1, j3, l, m, n, dims(3) 
517:       integer, intent(in)          :: newaldrecip(3) 
518:       double precision, intent(in) :: x(3*natoms) 
519:       double precision             :: k(3), r(3), reciplatvec(3,3), reciplatvec_grad(3,3,6) 
520:       double precision             :: q1, k2, kdotr, rerho, imrho, ewaldrecipc2 
521:  
522:       ! reciprocal-space cutoff 
523:       ewaldrecipc2 = ewaldrecipc**2 
524:  
525:       ! make sure allocated arrays for structure factors are the correct size 
526:       dims(:) = 2*newaldrecip(1:3)+1  
527:       if (.not.allocated(rerhoarray)) allocate(rerhoarray(dims(1), dims(2), dims(3))) 
528:       if (.not.allocated(imrhoarray)) allocate(imrhoarray(dims(1), dims(2), dims(3))) 
529:  
530:       if (.not.(size(rerhoarray,1).eq.dims(1).and.size(rerhoarray,2).eq.dims(2).and.size(rerhoarray,3).eq.dims(3))) then 
531:          deallocate(rerhoarray)  
532:          deallocate(imrhoarray) 
533:          allocate(rerhoarray(dims(1), dims(2), dims(3))) 
534:          allocate(imrhoarray(dims(1), dims(2), dims(3))) 
535:       endif 
536:  
537:       ! get reciprocal lattice vectors 
538:       call get_reciplatvec(reciplatvec, reciplatvec_grad, .false.) 
539:  
540:       ! iterate over boxes and calculate reciprocal lattice vectors257:       ! iterate over boxes and calculate reciprocal lattice vectors
541:       ! note: because of anti/symmetry in sine and cosine functions,258:       ! note: because of anti/symmetry in sine and cosine functions,
542:       ! only need to calculate terms for half of the k-values259:       ! only need to calculate terms for half of the k-values
543:       do l = 0,newaldrecip(1)260:       do l = 0,newaldrecip(1)
544:          do m = -newaldrecip(2), newaldrecip(2)261:          k(1) = 2*pi*l/boxlx
545:             do n = -newaldrecip(3), newaldrecip(3)262:          do m = -newaldrecip(2),newaldrecip(2)
 263:             k(2) = 2*pi*m/boxly
 264:             do n = -newaldrecip(3),newaldrecip(3)
 265:                k(3) = 2*pi*n/boxlz
546:                ! check not in central box266:                ! check not in central box
547:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then267:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
548:                   k = l*reciplatvec(:,1) + m*reciplatvec(:,2) + n*reciplatvec(:,3) 
549:                   k2 = k(1)**2 + k(2)**2 + k(3)**2268:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
550:                   rerho=0.0d0 
551:                   imrho=0.0d0 
552:                   if (k2 < ewaldrecipc2) then269:                   if (k2 < ewaldrecipc2) then
 270:                      rerho=0.0d0
 271:                      imrho=0.0d0
553:                      ! iterate over atoms272:                      ! iterate over atoms
554:                      do j1 = 1, natoms273:                      do j1 = 1, natoms
555:                         j3 = 3*j1274:                         j3 = 3*j1
556:                         q1 = stchrg(j1)275:                         q1 = stchrg(j1)
557:                         r(:) = x(j3-2:j3)276:                         r(1) = x(j3-2)
 277:                         r(2) = x(j3-1)
 278:                         r(3) = x(j3)
558:                         ! dot product of k and ri279:                         ! dot product of k and ri
559:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3)280:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3)
560:                         ! rerho = sum_i(Qi*cos(k*ri))281:                         ! rerho = sum_i(Qi*cos(k*ri))
561:                         rerho = rerho + q1*dcos(kdotr)282:                         rerho = rerho + q1*dcos(kdotr)
562:                         ! imrho = sum_i(Qi*sin(k*ri))283:                         ! imrho = sum_i(Qi*sin(k*ri))
563:                         imrho = imrho + q1*dsin(kdotr)284:                         imrho = imrho + q1*dsin(kdotr)
564:                      enddo ! atoms285:                      enddo
565:                   endif ! within cutoff286:                   endif
566:                   ! store rerho and imrho values287:                   ! store rerho and imrho values
567:                   rerhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = rerho288:                   rerhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = rerho
568:                   rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = rerho289:                   rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = rerho
569:                   imrhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = -imrho290:                   imrhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = -imrho
570:                   imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = imrho291:                   imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = imrho
571:                endif ! not in central box292:                endif
572:             enddo ! n293:             enddo
573:          enddo ! m294:          enddo
574:       enddo ! l295:       enddo
575: 296: 
576:       return297:       return
577:       end subroutine ftdensity_tri298:       endsubroutine
578: 299: 
579: ! -----------------------------------------------------------------------------------300: ! ---------------------------------------
580: ! Calculates long-range contribution to Coulomb energy. Uses terms calculated by301: ! dj337: Calculates energy contributions to Coulomb sum due to
581: ! ftdensity_ortho subroutine (structure factors) to simplify computation.302: ! reciprocal-space sum. Uses terms calculated by ftdensity subroutine
582: 303: ! to use structure factors to simplify computation.
583: ! Assumes orthorhombic unit cell.304: !
584: ! -----------------------------------------------------------------------------------305: ! Assumes orthogonal lattice vectors.
585:       subroutine coulombrecip_ortho(x, newaldrecip, erecip)306: ! ---------------------------------------
586: 307:       subroutine coulombrecip(x, erecip)
587:       use commons, only: rerhoarray, imrhoarray 
588:       use cartdist, only: get_volume 
589: 308: 
590:       implicit none309:       implicit none
591: 310: 
592:       integer                         :: l, m, n311:       integer                         :: l, m, n
593:       integer, intent(in)             :: newaldrecip(3) 
594:       double precision, intent(in)    :: x(3*natoms)312:       double precision, intent(in)    :: x(3*natoms)
595:       double precision                :: vol, ewaldrecipc2, k(3)313:       double precision                :: k(3)
 314:       double precision                :: vol, ewaldrecipc2
596:       double precision                :: k2, rerho, imrho, esum315:       double precision                :: k2, rerho, imrho, esum
597:       double precision, intent(inout) :: erecip316:       double precision, intent(inout) :: erecip
598:       double precision, parameter     :: pi = 3.141592654D0317:       double precision, parameter     :: pi = 3.141592654D0
599: 318: 
600:       ! cell volume319:       ! cell volume
601:       call get_volume(vol)320:       call volume(vol)
602:       ! reciprocal-space cutoff321:       ! reciprocal-space cutoff
603:       ewaldrecipc2 = ewaldrecipc**2322:       ewaldrecipc2 = ewaldrecipc**2
604:       ! compute / store structure factors323:       call ftdensity(x)
605:       call ftdensity_ortho(x, newaldrecip) 
606:       esum = 0.0d0324:       esum = 0.0d0
607: 325: 
608:       ! compute reciprocal-space sum326:       ! compute reciprocal-space sum
609:       ! U_f = (2*pi/V)*(sum_k(exp(-k**2/4*alpha**2)*S(k)S(-k)/k**2)327:       ! U_f = (2*pi/V)*(sum_k(exp(-k**2/4*alpha**2)*S(k)S(-k)/k**2)
610:       ! iterate over boxes and calculate reciprocal lattice vectors328:       ! iterate over boxes and calculate reciprocal lattice vectors
611:       do l = -newaldrecip(1), newaldrecip(1)329:       do l = -newaldrecip(1), newaldrecip(1)
612:          k(1) = 2*pi*l/box_params(1)330:          k(1) = 2*pi*l/boxlx
613:          do m = -newaldrecip(2), newaldrecip(2)331:          do m = -newaldrecip(2), newaldrecip(2)
614:             k(2) = 2*pi*m/box_params(2)332:             k(2) = 2*pi*m/boxly
615:             do n = -newaldrecip(3), newaldrecip(3)333:             do n = -newaldrecip(3), newaldrecip(3)
616:                k(3) = 2*pi*n/box_params(3)334:                k(3) = 2*pi*n/boxlz
617:                ! check not in central box335:                ! check not in central box
618:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then336:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
619:                   k2 = k(1)**2 + k(2)**2 + k(3)**2337:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
620:                   if (k2 < ewaldrecipc2) then338:                   if (k2 < ewaldrecipc2) then
621:                      ! get structure factors 
622:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)339:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)
623:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)340:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)
624:                      ! calculate long-range contribution341:                      ! calculate long-range contribution
625:                      esum = esum + dexp(-k2/(4.0d0*ewaldalpha**2))*(rerho**2+imrho**2)/k2342:                      esum = esum + dexp(-k2/(4.0d0*ewaldalpha**2))*(rerho**2+imrho**2)/k2
626:                   endif ! within cutoff343:                   endif
627:                endif ! not in central box344:                endif
628:             enddo ! n345:             enddo
629:          enddo ! m346:          enddo
630:       enddo ! l347:       enddo
631:  
632:       ! multiply sum by factor of 2*pi/vol 
633:       erecip = erecip + 2.0d0*pi*esum/vol 
634:  
635:       return 
636:       end subroutine coulombrecip_ortho 
637:  
638: ! ----------------------------------------------------------------------------------- 
639: ! Calculates long-range contribution to Coulomb energy. Uses terms calculated by 
640: ! ftdensity_ortho subroutine (structure factors) to simplify computation. 
641:  
642: ! Assumes triclinic unit cell. 
643: ! ----------------------------------------------------------------------------------- 
644:       subroutine coulombrecip_tri(x, newaldrecip, erecip) 
645:  
646:       use commons, only: rerhoarray, imrhoarray 
647:       use cartdist, only: get_volume, get_reciplatvec 
648:  
649:       implicit none 
650:  
651:       integer                         :: l, m, n 
652:       integer, intent(in)             :: newaldrecip(3) 
653:       double precision, intent(in)    :: x(3*natoms) 
654:       double precision                :: reciplatvec(3,3), reciplatvec_grad(3,3,6), k(3) 
655:       double precision                :: vol, ewaldrecipc2, k2, rerho, imrho, esum 
656:       double precision, intent(inout) :: erecip 
657:       double precision, parameter     :: pi = 3.141592654D0 
658:  
659:       ! cell volume 
660:       call get_volume(vol) 
661:       ! reciprocal lattice vectors 
662:       call get_reciplatvec(reciplatvec, reciplatvec_grad, .false.) 
663:       ! reciprocal-space cutoff 
664:       ewaldrecipc2 = ewaldrecipc**2 
665:       ! compute / store structure factors 
666:       call ftdensity_tri(x, newaldrecip) 
667:       esum = 0.0d0 
668:  
669:       ! compute reciprocal-space sum 
670:       ! U_f = (2*pi/V)*(sum_k(exp(-k**2/4*alpha**2)*S(k)S(-k)/k**2) 
671:       ! iterate over boxes and calculate reciprocal lattice vectors 
672:       do l = -newaldrecip(1), newaldrecip(1) 
673:          do m = -newaldrecip(2), newaldrecip(2) 
674:             do n = -newaldrecip(3), newaldrecip(3) 
675:                ! check not in central box 
676:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
677:                   k = l*reciplatvec(:,1) + m*reciplatvec(:,2) + n*reciplatvec(:,3) 
678:                   k2 = k(1)**2 + k(2)**2 + k(3)**2 
679:                   if (k2 < ewaldrecipc2) then 
680:                      ! get structure factors 
681:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) 
682:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) 
683:                      ! calculate long-range contribution 
684:                      esum = esum + dexp(-k2/(4.0d0*ewaldalpha**2))*(rerho**2+imrho**2)/k2 
685:                   endif ! within cutoff 
686:                endif ! not in central box 
687:             enddo ! n 
688:          enddo ! m 
689:       enddo ! l 
690: 348: 
691:       ! multiply sum by factor of 2*pi/vol349:       ! multiply sum by factor of 2*pi/vol
692:       erecip = erecip + 2.0d0*pi*esum/vol350:       erecip = erecip + 2.0d0*pi*esum/vol
693: 351: 
694:       return352:       return
695:       end subroutine coulombrecip_tri353:       end subroutine
696: 354: 
697: ! -----------------------------------------------------------------------------------355: ! ---------------------------------------
698: ! Calculates the real-space contribution to the gradient with respects to atomic356: ! dj337: Calculates the real-space contribution to the gradient
699: ! positions. Also calculates real-space contribution to the gradient wrt lattice357: ! of the Coulomb sum. 
700: ! vectors, if BOXDERIVT is true.358: !
701: 359: ! Assumes orthogonal lattice vectors.
702: ! Assumes orthorhombic unit cell.360: ! ---------------------------------------
703: ! -----------------------------------------------------------------------------------361:       subroutine coulombrealgrad(x, g)
704:       subroutine coulombrealgrad_ortho(x, newaldreal, g) 
705: 362: 
706:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, gr_weights363:       use commons
707: 364: 
708:       implicit none365:       implicit none
709: 366: 
710:       integer                         :: j1, j3, j2, j4, l, m, n367:       integer                         :: j1, j3, j2, j4, l, m, n
711:       integer, intent(in)             :: newaldreal(3) 
712:       double precision, intent(in)    :: x(3*natoms)368:       double precision, intent(in)    :: x(3*natoms)
713:       double precision, intent(inout) :: g(3*natoms)369:       double precision, intent(inout) :: g(3*natoms)
714:       double precision                :: com(3), mass, comcoords(3*natoms)370:       double precision                :: r(3), rmin(3), f(3)
715:       double precision                :: rss(3), rmin(3), r(3), rcommin(3), rcom(3), f(3)371:       double precision                :: ewaldrealc2
716:       double precision                :: ewaldrealc2, q1, q2, mul, dist, dist2372:       double precision                :: q1, q2, mul, dist, dist2
717:       double precision, parameter     :: pi = 3.141592654d0373:       double precision, parameter     :: pi = 3.141592654d0
718: 374: 
719:       ! if rigid bodies, calculate COM coordinates 
720:       ! to compute box derivatives 
721:       if (rigidinit.and.boxderivt) then 
722:          do j1 = 1, nrigidbody 
723:             ! calculate COM 
724:             com(:) = 0.0d0 
725:             mass = 0.0d0 
726:             do j2 = 1, nsiteperbody(j1) 
727:                j3 = rigidgroups(j2, j1) 
728:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3) 
729:                mass = mass + gr_weights(j3) 
730:             enddo 
731:             com(1:3) = com(1:3) / mass 
732:             ! store COM coords 
733:             do j2 = 1, nsiteperbody(j1) 
734:                j3 = rigidgroups(j2, j1) 
735:                comcoords(3*j3-2:3*j3) = com(1:3) 
736:             enddo 
737:          enddo 
738:       endif 
739:  
740:       ! real-space cutoff375:       ! real-space cutoff
741:       ewaldrealc2 = ewaldrealc**2376:       ewaldrealc2 = ewaldrealc**2
742: 377: 
743:       ! compute real-space contribution to gradient378:       ! compute real-space contribution to gradient
744:       ! G_r = sum_L,i>j(-Qij*r*((erfc(alpha*rij)/(alpha*dist)**3) + 2*alpha*exp(-(alpha*rij)**2)/(sqrt(pi)*rij**2))379:       ! G_r = sum_L,i>j(-Qij*r*((erfc(alpha*rij)/(alpha*dist)**3) + 2*alpha*exp(-(alpha*rij)**2)/(sqrt(pi)*rij**2))
745:       ! iterate over atoms i380:       ! iterate over atoms i
746:       do j1 = 1, natoms381:       do j1 = 1, natoms
747:          j3 = 3*j1382:          j3 = 3*j1
748:          q1 = stchrg(j1)383:          q1 = stchrg(j1)
749: 384: 
750:          ! iterate over atoms i > j385:          ! iterate over atoms i > j
751:          do j2 = j1+1, natoms386:          do j2 = j1+1, natoms
752:             j4 = 3*j2387:             j4 = 3*j2
753:             q2 = stchrg(j2)388:             q2 = stchrg(j2)
754: 389: 
755:             ! get distance between atoms390:             ! get distance between atoms
756:             rss(1) = x(j3-2)-x(j4-2)391:             rmin(1) = x(j3-2)-x(j4-2)
757:             rss(2) = x(j3-1)-x(j4-1)392:             rmin(2) = x(j3-1)-x(j4-1)
758:             rss(3) = x(j3)-x(j4) 393:             rmin(3) = x(j3)-x(j4)
759:             ! minimum image convention394:             ! minimum image convention
760:             rmin(1) = rss(1) - box_params(1)*anint(rss(1)/box_params(1))395:             rmin(1) = rmin(1)-boxlx*anint(rmin(1)/boxlx)
761:             rmin(2) = rss(2) - box_params(2)*anint(rss(2)/box_params(2))396:             rmin(2) = rmin(2)-boxly*anint(rmin(2)/boxly)
762:             rmin(3) = rss(3) - box_params(3)*anint(rss(3)/box_params(3))397:             rmin(3) = rmin(3)-boxlz*anint(rmin(3)/boxlz)
763:  
764:             ! get minimum distance between COM 
765:             ! NOTE: use rss for minimum image convention to ensure COM corresponds to right atoms 
766:             if (rigidinit.and.boxderivt) then 
767:                rcommin(1) = comcoords(j3-2)-comcoords(j4-2) - box_params(1)*anint(rss(1)/box_params(1)) 
768:                rcommin(2) = comcoords(j3-1)-comcoords(j4-1) - box_params(2)*anint(rss(2)/box_params(2)) 
769:                rcommin(3) = comcoords(j3)-comcoords(j4) - box_params(3)*anint(rss(3)/box_params(3)) 
770:             endif 
771: 398: 
772:             ! get gradient contribution per box399:             ! get gradient contribution per box
773:             f(:) = 0.0d0400:             f(:) = 0.0d0
774: 401: 
775:             ! iterate over boxes402:             ! iterate over boxes
776:             do l = -newaldreal(1), newaldreal(1)403:             do l = -newaldreal(1),newaldreal(1)
777:                r(1) = rmin(1)+box_params(1)*l404:                r(1) = rmin(1)+boxlx*l
778:                do m = -newaldreal(2), newaldreal(2)405:                do m = -newaldreal(2),newaldreal(2)
779:                   r(2) = rmin(2)+box_params(2)*m406:                   r(2) = rmin(2)+boxly*m
780:                   do n = -newaldreal(3), newaldreal(3)407:                   do n = -newaldreal(3),newaldreal(3)
781:                      r(3) = rmin(3)+box_params(3)*n408:                      r(3) = rmin(3)+boxlz*n
782:  
783:                      if (rigidinit.and.boxderivt) then 
784:                         rcom(1) = rcommin(1)+box_params(1)*l 
785:                         rcom(2) = rcommin(2)+box_params(2)*m 
786:                         rcom(3) = rcommin(3)+box_params(3)*n 
787:                      endif 
788:  
789:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2409:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2
790:                      if (dist2 < ewaldrealc2) then410:                      if (dist2 < ewaldrealc2) then
791:                         dist = dsqrt(dist2)411:                         dist = dsqrt(dist2)
792:                         ! calculate short-range gradient contribution per box412:                         ! calculate short-range gradient contribution per box
793:                         mul = q1*q2*(erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2))413:                         mul = q1*q2*(erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist**2))
794:                         f(1) = f(1) + mul*r(1)414:                         f(1) = f(1) + mul*r(1)
795:                         f(2) = f(2) + mul*r(2)415:                         f(2) = f(2) + mul*r(2)
796:                         f(3) = f(3) + mul*r(3)416:                         f(3) = f(3) + mul*r(3)
797: 417:                      endif
798:                         ! compute contribution to box derivatives418:                   enddo
799:                         if (boxderivt) then419:                enddo
800:                            if (rigidinit) then420:             enddo
801:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) - mul*r(1:3)*rcom(1:3)/box_params(1:3) 
802:                            else ! not rigid bodies 
803:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) - mul*r(1:3)*r(1:3)/box_params(1:3) 
804:                            endif  
805:                         endif  
806:  
807:                      endif ! within cutoff 
808:                   enddo ! n 
809:                enddo ! m 
810:             enddo ! l 
811: 421: 
812:             ! add gradient contribution422:             ! add gradient contribution
813:             g(j3-2) = g(j3-2)-f(1)423:             g(j3-2) = g(j3-2)-f(1)
814:             g(j3-1) = g(j3-1)-f(2)424:             g(j3-1) = g(j3-1)-f(2)
815:             g(j3)   = g(j3)-f(3)425:             g(j3)   = g(j3)-f(3)
816:             g(j4-2) = g(j4-2)+f(1)426:             g(j4-2) = g(j4-2)+f(1)
817:             g(j4-1) = g(j4-1)+f(2)427:             g(j4-1) = g(j4-1)+f(2)
818:             g(j4)   = g(j4)+f(3)428:             g(j4)   = g(j4)+f(3)
819:          enddo ! atoms j429:          enddo
820:       enddo ! atoms i430:       enddo
821: 431: 
822:       ! include contribution due to interaction of j1 with periodic images of itself432:       ! include contribution due to interaction of j1 with periodic images of itself
823:       ! (separated due to efficiency)433:       ! (separated due to efficiency)
824:       ! G_periodic-self = sum_L(Qi**2*rL*(erfc(alpha*rL)/rL**3 + 2*alpha*exp(-(alpha*rL)**2)/(sqrt(pi)*rL**2)))434:       ! G_periodic-self = sum_L(Qi**2*rL*(erfc(alpha*rL)/rL**3 + 2*alpha*exp(-(alpha*rL)**2)/(sqrt(pi)*rL**2)))
825:       ! iterate over boxes435:       ! iterate over boxes
826:       do l = -newaldreal(1), newaldreal(1)436:       do l = -newaldreal(1),newaldreal(1)
827:          rmin(1) = box_params(1)*l437:          rmin(1) = boxlx*l
828:          do m = -newaldreal(2), newaldreal(2)438:          do m = -newaldreal(2),newaldreal(2)
829:             rmin(2) = box_params(2)*m439:             rmin(2) = boxly*m
830:             do n = -newaldreal(3), newaldreal(3)440:             do n = -newaldreal(3),newaldreal(3)
831:                rmin(3) = box_params(3)*n441:                rmin(3) = boxlz*n
832:                ! check not in central box442:                ! check not in central box
833:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then443:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
834:                   dist2 = rmin(1)**2 + rmin(2)**2 + rmin(3)**2444:                   dist2 = rmin(1)**2 + rmin(2)**2 + rmin(3)**2
835:                   if (dist2 < ewaldrealc2) then445:                   if (dist2 < ewaldrealc2) then
836:                      dist = dsqrt(dist2)446:                      dist = dsqrt(dist2)
837: 447:                      mul = erfc(ewaldalpha*dist)/dist**2 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist**2)
838:                      if (rigidinit.and.boxderivt) then 
839:                         rcom(1) = box_params(1)*l 
840:                         rcom(2) = box_params(2)*m 
841:                         rcom(3) = box_params(3)*n 
842:                      endif 
843:  
844:                      mul = erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2) 
845:                      ! iterate over atoms and calculate gradient terms448:                      ! iterate over atoms and calculate gradient terms
846:                      do j1 = 1, natoms449:                      do j1 = 1, natoms
847:                         j3 = 3*j1450:                         j3 = 3*j1
848:                         q1 = stchrg(j1)451:                         q1 = stchrg(j1)
849:                         g(j3-2) = g(j3-2) - q1*q1*mul*rmin(1)452:                         g(j3-2) = g(j3-2) - q1*q1*mul*rmin(1)
850:                         g(j3-1) = g(j3-1) - q1*q1*mul*rmin(2)453:                         g(j3-1) = g(j3-1) - q1*q1*mul*rmin(2)
851:                         g(j3)   = g(j3)   - q1*q1*mul*rmin(3)454:                         g(j3)   = g(j3)   - q1*q1*mul*rmin(3)
852: 455:                      enddo
853:                         ! compute contribution to box derivatives456:                   endif
854:                         if (boxderivt) then457:                endif
855:                            if (rigidinit) then 
856:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) - q1*q1*mul*rmin(1:3)*rcom(1:3)/box_params(1:3) 
857:                            else ! not rigid bodies 
858:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) + q1*q1*mul*rmin(1:3)*rmin(1:3)/box_params(1:3) 
859:                            endif 
860:                         endif  
861:  
862:                      enddo ! atoms 
863:                   endif ! within cutoff 
864:                endif ! not in central box 
865:             enddo ! n 
866:          enddo ! m 
867:       enddo ! l 
868:  
869:       return 
870:       end subroutine coulombrealgrad_ortho 
871:  
872: ! ----------------------------------------------------------------------------------- 
873: ! Calculates the real-space contribution to the gradient with respects to atomic 
874: ! positions. Also calculates real-space contribution to the gradient wrt lattice 
875: ! vectors, if BOXDERIVT is true. 
876:  
877: ! Assumes triclinic unit cell. 
878: ! ----------------------------------------------------------------------------------- 
879:       subroutine coulombrealgrad_tri(x, newaldreal, g) 
880:  
881:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, & 
882:       &                   gr_weights, inversematrix 
883:       use cartdist, only: build_H 
884:  
885:       implicit none 
886:  
887:       integer                         :: j1, j3, j2, j4, l, m, n, idx 
888:       integer, intent(in)             :: newaldreal(3) 
889:       double precision, intent(in)    :: x(3*natoms) 
890:       double precision, intent(inout) :: g(3*natoms) 
891:       double precision                :: com(3), mass, comcoords(3*natoms) 
892:       double precision                :: rr(3), rrfrac(3), rrfracmin(3), r(3), f(3) 
893:       double precision                :: rcom(3), rcomfracmin(3), rcomfrac(3) 
894:       double precision                :: H(3,3), H_grad(3,3,6), H_inverse(3,3) 
895:       double precision                :: ewaldrealc2, q1, q2, mul, dist, dist2 
896:       double precision, parameter     :: pi = 3.141592654d0 
897:  
898:       ! if rigid bodies, calculate COM coordinates 
899:       ! to compute box derivatives 
900:       if (rigidinit.and.boxderivt) then 
901:          do j1 = 1, nrigidbody 
902:             ! calculate COM 
903:             com(:) = 0.0d0 
904:             mass = 0.0d0 
905:             do j2 = 1, nsiteperbody(j1) 
906:                j3 = rigidgroups(j2, j1) 
907:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3) 
908:                mass = mass + gr_weights(j3) 
909:             enddo 
910:             com(1:3) = com(1:3) / mass 
911:             ! store COM coords 
912:             do j2 = 1, nsiteperbody(j1) 
913:                j3 = rigidgroups(j2, j1) 
914:                comcoords(3*j3-2:3*j3) = com(1:3) 
915:             enddo458:             enddo
916:          enddo459:          enddo
917:       endif460:       enddo
918:  
919:       ! real-space cutoff 
920:       ewaldrealc2 = ewaldrealc**2 
921:  
922:       ! get H matrix and inverse 
923:       call build_H(H, H_grad, boxderivt) 
924:       call inversematrix(H, H_inverse) 
925:  
926:       ! compute real-space contribution to gradient 
927:       ! G_r = sum_L,i>j(-Qij*r*((erfc(alpha*rij)/(alpha*dist)**3) + 2*alpha*exp(-(alpha*rij)**2)/(sqrt(pi)*rij**2)) 
928:       ! iterate over atoms i 
929:       do j1 = 1, natoms 
930:          j3 = 3*j1 
931:          q1 = stchrg(j1) 
932:  
933:          ! iterate over atoms i > j 
934:          do j2 = j1+1, natoms 
935:             j4 = 3*j2 
936:             q2 = stchrg(j2) 
937:  
938:             ! get distance between atoms 
939:             rr(:) = x(j3-2:j3) - x(j4-2:j4) 
940:             ! convert to fractional coordinates 
941:             rrfrac(:) = matmul(H_inverse, rr(:)) 
942:             ! minimum image convention 
943:             rrfracmin(1) = rrfrac(1) - anint(rrfrac(1)) 
944:             rrfracmin(2) = rrfrac(2) - anint(rrfrac(2)) 
945:             rrfracmin(3) = rrfrac(3) - anint(rrfrac(3)) 
946:  
947:             ! get minimum distance between COM 
948:             if (rigidinit.and.boxderivt) then 
949:                rcom(:) = comcoords(j3-2:j3) - comcoords(j4-2:j4) 
950:                ! convert to fractional coords 
951:                rcomfracmin(:) = matmul(H_inverse, rcom(:)) 
952:                ! minimum image convention 
953:                ! NOTE: use rrfrac for minimum image convention to ensure COM corresponds to right atoms 
954:                rcomfracmin(1) = rcomfracmin(1) - anint(rrfrac(1)) 
955:                rcomfracmin(2) = rcomfracmin(2) - anint(rrfrac(2)) 
956:                rcomfracmin(3) = rcomfracmin(3) - anint(rrfrac(3)) 
957:             endif 
958:  
959:             ! get gradient contribution per box 
960:             f(:) = 0.0d0 
961:  
962:             ! iterate over boxes 
963:             do l = -newaldreal(1), newaldreal(1) 
964:                rrfrac(1) = rrfracmin(1) + l 
965:                do m = -newaldreal(2), newaldreal(2) 
966:                   rrfrac(2) = rrfracmin(2) + m 
967:                   do n = -newaldreal(3), newaldreal(3) 
968:                      rrfrac(3) = rrfracmin(3) + n 
969:  
970:                      ! convert to absolute coordinates 
971:                      r(:) = matmul(H, rrfrac(:)) 
972:  
973:                      if (rigidinit.and.boxderivt) then 
974:                         rcomfrac(1) = rcomfracmin(1) + l 
975:                         rcomfrac(2) = rcomfracmin(2) + m 
976:                         rcomfrac(3) = rcomfracmin(3) + n 
977:                      endif 
978:  
979:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2 
980:                      if (dist2 < ewaldrealc2) then 
981:                         dist = dsqrt(dist2) 
982:                         ! calculate short-range gradient contribution per box 
983:                         mul = q1*q2*(erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2)) 
984:                         f(1) = f(1) + mul*r(1) 
985:                         f(2) = f(2) + mul*r(2) 
986:                         f(3) = f(3) + mul*r(3) 
987:  
988:                         ! compute contribution to box derivatives 
989:                         if (boxderivt) then 
990:                            if (rigidinit) then 
991:                               ! iterate over cell parameters 
992:                               do idx = 1,6 
993:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx),rcomfrac)) 
994:                               enddo 
995:                            else ! not rigid bodies 
996:                               ! iterate over cell parameters 
997:                               do idx = 1, 6 
998:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx), rrfrac)) 
999:                               enddo 
1000:                            endif  
1001:                         endif  
1002:  
1003:                      endif ! within cutoff 
1004:                   enddo ! n 
1005:                enddo ! m 
1006:             enddo ! l 
1007:  
1008:             ! add gradient contribution 
1009:             g(j3-2) = g(j3-2)-f(1) 
1010:             g(j3-1) = g(j3-1)-f(2) 
1011:             g(j3)   = g(j3)-f(3) 
1012:             g(j4-2) = g(j4-2)+f(1) 
1013:             g(j4-1) = g(j4-1)+f(2) 
1014:             g(j4)   = g(j4)+f(3) 
1015:          enddo ! atoms j 
1016:       enddo ! atoms i 
1017:  
1018:       ! include contribution due to interaction of j1 with periodic images of itself 
1019:       ! (separated due to efficiency) 
1020:       ! G_periodic-self = sum_L(Qi**2*rL*(erfc(alpha*rL)/rL**3 + 2*alpha*exp(-(alpha*rL)**2)/(sqrt(pi)*rL**2))) 
1021:       ! iterate over boxes 
1022:       do l = -newaldreal(1), newaldreal(1) 
1023:          rrfrac(1) = l 
1024:          do m = -newaldreal(2), newaldreal(2) 
1025:             rrfrac(2) = m 
1026:             do n = -newaldreal(3), newaldreal(3) 
1027:                rrfrac(3) = n 
1028:                ! check not in central box 
1029:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
1030:                   ! convert from fractional to absolute 
1031:                   r(:) = matmul(H, rrfrac(:)) 
1032:  
1033:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2 
1034:                   if (dist2 < ewaldrealc2) then 
1035:                      dist = dsqrt(dist2) 
1036:  
1037:                      if (rigidinit.and.boxderivt) then 
1038:                         rcomfrac(1) = l 
1039:                         rcomfrac(2) = m 
1040:                         rcomfrac(3) = n 
1041:                      endif 
1042:  
1043:                      mul = erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2) 
1044:                      ! iterate over atoms and calculate gradient terms 
1045:                      do j1 = 1, natoms 
1046:                         j3 = 3*j1 
1047:                         q1 = stchrg(j1) 
1048:                         g(j3-2) = g(j3-2) - q1*q1*mul*r(1) 
1049:                         g(j3-1) = g(j3-1) - q1*q1*mul*r(2) 
1050:                         g(j3)   = g(j3)   - q1*q1*mul*r(3) 
1051:  
1052:                         ! compute contribution to box derivatives 
1053:                         if (boxderivt) then 
1054:                            if (rigidinit) then 
1055:                               ! iterate over cell parameters 
1056:                               do idx = 1,6 
1057:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx),rcomfrac)) 
1058:                               enddo 
1059:                            else ! not rigid bodies 
1060:                               ! iterate over cell parameters 
1061:                               do idx = 1, 6 
1062:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx), rrfrac)) 
1063:                               enddo 
1064:                            endif 
1065:                         endif 
1066:  
1067:                      enddo ! atoms 
1068:                   endif ! within cutoff 
1069:                endif ! not in central box 
1070:             enddo ! n 
1071:          enddo ! m 
1072:       enddo ! l 
1073: 461: 
1074:       return462:       return
1075:       end subroutine coulombrealgrad_tri463:       endsubroutine
1076: 464: 
1077: ! -----------------------------------------------------------------------------------465: ! ---------------------------------------
1078: ! Calculates the reciprocal-space contribution to the gradient with respects to atomic466: ! dj337: Calculates the reipcrocal-space contribution to the gradient
1079: ! positions. Also calculates reciprocal-space contribution to the gradient wrt lattice467: ! of the Coulomb sum. Uses terms calculated by ftdensity subroutine
1080: ! vectors, if BOXDERIVT is true. Uses structure factors to simplify computation.468: ! to use structure factors to simplify computation.
1081: 469: !
1082: ! Assumes orthorhombic unit cell.470: ! Assumes orthogonal lattice vectors.
1083: ! -----------------------------------------------------------------------------------471: ! ---------------------------------------
1084:       subroutine coulombrecipgrad_ortho(x, newaldrecip, g)472:       subroutine coulombrecipgrad(x, g)
1085: 473: 
1086:       use commons, only: rerhoarray, imrhoarray474:       use commons
1087:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, gr_weights 
1088:       use cartdist, only: get_volume 
1089: 475: 
1090:       implicit none476:       implicit none
1091: 477: 
1092:       integer                         :: l, m, n, j1, j2, j3478:       integer                         :: l, m, n, j1, j3
1093:       integer, intent(in)             :: newaldrecip(3) 
1094:       double precision, intent(in)    :: x(3*natoms)479:       double precision, intent(in)    :: x(3*natoms)
1095:       double precision, intent(inout) :: g(3*natoms)480:       double precision, intent(inout) :: g(3*natoms)
1096:       double precision                :: vol, ewaldrecipc2, k(3), r(3)481:       double precision                :: k(3), r(3)
 482:       double precision                :: vol, ewaldrecipc2
1097:       double precision                :: k2, kdotr, rerho, imrho, q1, mul, mul2483:       double precision                :: k2, kdotr, rerho, imrho, q1, mul, mul2
1098:       double precision                :: com(3), mass, comcoords(3*natoms) 
1099:       double precision, parameter     :: pi = 3.141592654D0484:       double precision, parameter     :: pi = 3.141592654D0
1100: 485: 
1101:       ! cell volume486:       ! cell volume
1102:       call get_volume(vol)487:       call volume (vol)
1103:       ! reciprocal-space cutoff488:       ! reciprocal-space cutoff
1104:       ewaldrecipc2 = ewaldrecipc**2489:       ewaldrecipc2 = ewaldrecipc**2
1105: 490: 
1106:       ! if rigid bodies, compute COM coords 
1107:       ! to compute box derivatives 
1108:       if (rigidinit.and.boxderivt) then 
1109:          do j1 = 1, nrigidbody 
1110:             com(:) = 0.0d0 
1111:             mass = 0.0d0 
1112:             ! compute COM 
1113:             do j2 = 1, nsiteperbody(j1) 
1114:                j3 = rigidgroups(j2, j1) 
1115:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3) 
1116:                mass = mass + gr_weights(j3) 
1117:             enddo 
1118:             com(1:3) = com(1:3) / mass 
1119:             ! store COM coords 
1120:             do j2 = 1, nsiteperbody(j1) 
1121:                j3 = rigidgroups(j2, j1) 
1122:                comcoords(3*j3-2:3*j3) = com(1:3) 
1123:             enddo 
1124:          enddo 
1125:       endif 
1126:  
1127:       ! compute reciprocal-space gradient491:       ! compute reciprocal-space gradient
1128:       ! G_f = (-4*pi/vol)*q*sum_k((k/k2)*exp(-k2/4*alpha)*(sin(k*r)*sum_i(qi*cos(k*ri)) - cos(k*r)*sum_i(qi*sin(k*ri))))492:       ! G_f = (-4*pi/vol)*q*sum_k((k/k2)*exp(-k2/4*alpha)*(sin(k*r)*sum_i(qi*cos(k*ri)) - cos(k*r)*sum_i(qi*sin(k*ri))))
1129:       ! iterate over boxes and calculate repciprocal lattice vectors493:       ! iterate over boxes and calculate repciprocal lattice vectors
1130:       do l = -newaldrecip(1), newaldrecip(1)494:       do l = -newaldrecip(1), newaldrecip(1)
1131:          k(1) = 2*pi*l/box_params(1)495:          k(1) = 2*pi*l/boxlx
1132:          do m = -newaldrecip(2), newaldrecip(2)496:          do m = -newaldrecip(2), newaldrecip(2)
1133:             k(2) = 2*pi*m/box_params(2)497:             k(2) = 2*pi*m/boxly
1134:             do n = -newaldrecip(3), newaldrecip(3)498:             do n = -newaldrecip(3), newaldrecip(3)
1135:                k(3) = 2*pi*n/box_params(3)499:                k(3) = 2*pi*n/boxlz
1136:                ! check not in central box500:                ! check not in central box
1137:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then501:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
1138:                   k2 = k(1)**2 + k(2)**2 + k(3)**2502:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
1139:                   if (k2 < ewaldrecipc2) then503:                   if (k2 < ewaldrecipc2) then
1140:                      ! calculate multiplicative factor504:                      ! calculate multiplicative factor
1141:                      mul = -4.0d0*pi*dexp(-k2/(4.0d0*ewaldalpha**2))/(vol*k2)505:                      mul = -4*pi*dexp(-k2/(4.0d0*ewaldalpha**2))/(vol*k2)
1142:                      ! get structure factors 
1143:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)506:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)
1144:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)507:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)
1145:  
1146:                      ! add contribution to box derivatives 
1147:                      if (boxderivt) then 
1148:                         box_paramsgrad(1:3) = box_paramsgrad(1:3) + mul*(rerho**2+imrho**2)* & 
1149:                                               (1.0d0 - (k2 + 4.0d0*ewaldalpha**2)*k(1:3)*k(1:3)/ & 
1150:                                               (2.0d0*ewaldalpha**2*k2))/(2.0d0*box_params(1:3)) 
1151:                      endif 
1152:  
1153:                      ! iterate over atoms and calculate long-range gradient terms508:                      ! iterate over atoms and calculate long-range gradient terms
1154:                      do j1 = 1, natoms509:                      do j1 = 1,natoms
1155:                         j3 = 3*j1510:                         j3 = 3*j1
1156:                         r(:) = x(j3-2:j3)511:                         r(1) = x(j3-2)
 512:                         r(2) = x(j3-1)
 513:                         r(3) = x(j3)
1157:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3)514:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3)
1158:                         q1 = stchrg(j1)515:                         q1 = stchrg(j1)
1159:                         mul2 = mul*q1*(dsin(kdotr)*rerho - dcos(kdotr)*imrho)516:                         mul2 = mul*q1*(dsin(kdotr)*rerho - dcos(kdotr)*imrho)
1160:                          
1161:                         ! add contribution to gradient  
1162:                         g(j3-2) = g(j3-2) + mul2*k(1)517:                         g(j3-2) = g(j3-2) + mul2*k(1)
1163:                         g(j3-1) = g(j3-1) + mul2*k(2)518:                         g(j3-1) = g(j3-1) + mul2*k(2)
1164:                         g(j3)   = g(j3)   + mul2*k(3)519:                         g(j3)   = g(j3)   + mul2*k(3)
1165: 520:                      enddo
1166:                         ! add contribution to box derivatives from rigid bodies521:                   endif
1167:                         ! NOTE: no contribition if not using rigid bodies522:                endif
1168:                         if (rigidinit.and.boxderivt) then 
1169:                            box_paramsgrad(1:3) = box_paramsgrad(1:3) - mul2*k(1:3)*(x(j3-2:j3)-comcoords(j3-2:j3))/box_params(1:3) 
1170:                         endif 
1171:  
1172:                      enddo ! atoms 
1173:  
1174:                   endif ! within cutoff 
1175:                endif ! not in central box 
1176:             enddo ! n 
1177:          enddo ! m 
1178:       enddo ! l 
1179:  
1180:       return 
1181:       end subroutine coulombrecipgrad_ortho 
1182:  
1183: ! ----------------------------------------------------------------------------------- 
1184: ! Calculates the reciprocal-space contribution to the gradient with respects to atomic 
1185: ! positions. Also calculates reciprocal-space contribution to the gradient wrt lattice 
1186: ! vectors, if BOXDERIVT is true. Uses structure factors to simplify computation. 
1187:  
1188: ! Assumes triclinic unit cell. 
1189: ! ----------------------------------------------------------------------------------- 
1190:       subroutine coulombrecipgrad_tri(x, newaldrecip, g) 
1191:  
1192:       use commons, only: rerhoarray, imrhoarray 
1193:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, gr_weights, inversematrix 
1194:       use cartdist, only: get_volume, get_reciplatvec, build_H, cart2frac_tri 
1195:  
1196:       implicit none 
1197:  
1198:       integer                         :: l, m, n, j1, j2, j3, idx 
1199:       integer, intent(in)             :: newaldrecip(3) 
1200:       double precision, intent(in)    :: x(3*natoms) 
1201:       double precision, intent(inout) :: g(3*natoms) 
1202:       double precision                :: vol, ewaldrecipc2, c(3), s(3), abc, vfact, dvol(6), r(3) 
1203:       double precision                :: reciplatvec(3,3), reciplatvec_grad(3,3,6), xfrac(3*natoms) 
1204:       double precision                :: H(3,3), H_grad(3,3,6), H_inverse(3,3), k(3), k_grad(3,6) 
1205:       double precision                :: k2, kdotr, rerho, imrho, q1, mul, mul2 
1206:       double precision                :: com(3), mass, comcoords(3*natoms), comcoordsfrac(3*natoms) 
1207:       double precision, parameter     :: pi = 3.141592654D0 
1208:  
1209:       ! cell volume 
1210:       call get_volume(vol) 
1211:       ! gradient of volume wrt cell parameters 
1212:       if (boxderivt) then 
1213:          c(:) = dcos(box_params(4:6)) 
1214:          s(:) = dsin(box_params(4:6)) 
1215:          abc = box_params(1)*box_params(2)*box_params(3) 
1216:          vfact = vol/abc 
1217:          dvol(1) = vol/box_params(1) 
1218:          dvol(2) = vol/box_params(2) 
1219:          dvol(3) = vol/box_params(3) 
1220:          dvol(4) = s(1)*(c(1)-c(2)*c(3)) 
1221:          dvol(5) = s(2)*(c(2)-c(1)*c(3)) 
1222:          dvol(6) = s(3)*(c(3)-c(1)*c(2)) 
1223:          dvol(4:6) = abc*dvol(4:6)/vfact 
1224:       endif 
1225:  
1226:       ! reciprocal lattice vectors 
1227:       call get_reciplatvec(reciplatvec, reciplatvec_grad, boxderivt) 
1228:       ! get H matrix and inverse 
1229:       call build_H(H, H_grad, boxderivt) 
1230:       call inversematrix(H, H_inverse) 
1231:       ! get fractional coordinates 
1232:       if (boxderivt) call cart2frac_tri(x, xfrac, H_inverse) 
1233:       ! reciprocal-space cutoff 
1234:       ewaldrecipc2 = ewaldrecipc**2 
1235:  
1236:       ! if rigid bodies, compute COM coords 
1237:       ! to compute box derivatives 
1238:       if (rigidinit.and.boxderivt) then 
1239:          do j1 = 1, nrigidbody 
1240:             com(:) = 0.0d0 
1241:             mass = 0.0d0 
1242:             ! compute COM 
1243:             do j2 = 1, nsiteperbody(j1) 
1244:                j3 = rigidgroups(j2, j1) 
1245:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3) 
1246:                mass = mass + gr_weights(j3) 
1247:             enddo 
1248:             com(1:3) = com(1:3) / mass 
1249:             ! store COM coords 
1250:             do j2 = 1, nsiteperbody(j1) 
1251:                j3 = rigidgroups(j2, j1) 
1252:                comcoords(3*j3-2:3*j3) = com(1:3) 
1253:             enddo523:             enddo
1254:          enddo524:          enddo
1255:          ! convert to fractional525:       enddo
1256:          call cart2frac_tri(comcoords, comcoordsfrac, H_inverse) 
1257:       endif 
1258:  
1259:       ! compute reciprocal-space gradient 
1260:       ! G_f = (-4*pi/vol)*q*sum_k((k/k2)*exp(-k2/4*alpha)*(sin(k*r)*sum_i(qi*cos(k*ri)) - cos(k*r)*sum_i(qi*sin(k*ri)))) 
1261:       ! iterate over boxes and calculate repciprocal lattice vectors 
1262:       do l = -newaldrecip(1), newaldrecip(1) 
1263:          do m = -newaldrecip(2), newaldrecip(2) 
1264:             do n = -newaldrecip(3), newaldrecip(3) 
1265:                ! check not in central box 
1266:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
1267:                   k = l*reciplatvec(:,1) + m*reciplatvec(:,2) + n*reciplatvec(:,3) 
1268:                   k2 = k(1)**2 + k(2)**2 + k(3)**2 
1269:                   if (k2 < ewaldrecipc2) then 
1270:  
1271:                      ! get gradient of reciprocal lattice vector wrt cell parameters 
1272:                      if (boxderivt) then 
1273:                         do idx = 1,6 
1274:                            k_grad(:,idx) = l*reciplatvec_grad(:,1,idx) + m*reciplatvec_grad(:,2,idx) + n*reciplatvec_grad(:,3,idx) 
1275:                         enddo 
1276:                      endif 
1277:                       
1278:                      ! calculate multiplicative factor 
1279:                      mul = -4.0d0*pi*dexp(-k2/(4.0d0*ewaldalpha**2))/(vol*k2) 
1280:                      ! get structure factors 
1281:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) 
1282:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) 
1283:  
1284:                      ! add contribution to box derivatives 
1285:                      if (boxderivt) then 
1286:                         ! iterate over cell parameters 
1287:                         do idx = 1, 6 
1288:                             box_paramsgrad(idx) = box_paramsgrad(idx) + & 
1289:                                                   mul*(rerho**2+imrho**2)*(dvol(idx)/(2.0d0*vol) + & 
1290:                                                   (k2 + 4.0d0*ewaldalpha**2)*dot_product(k, k_grad(:,idx))/ & 
1291:                                                   (4.0d0*ewaldalpha**2*k2)) 
1292:                         enddo 
1293:                      endif 
1294:  
1295:                      ! iterate over atoms and calculate long-range gradient terms 
1296:                      do j1 = 1, natoms 
1297:                         j3 = 3*j1 
1298:                         r(:) = x(j3-2:j3) 
1299:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3) 
1300:                         q1 = stchrg(j1) 
1301:                         mul2 = mul*q1*(dsin(kdotr)*rerho - dcos(kdotr)*imrho) 
1302:                          
1303:                         ! add contribution to gradient  
1304:                         g(j3-2) = g(j3-2) + mul2*k(1) 
1305:                         g(j3-1) = g(j3-1) + mul2*k(2) 
1306:                         g(j3)   = g(j3)   + mul2*k(3) 
1307:  
1308:                         ! add contribution to box derivatives 
1309:                         if (boxderivt) then 
1310:                            if (rigidinit) then 
1311:                               ! iterate over cell parameters 
1312:                               do idx = 1,6 
1313:                                  box_paramsgrad(idx) = box_paramsgrad(idx) + & 
1314:                                                        mul2*(dot_product(k_grad(:,idx), r) + & 
1315:                                                        dot_product(k, matmul(H_grad(:,:,idx), comcoordsfrac(j3-2:j3)))) 
1316:                               enddo 
1317:                            else ! not rigid bodies 
1318:                               ! iterate over cell parameters 
1319:                               do idx = 1,6 
1320:                                  box_paramsgrad(idx) = box_paramsgrad(idx) + & 
1321:                                                        mul2*(dot_product(k_grad(:,idx), r) + & 
1322:                                                        dot_product(k, matmul(H_grad(:,:,idx), xfrac(j3-2:j3)))) 
1323:                               enddo 
1324:                            endif 
1325:                         endif 
1326:  
1327:                      enddo ! atoms 
1328:  
1329:                   endif ! within cutoff 
1330:                endif ! not in central box 
1331:             enddo ! n 
1332:          enddo ! m 
1333:       enddo ! l 
1334: 526: 
1335:       return527:       return
1336:       end subroutine coulombrecipgrad_tri528:       end subroutine
1337: 529: 
1338: end module530: end module


r33142/finalio.f90 2017-08-08 12:30:10.886327422 +0100 r33141/finalio.f90 2017-08-08 12:30:15.002382450 +0100
396:            WRITE(MYUNIT2,*) NATOMS396:            WRITE(MYUNIT2,*) NATOMS
397:            WRITE(MYUNIT2, '(2F20.10,I6,1X,E15.8E2)') &397:            WRITE(MYUNIT2, '(2F20.10,I6,1X,E15.8E2)') &
398:                 EDUMMY, LOG_PROD, NSYMOPS, ITDET398:                 EDUMMY, LOG_PROD, NSYMOPS, ITDET
399:            !399:            !
400:         ENDIF400:         ENDIF
401:         !401:         !
402:      ELSE ! <ds656402:      ELSE ! <ds656
403:         WRITE(MYUNIT2,10) J1, QMIN(J1), FF(J1), NPCALL_QMIN(J1)403:         WRITE(MYUNIT2,10) J1, QMIN(J1), FF(J1), NPCALL_QMIN(J1)
404: 10      FORMAT('Energy of minimum ',I6,'=',G20.10, &404: 10      FORMAT('Energy of minimum ',I6,'=',G20.10, &
405:              ' first found at step ',I8,' after ',I20,' function calls')405:              ' first found at step ',I8,' after ',I20,' function calls')
406:         ! dj337: write cell parameters 
407:         if (boxderivt) then 
408:            write(myunit2, *) 'Box lengths: ', boxq(j1,1:3) 
409:            if (.not.ortho) write(myunit2, *) 'Box angles: ', boxq(j1,4:6) 
410:         endif 
411:      ENDIF406:      ENDIF
412:      !407:      !
413:      IF (MSORIGT.OR.FRAUSIT) THEN408:      IF (MSORIGT.OR.FRAUSIT) THEN
414:         WRITE(MYUNIT2,20) (QMINP(J1,J2),J2=1,3*(NATOMS-NS))409:         WRITE(MYUNIT2,20) (QMINP(J1,J2),J2=1,3*(NATOMS-NS))
415: 20      FORMAT('Si',3F20.10)410: 20      FORMAT('Si',3F20.10)
416:      ELSE IF (MSTRANST) THEN411:      ELSE IF (MSTRANST) THEN
417:         WRITE(MYUNIT2,20) (QMINP(J1,J2),J2=1,3*(NATOMS-NS))412:         WRITE(MYUNIT2,20) (QMINP(J1,J2),J2=1,3*(NATOMS-NS))
418:      ELSE IF (RGCL2) THEN413:      ELSE IF (RGCL2) THEN
419:         WRITE(MYUNIT2,'(A,F20.10)') 'Cl 0.0 0.0 ', 0.995D0414:         WRITE(MYUNIT2,'(A,F20.10)') 'Cl 0.0 0.0 ', 0.995D0
420:         WRITE(MYUNIT2,'(A,F20.10)') 'Cl 0.0 0.0 ',-0.995D0415:         WRITE(MYUNIT2,'(A,F20.10)') 'Cl 0.0 0.0 ',-0.995D0


r33142/genrigid.f90 2017-08-08 12:30:11.110330415 +0100 r33141/genrigid.f90 2017-08-08 12:30:15.234385552 +0100
403:   CLOSE(222)403:   CLOSE(222)
404:   CALL GENRIGID_INITIALISE(INICOORDS)404:   CALL GENRIGID_INITIALISE(INICOORDS)
405: END SUBROUTINE GENRIGID_READ_FROM_FILE405: END SUBROUTINE GENRIGID_READ_FROM_FILE
406: 406: 
407: !-----------------------------------------------------------407: !-----------------------------------------------------------
408: 408: 
409: !-----------------------------------------------------------409: !-----------------------------------------------------------
410: 410: 
411: SUBROUTINE TRANSFORMRIGIDTOC (CMIN, CMAX, XCOORDS, XRIGIDCOORDS)411: SUBROUTINE TRANSFORMRIGIDTOC (CMIN, CMAX, XCOORDS, XRIGIDCOORDS)
412:       412:       
413:   USE COMMONS, ONLY: NATOMS, ORTHO, BOXDERIVT413:   USE COMMONS, ONLY: NATOMS
414:   USE CARTDIST 
415:   IMPLICIT NONE414:   IMPLICIT NONE
416:   415:   
417:   INTEGER :: J1, J2, J5, J7, J9416:   INTEGER :: J1, J2, J5, J7, J9
418:   INTEGER :: CMIN, CMAX417:   INTEGER :: CMIN, CMAX
419:   DOUBLE PRECISION :: P(3), RMI(3,3), DRMI1(3,3), DRMI2(3,3), DRMI3(3,3)418:   DOUBLE PRECISION :: P(3), RMI(3,3), DRMI1(3,3), DRMI2(3,3), DRMI3(3,3)
420:   DOUBLE PRECISION :: XRIGIDCOORDS(DEGFREEDOMS), XCOORDS(3*NATOMS)419:   DOUBLE PRECISION :: XRIGIDCOORDS(DEGFREEDOMS), XCOORDS(3*NATOMS)
421:   DOUBLE PRECISION :: XRFRAC(3*NATOMS), H(3,3), H_GRAD(3,3,6) ! dj337: fractional rigid body coords 
422:   DOUBLE PRECISION :: COM(3) ! center of mass420:   DOUBLE PRECISION :: COM(3) ! center of mass
423:   LOGICAL          :: GTEST !, ATOMTEST421:   LOGICAL          :: GTEST !, ATOMTEST
424:   DOUBLE PRECISION :: MLATTICE(3,3)422:   DOUBLE PRECISION :: MLATTICE(3,3)
425:   423:   
426:   GTEST = .FALSE.424:   GTEST = .FALSE.
427: 425: 
428:   ! dj337: convert rigidbody coords from fractional to absolute 
429:   if (boxderivt.and.rigidinit) then 
430:      xrfrac(1:degfreedoms) = xrigidcoords(1:degfreedoms) 
431:      if (ortho) then 
432:         call frac2cart_rb_ortho(nrigidbody, xrigidcoords, xrfrac) 
433:      else 
434:         call build_H(H, H_grad, .false.) 
435:         call frac2cart_rb_tri(nrigidbody, xrigidcoords, xrfrac, H) 
436:      endif 
437:   endif 
438:  
439: ! vr274 > are there additional lattice coordinates? If yes, setup transformation matrix426: ! vr274 > are there additional lattice coordinates? If yes, setup transformation matrix
440:   IF(HAS_LATTICE_COORDS) THEN427:   IF(HAS_LATTICE_COORDS) THEN
441:     CALL GET_LATTICE_MATRIX(XRIGIDCOORDS(DEGFREEDOMS-5:DEGFREEDOMS), MLATTICE)428:     CALL GET_LATTICE_MATRIX(XRIGIDCOORDS(DEGFREEDOMS-5:DEGFREEDOMS), MLATTICE)
442:   ELSE ! vr274 > otherwise identity matrix429:   ELSE ! vr274 > otherwise identity matrix
443:     MLATTICE = 0D0430:     MLATTICE = 0D0
444:     MLATTICE(1,1)=1d0431:     MLATTICE(1,1)=1d0
445:     MLATTICE(2,2)=1D0432:     MLATTICE(2,2)=1D0
446:     MLATTICE(3,3)=1D0433:     MLATTICE(3,3)=1D0
447:   ENDIF434:   ENDIF
448: 435: 
464:   ENDDO451:   ENDDO
465:   452:   
466: ! hk286 > now the single atoms453: ! hk286 > now the single atoms
467: ! vr274 > this copies lattice coordinates as well which is stored in last 2 atoms454: ! vr274 > this copies lattice coordinates as well which is stored in last 2 atoms
468:   IF (DEGFREEDOMS > 6 * NRIGIDBODY) THEN455:   IF (DEGFREEDOMS > 6 * NRIGIDBODY) THEN
469:      DO J1 = 1, (DEGFREEDOMS - 6*NRIGIDBODY)/3456:      DO J1 = 1, (DEGFREEDOMS - 6*NRIGIDBODY)/3
470:         J9 = RIGIDSINGLES(J1)457:         J9 = RIGIDSINGLES(J1)
471:         XCOORDS(3*J9-2:3*J9) = XRIGIDCOORDS(6*NRIGIDBODY + 3*J1-2:6*NRIGIDBODY + 3*J1)458:         XCOORDS(3*J9-2:3*J9) = XRIGIDCOORDS(6*NRIGIDBODY + 3*J1-2:6*NRIGIDBODY + 3*J1)
472:      ENDDO459:      ENDDO
473:   ENDIF460:   ENDIF
474:  
475:   ! dj337: restore rigid body coords as fractional 
476:   if (boxderivt.and.rigidinit) xrigidcoords(1:degfreedoms) = xrfrac(1:degfreedoms) 
477:       461:       
478: END SUBROUTINE TRANSFORMRIGIDTOC462: END SUBROUTINE TRANSFORMRIGIDTOC
479: 463: 
480: !----------------------------------------------------------464: !----------------------------------------------------------
481: 465: 
482: SUBROUTINE ROTATEINITIALREF ()466: SUBROUTINE ROTATEINITIALREF ()
483: IMPLICIT NONE467: IMPLICIT NONE
484: DOUBLE PRECISION :: P(3)468: DOUBLE PRECISION :: P(3)
485: INTEGER J1469: INTEGER J1
486: 470: 
508:   CALL RMDRVT(P, RMI, DRMI1, DRMI2, DRMI3, .FALSE.)  492:   CALL RMDRVT(P, RMI, DRMI1, DRMI2, DRMI3, .FALSE.)  
509:   DO J2 = 1, NSITEPERBODY(J1)493:   DO J2 = 1, NSITEPERBODY(J1)
510:      SITESRIGIDBODY(J2,:,J1) = MATMUL(RMI(:,:),SITESRIGIDBODY(J2,:,J1))494:      SITESRIGIDBODY(J2,:,J1) = MATMUL(RMI(:,:),SITESRIGIDBODY(J2,:,J1))
511:   ENDDO495:   ENDDO
512: 496: 
513: END SUBROUTINE REDEFINERIGIDREF497: END SUBROUTINE REDEFINERIGIDREF
514: 498: 
515: !----------------------------------------------------------499: !----------------------------------------------------------
516: 500: 
517: SUBROUTINE TRANSFORMCTORIGID (XCOORDS, XRIGIDCOORDS)501: SUBROUTINE TRANSFORMCTORIGID (XCOORDS, XRIGIDCOORDS)
518:   USE COMMONS, ONLY: NATOMS, PERMDIST, MYUNIT, ORTHO, BOXDERIVT502:   USE COMMONS, ONLY: NATOMS, PERMDIST, MYUNIT
519:   USE VEC3503:   USE VEC3
520:   USE ROTATIONS504:   USE ROTATIONS
521:   USE CARTDIST 
522:   IMPLICIT NONE505:   IMPLICIT NONE
523:   506:   
524:   INTEGER :: J1, J2, J9     !No of processor507:   INTEGER :: J1, J2, J9     !No of processor
525:   DOUBLE PRECISION :: P(3)508:   DOUBLE PRECISION :: P(3)
526:   DOUBLE PRECISION :: COM(3), PNORM, PT(3,3), PI(3,3), MASS509:   DOUBLE PRECISION :: COM(3), PNORM, PT(3,3), PI(3,3), MASS
527:   DOUBLE PRECISION :: XRIGIDCOORDS(DEGFREEDOMS), XCOORDS(3*NATOMS)510:   DOUBLE PRECISION :: XRIGIDCOORDS (DEGFREEDOMS), XCOORDS(3*NATOMS)
528:   DOUBLE PRECISION :: XRFRAC(3*NATOMS) ! dj337: fractional rigidbody coords 
529:   DOUBLE PRECISION :: H(3,3), H_GRAD(3,3,6), H_INV(3,3) ! dj337: for fractional rb 
530: 511: 
531: ! vr274 > lattice matrix and inverse512: ! vr274 > lattice matrix and inverse
532:   DOUBLE PRECISION MLATTICE(3,3), MLATTICEINV(3,3)513:   DOUBLE PRECISION MLATTICE(3,3), MLATTICEINV(3,3)
533:   INTEGER NLATTICECOORDS514:   INTEGER NLATTICECOORDS
534: 515: 
535: ! hk286 - extra variables for minpermdist516: ! hk286 - extra variables for minpermdist
536:   DOUBLE PRECISION :: D, DIST2, RMAT(3,3) 517:   DOUBLE PRECISION :: D, DIST2, RMAT(3,3) 
537:   DOUBLE PRECISION :: PP1(3*NATOMS), PP2(3*NATOMS)518:   DOUBLE PRECISION :: PP1(3*NATOMS), PP2(3*NATOMS)
538:   LOGICAL :: TEMPPERMDIST519:   LOGICAL :: TEMPPERMDIST
539: 520: 
 521:   !print *, 'transforming to rigid'
 522:   !print *, 'xcoords received: ', xcoords(:3*natoms)
 523: 
540: ! vr274 > if has lattice coordinates, setup matrices524: ! vr274 > if has lattice coordinates, setup matrices
541:   IF(HAS_LATTICE_COORDS) THEN525:   IF(HAS_LATTICE_COORDS) THEN
542:     NLATTICECOORDS=6526:     NLATTICECOORDS=6
543:     CALL GET_LATTICE_MATRIX(XCOORDS(3*NATOMS-5:3*NATOMS),MLATTICE)527:     CALL GET_LATTICE_MATRIX(XCOORDS(3*NATOMS-5:3*NATOMS),MLATTICE)
544:   ELSE528:   ELSE
545:     NLATTICECOORDS=0529:     NLATTICECOORDS=0
546:     MLATTICE=0530:     MLATTICE=0
547:     MLATTICE(1,1)=1531:     MLATTICE(1,1)=1
548:     MLATTICE(2,2)=1532:     MLATTICE(2,2)=1
549:     MLATTICE(3,3)=1533:     MLATTICE(3,3)=1
595:         ! vr274 > added lattice stuff579:         ! vr274 > added lattice stuff
596:         XRIGIDCOORDS(6*NRIGIDBODY + 3*J1-2:6*NRIGIDBODY + 3*J1) = MATMUL(MLATTICEINV, XCOORDS(3*J9-2:3*J9))580:         XRIGIDCOORDS(6*NRIGIDBODY + 3*J1-2:6*NRIGIDBODY + 3*J1) = MATMUL(MLATTICEINV, XCOORDS(3*J9-2:3*J9))
597:      ENDDO581:      ENDDO
598:   ENDIF582:   ENDIF
599: 583: 
600: ! vr274 > copy lattice coords584: ! vr274 > copy lattice coords
601:   IF(HAS_LATTICE_COORDS) THEN585:   IF(HAS_LATTICE_COORDS) THEN
602:     XRIGIDCOORDS(DEGFREEDOMS - 5:DEGFREEDOMS) =  XCOORDS(3*NATOMS-5:3*NATOMS)586:     XRIGIDCOORDS(DEGFREEDOMS - 5:DEGFREEDOMS) =  XCOORDS(3*NATOMS-5:3*NATOMS)
603:   ENDIF587:   ENDIF
604: 588: 
605:   ! dj337: if computing box derivatives, convert rb coords to fractional589:   !print *, 'after being transformed:'
606:   if (boxderivt.and.rigidinit) then590:   !print *, xrigidcoords(:3*natoms)
607:      if (ortho) then 
608:         call cart2frac_rb_ortho(nrigidbody, xrigidcoords, xrfrac) 
609:      else 
610:         call build_H(H, H_grad, .false.) 
611:         call inversematrix(H, H_inv) 
612:         call cart2frac_rb_tri(nrigidbody, xrigidcoords, xrfrac, H_inv) 
613:      endif 
614:      xrigidcoords(1:degfreedoms) = xrfrac(1:degfreedoms) 
615:   endif 
616: 591: 
617: END SUBROUTINE TRANSFORMCTORIGID592: END SUBROUTINE TRANSFORMCTORIGID
618: 593: 
619: !-----------------------------------------------------------594: !-----------------------------------------------------------
620: 595: 
621: SUBROUTINE TRANSFORMCTORIGID_OLD (XCOORDS, XRIGIDCOORDS)596: SUBROUTINE TRANSFORMCTORIGID_OLD (XCOORDS, XRIGIDCOORDS)
622: 597: 
623:   USE COMMONS, ONLY: NATOMS598:   USE COMMONS, ONLY: NATOMS
624:   USE VEC3599:   USE VEC3
625:   IMPLICIT NONE600:   IMPLICIT NONE


r33142/keywords.f 2017-08-08 12:30:11.338333465 +0100 r33141/keywords.f 2017-08-08 12:30:15.470388707 +0100
100:       CHARACTER(LEN=100) TOPFILE,PARFILE100:       CHARACTER(LEN=100) TOPFILE,PARFILE
101:       CHARACTER(LEN=20) UNSTRING101:       CHARACTER(LEN=20) UNSTRING
102:       DOUBLE PRECISION LJREPBB, LJATTBB, LJREPLL, LJATTLL, LJREPNN, LJATTNN,102:       DOUBLE PRECISION LJREPBB, LJATTBB, LJREPLL, LJATTLL, LJREPNN, LJATTNN,
103:      &                 HABLN, HBBLN, HCBLN, HDBLN, EABLN, EBBLN, ECBLN, EDBLN, TABLN, TBBLN, TCBLN, TDBLN103:      &                 HABLN, HBBLN, HCBLN, HDBLN, EABLN, EBBLN, ECBLN, EDBLN, TABLN, TBBLN, TCBLN, TDBLN
104:       DOUBLE PRECISION LJREPBL, LJATTBL, LJREPBN, LJATTBN, LJREPLN, LJATTLN104:       DOUBLE PRECISION LJREPBL, LJATTBL, LJREPBN, LJATTBN, LJREPLN, LJATTLN
105: 105: 
106: !     DC430 >106: !     DC430 >
107:       DOUBLE PRECISION :: LPL, LPR107:       DOUBLE PRECISION :: LPL, LPR
108:       LOGICAL          :: RBSYMTEST     ! jdf43>108:       LOGICAL          :: RBSYMTEST     ! jdf43>
109: 109: 
 110: !      DOUBLE PRECISION :: VOL ! dj337
110: !111: !
111: !       sf344> added stuff112: !       sf344> added stuff
112: !113: !
113:       CHARACTER(LEN=10) check1114:       CHARACTER(LEN=10) check1
114:       CHARACTER(LEN=1) readswitch115:       CHARACTER(LEN=1) readswitch
115:       CHARACTER(LEN=4) J1CHAR116:       CHARACTER(LEN=4) J1CHAR
116:       CHARACTER(LEN=20) J2CHAR117:       CHARACTER(LEN=20) J2CHAR
117:       INTEGER iostatus, groupsize, groupatom,groupoffset,axis1,axis2,EOF118:       INTEGER iostatus, groupsize, groupatom,groupoffset,axis1,axis2,EOF
118:       INTEGER LUNIT, GETUNIT119:       INTEGER LUNIT, GETUNIT
119: 120: 
1054:       BENZRIGIDEWALDT = .FALSE.1055:       BENZRIGIDEWALDT = .FALSE.
1055: 1056: 
1056: ! dj337: Ewald summation1057: ! dj337: Ewald summation
1057:       ORTHO = .TRUE.1058:       ORTHO = .TRUE.
1058:       EWALDT = .FALSE.1059:       EWALDT = .FALSE.
1059:       EWALDN = 11060:       EWALDN = 1
1060:       EWALDREALC = 10.0D01061:       EWALDREALC = 10.0D0
1061:       EWALDRECIPC = 3.0D01062:       EWALDRECIPC = 3.0D0
1062:       RSPEED = 1.0D01063:       RSPEED = 1.0D0
1063: 1064: 
1064: ! dj337: box derivatives 
1065:       BOXDERIVT = .FALSE. 
1066:       BOXSTEPFREQ = 1 
1067:  
1068: !--------------------------------!1065: !--------------------------------!
1069: ! hk286 > Generalised Thomson    !1066: ! hk286 > Generalised Thomson    !
1070: !--------------------------------!1067: !--------------------------------!
1071:       GTHOMSONT = .FALSE.1068:       GTHOMSONT = .FALSE.
1072:       GTHOMPOT = 11069:       GTHOMPOT = 1
1073: 1070: 
1074: ! hk286 > Damped group moves1071: ! hk286 > Damped group moves
1075:       DAMPEDGMOVET = .FALSE.1072:       DAMPEDGMOVET = .FALSE.
1076:       DMOVEFREQ = 11073:       DMOVEFREQ = 1
1077: 1074: 
3697:          IF (NITEMS.GT.2) CALL READF(EAMP)3694:          IF (NITEMS.GT.2) CALL READF(EAMP)
3698: 3695: 
3699: ! Commenting out this AMBER keyword that should be used only with PNM's hand-coded AMBER3696: ! Commenting out this AMBER keyword that should be used only with PNM's hand-coded AMBER
3700: !      ELSE IF (WORD.EQ.'FAKEWATER') THEN3697: !      ELSE IF (WORD.EQ.'FAKEWATER') THEN
3701: !         FAKEWATER=.TRUE.3698: !         FAKEWATER=.TRUE.
3702: !         WRITE (MYUNIT,'(A)') '**********************************************************'3699: !         WRITE (MYUNIT,'(A)') '**********************************************************'
3703: !         WRITE (MYUNIT,'(A)') '* DISTANCE DEPENDENT DIELECTRIC BEING USED - FAKE WATER! *'3700: !         WRITE (MYUNIT,'(A)') '* DISTANCE DEPENDENT DIELECTRIC BEING USED - FAKE WATER! *'
3704: !         WRITE (MYUNIT,'(A)') '**********************************************************'3701: !         WRITE (MYUNIT,'(A)') '**********************************************************'
3705: 3702: 
3706: ! ----------------------------------------------------------------------------------------3703: ! ----------------------------------------------------------------------------------------
3707: ! dj337: box derivatives keyword 
3708:       ELSE IF (WORD.EQ.'BOXDERIV') THEN 
3709:          BOXDERIVT = .TRUE. 
3710:  
3711:          ! read box lengths 
3712:          IF (NITEMS.GT.1) CALL READF(XX) 
3713:          BOX_PARAMS(1) = XX 
3714:          IF (NITEMS.GT.2) CALL READF(XX) 
3715:          BOX_PARAMS(2) = XX 
3716:          IF (NITEMS.GT.3) CALL READF(XX) 
3717:          BOX_PARAMS(3) = XX 
3718:  
3719:          ! read angles if provided 
3720:          IF (NITEMS.GT.4) THEN 
3721:             ! not orthorhombic 
3722:             ORTHO = .FALSE. 
3723:             CALL READF(XX) 
3724:             BOX_PARAMS(4) = XX 
3725:             IF (NITEMS.GT.5) THEN 
3726:                CALL READF(XX) 
3727:                BOX_PARAMS(5) = XX 
3728:             ENDIF 
3729:             IF (NITEMS.GT.6) THEN 
3730:                CALL READF(XX) 
3731:                BOX_PARAMS(6) = XX 
3732:             ENDIF 
3733:          ! otherwise set angles at pi/2 
3734:          ELSE 
3735:             BOX_PARAMS(4:6) = 1.57079632679D0 
3736:          ENDIF 
3737:  
3738: ! ---------------------------------------------------------------------------------------- 
3739: ! dj337: frequency with which to take BH steps in box parameters 
3740:  
3741:       ELSE IF (WORD.EQ.'BOXSTEP') THEN 
3742:  
3743:          IF (NITEMS.GT.1) CALL READI(BOXSTEPFREQ) 
3744:  
3745: ! ---------------------------------------------------------------------------------------- 
3746: ! dj337: pahagenrigid for benzene using Ewald summation3704: ! dj337: pahagenrigid for benzene using Ewald summation
3747: 3705: 
3748:       ELSE IF (WORD.EQ.'BENZRIGIDEWALD') THEN3706:       ELSE IF (WORD.EQ.'BENZRIGIDEWALD') THEN
3749: 3707: 
3750:          IF (.NOT.PERIODIC) THEN3708:          IF (.NOT.PERIODIC) THEN
3751:             WRITE(MYUNIT, '(A)') 'keyword> ERROR PERIODIC must be defined first in data file'3709:             WRITE(MYUNIT, '(A)') 'keyword> ERROR PERIODIC must be defined first in data file'
3752:             STOP3710:             STOP
3753:          ENDIF3711:          ENDIF
3754: 3712: 
3755:          BENZRIGIDEWALDT = .TRUE.3713:          BENZRIGIDEWALDT = .TRUE.
3756: 3714: 
3757:          IF (NITEMS.GT.1) CALL READF(EWALDREALC)3715:          IF (NITEMS.GT.1) CALL READF(EWALDREALC)
3758:          IF (NITEMS.GT.2) CALL READF(EWALDRECIPC)3716:          IF (NITEMS.GT.2) CALL READF(EWALDRECIPC)
3759: 3717: 
3760:          ! CALCULATE ALPHA = 5.6/L_MIN3718:          ! CALCULATE ALPHA = 5.6/L_MIN
3761:          EWALDALPHA = 5.6D0/12.0d03719:          EWALDALPHA = 5.6D0/MINVAL(BOX3D)
 3720: 
 3721:          ! SET NUMBER OF LATTICE AND RECIPROCAL LATTICE VECTORS
 3722:          NEWALDREAL(:) = 0
 3723: 
 3724:          NEWALDRECIP(1) = FLOOR(EWALDRECIPC*BOXLX/(2*PI))
 3725:          NEWALDRECIP(2) = FLOOR(EWALDRECIPC*BOXLY/(2*PI))
 3726:          NEWALDRECIP(3) = FLOOR(EWALDRECIPC*BOXLZ/(2*PI))
 3727: 
 3728:          ! ALLOCATE ARRAYS FOR STRUCTURE FACTORS
 3729:          ALLOCATE(RERHOARRAY(2*NEWALDRECIP(1)+1, 2*NEWALDRECIP(2)+1, 2*NEWALDRECIP(3)+1))
 3730:          ALLOCATE(IMRHOARRAY(2*NEWALDRECIP(1)+1, 2*NEWALDRECIP(2)+1, 2*NEWALDRECIP(3)+1))
3762: 3731: 
3763:          ! ALLOCATE BENZENE MOLECULE3732:          ! ALLOCATE BENZENE MOLECULE
3764:          NRBSITES = 123733:          NRBSITES = 12
3765:          ALLOCATE(SITE(NRBSITES,3))3734:          ALLOCATE(SITE(NRBSITES,3))
3766:          ALLOCATE(RBSTLA(NRBSITES,3))3735:          ALLOCATE(RBSTLA(NRBSITES,3))
3767:          CALL DEFPAHARIGID()3736:          CALL DEFPAHARIGID()
3768:          NCARBON = 63737:          NCARBON = 6
3769: 3738: 
3770: ! ----------------------------------------------------------------------------------------3739: ! ----------------------------------------------------------------------------------------
3771:       ! dj337: Ewald summation3740:       ! dj337: Ewald summation
3776:             STOP3745:             STOP
3777:          ENDIF3746:          ENDIF
3778: 3747: 
3779:          EWALDT = .TRUE.3748:          EWALDT = .TRUE.
3780: 3749: 
3781:          IF (NITEMS.GT.1) CALL READI(EWALDN)3750:          IF (NITEMS.GT.1) CALL READI(EWALDN)
3782:          IF (NITEMS.GT.2) CALL READF(EWALDREALC)3751:          IF (NITEMS.GT.2) CALL READF(EWALDREALC)
3783:          IF (NITEMS.GT.3) CALL READF(EWALDRECIPC)3752:          IF (NITEMS.GT.3) CALL READF(EWALDRECIPC)
3784:          IF (NITEMS.GT.4) CALL READF(RSPEED)3753:          IF (NITEMS.GT.4) CALL READF(RSPEED)
3785: 3754: 
 3755:          !VOL = BOXLX*BOXLY*BOXLZ
 3756:          !CALL VOLUME(VOL)
 3757:          ! calculate alpha value
 3758: !         EWALDALPHA = 0.28D0
 3759:          !EWALDALPHA = (RSPEED*(PI**3)*NATOMS/(VOL**2))**(1.0D0/6.0D0)
 3760: 
3786:          ewaldalpha = 5.6d0/minval(box3d)3761:          ewaldalpha = 5.6d0/minval(box3d)
3787: 3762: 
3788:          NRBSITES = 123763:          IF (ORTHO) THEN
 3764:             ! set number of lattice vectors
 3765:             NEWALDREAL(1) = FLOOR(EWALDREALC/BOXLX+0.5D0)
 3766:             NEWALDREAL(2) = FLOOR(EWALDREALC/BOXLY+0.5D0)
 3767:             NEWALDREAL(3) = FLOOR(EWALDREALC/BOXLZ+0.5D0)
 3768: 
 3769:             ! set number of reciprocal lattice vectors
 3770:             NEWALDRECIP(1) = FLOOR(EWALDRECIPC*BOXLX/(2*PI))
 3771:             NEWALDRECIP(2) = FLOOR(EWALDRECIPC*BOXLY/(2*PI))
 3772:             NEWALDRECIP(3) = FLOOR(EWALDRECIPC*BOXLZ/(2*PI))
 3773:          ELSE
 3774:             print *, 'Not yet implemented for non-orthorhombic boxes!'
 3775:             STOP
 3776:          ENDIF
 3777: 
 3778:          print *, 'alpha: ', ewaldalpha
 3779:          print *, 'nreal: ', newaldreal(:3)
 3780:          print *, 'nrecip: ', newaldrecip(:3)
 3781: 
 3782:          ALLOCATE(RERHOARRAY(2*NEWALDRECIP(1)+1, 2*NEWALDRECIP(2)+1, 2*NEWALDRECIP(3)+1))
 3783:          ALLOCATE(IMRHOARRAY(2*NEWALDRECIP(1)+1, 2*NEWALDRECIP(2)+1, 2*NEWALDRECIP(3)+1))
 3784: 
3789:          ALLOCATE(SITE(NRBSITES,3))3785:          ALLOCATE(SITE(NRBSITES,3))
3790:          ALLOCATE(RBSTLA(NRBSITES,3))3786:          ALLOCATE(RBSTLA(NRBSITES,3))
 3787:          ALLOCATE(STCHRG(NRBSITES))
3791: 3788: 
3792:          CALL DEFPAHARIGID()3789:          CALL DEFPAHARIGID()
3793:          NCARBON = 63790:          NCARBON = 6
3794:          !CALL DEFBENZENERIGID()3791:          CALL DEFBENZENERIGID()
3795: 3792: 
3796: ! ----------------------------------------------------------------------------------------3793: ! ----------------------------------------------------------------------------------------
3797: 3794: 
3798:       ELSE IF (WORD.EQ.'FAL') THEN3795:       ELSE IF (WORD.EQ.'FAL') THEN
3799:          FAL=.TRUE.3796:          FAL=.TRUE.
3800:       ELSE IF (WORD.EQ.'WATERMETHANE') THEN3797:       ELSE IF (WORD.EQ.'WATERMETHANE') THEN
3801:          WATERMETHANET=.TRUE.3798:          WATERMETHANET=.TRUE.
3802:       ELSE IF (WORD.EQ.'CLATHRATE') THEN3799:       ELSE IF (WORD.EQ.'CLATHRATE') THEN
3803:          CLATHRATET=.TRUE.3800:          CLATHRATET=.TRUE.
3804:          CALL READI(NWATER)3801:          CALL READI(NWATER)
5522:             BOXLY=BOXLX5519:             BOXLY=BOXLX
5523:             BOX3D(2) = BOX3D(1)5520:             BOX3D(2) = BOX3D(1)
5524:             BOXLZ=BOXLX5521:             BOXLZ=BOXLX
5525:             BOX3D(3) = BOX3D(1)5522:             BOX3D(3) = BOX3D(1)
5526:          ENDIF5523:          ENDIF
5527:          PI = 4.D0*DATAN(1.D0)5524:          PI = 4.D0*DATAN(1.D0)
5528:          PALPHA=PI/2.D05525:          PALPHA=PI/2.D0
5529:          PBETA=PALPHA5526:          PBETA=PALPHA
5530:          PGAMMA=PALPHA5527:          PGAMMA=PALPHA
5531:          IF (NITEMS.GT.4) THEN5528:          IF (NITEMS.GT.4) THEN
5532:             ORTHO = .FALSE. 
5533:             CALL READF(XX)5529:             CALL READF(XX)
5534:             PGAMMA=XX5530:             PGAMMA=PI*XX/180.D0
5535:          ENDIF5531:          ENDIF
5536:          IF (NITEMS.GT.6) THEN5532:          IF (NITEMS.GT.6) THEN
5537:             PALPHA=PGAMMA5533:             PALPHA=PGAMMA
5538:             CALL READF(XX)5534:             CALL READF(XX)
5539:             PBETA=XX5535:             PBETA=PI*XX/180.D0
5540:             CALL READF(XX)5536:             CALL READF(XX)
5541:             PGAMMA=XX5537:             PGAMMA=PI*XX/180.D0
5542:          ENDIF5538:          ENDIF
5543:  
5544:          ! dj337: also put into box_params vector 
5545:          box_params(1) = boxlx 
5546:          box_params(2) = boxly 
5547:          box_params(3) = boxlz 
5548:          box_params(4) = palpha 
5549:          box_params(5) = pbeta 
5550:          box_params(6) = pgamma 
5551: ! lower triangular lattice matrix5539: ! lower triangular lattice matrix
5552: !         LAT(3,3)=BOXLZ5540: !         LAT(3,3)=BOXLZ
5553: !         LAT(2,2)=BOXLY*SIN(PALPHA)5541: !         LAT(2,2)=BOXLY*SIN(PALPHA)
5554: !         LAT(3,2)=BOXLY*COS(PALPHA)5542: !         LAT(3,2)=BOXLY*COS(PALPHA)
5555: !         LAT(1,1)=BOXLX/SIN(PALPHA)*SQRT(1.D0-COS(PALPHA)**2-COS(PBETA)**2-COS(PGAMMA)**2+2D0*COS(PALPHA)*COS(PBETA)*COS(PGAMMA))5543: !         LAT(1,1)=BOXLX/SIN(PALPHA)*SQRT(1.D0-COS(PALPHA)**2-COS(PBETA)**2-COS(PGAMMA)**2+2D0*COS(PALPHA)*COS(PBETA)*COS(PGAMMA))
5556: !         LAT(2,1)=BOXLX*(COS(PGAMMA)-COS(PBETA)*SIN(PALPHA))/SIN(PALPHA)5544: !         LAT(2,1)=BOXLX*(COS(PGAMMA)-COS(PBETA)*SIN(PALPHA))/SIN(PALPHA)
5557: !         LAT(3,1)=BOXLX*COS(PBETA)5545: !         LAT(3,1)=BOXLX*COS(PBETA)
5558: 5546: 
5559: ! upper triangular lattice matrix5547: ! upper triangular lattice matrix
5560: 5548: 


r33142/ljpshift_new.f90 2017-08-08 12:30:11.558336405 +0100 r33141/ljpshift_new.f90 2017-08-08 12:30:15.694391700 +0100
  1: ! dj337: the following subroutine computes the LJ potential  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/GMIN/source/ljpshift_new.f90' in revision 33141
  2: ! for periodic systems without using minimum image convention 
  3: ! (i.e. uses neighbor lists). 
  4: ! NOTE: binary LJ not yet implemented 
  5:  
  6:       subroutine ljpshift_new(x, potel, g, gtest) 
  7:  
  8:       use commons, only: natoms, epsab, sigab, box_params, cutoff, & 
  9:                          boxderivt, ortho, box_params, box_paramsgrad 
 10:  
 11:       implicit none 
 12:       integer                       :: j1, j3, j2, j4, l, m, n, i 
 13:       double precision, intent(in)  :: x(3*natoms) 
 14:       logical, intent(in)           :: gtest 
 15:       double precision, intent(out) :: potel, g(3*natoms) 
 16:       double precision              :: eps, sig, sig6, rcut, rcut2, sigrc6 
 17:       double precision              :: const, rconst, dist2, idist2, idist6 
 18:       double precision              :: sig12, idist8, idist14, dvdr, dist, temp1(3), temp(3) 
 19:       double precision              :: val, eself, sigrc12, xj(3), rmin(3), r(3), temp2(3) 
 20:       integer                       :: cell_range(3) 
 21:  
 22:       ! define and calculate constants 
 23:       eps = epsab 
 24:       sig = sigab 
 25:       sig6 = sig**6 
 26:       sig12 = sig6**2 
 27:       rcut = cutoff*sig 
 28:       rcut2 = rcut**2 
 29:       sigrc6 = sig6/rcut**6 
 30:       sigrc12 = sigrc6**2 
 31:       const = 4.0d0*(sigrc6)-7.0d0*sigrc12 
 32:       rconst = (6.0d0*sigrc12-3.0d0*sigrc6)/rcut**2 
 33:  
 34:       potel = 0.0d0 
 35:       if (gtest) g(:) = 0.0d0 
 36:       box_paramsgrad(:) = 0.0d0 
 37:  
 38:       ! determine cell range needed for cutoff 
 39:       cell_range(:) = ceiling(rcut/box_params(1:3)) 
 40:  
 41:       ! iterate over atoms i 
 42:       do j1 = 1, natoms 
 43:          j3 = 3*j1 
 44:  
 45:          ! iterate over atoms j > i 
 46:          do j2 = j1+1, natoms 
 47:             j4 = 3*j2 
 48:  
 49:             rmin(1:3) = x(j3-2:j3) - x(j4-2:j4) 
 50:             rmin(1) = rmin(1) - box_params(1)*anint(rmin(1)/box_params(1)) 
 51:             rmin(2) = rmin(2) - box_params(2)*anint(rmin(2)/box_params(2)) 
 52:             rmin(3) = rmin(3) - box_params(3)*anint(rmin(3)/box_params(3)) 
 53:  
 54:             ! iterate over cells 
 55:             do l = -cell_range(1), cell_range(1) 
 56:                do m = -cell_range(2), cell_range(2) 
 57:                   do n = -cell_range(3), cell_range(3) 
 58:  
 59:                      ! calculate atom-atom separation 
 60:                      r(1) = rmin(1)+box_params(1)*l 
 61:                      r(2) = rmin(2)+box_params(2)*m 
 62:                      r(3) = rmin(3)+box_params(3)*n 
 63:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2 
 64:  
 65:                      ! check that distance within cutoff 
 66:                      if (dist2 < rcut2) then 
 67:                         idist2 = 1.d0/dist2 
 68:                         idist6 = idist2**3 
 69:  
 70:                         ! calculate contribution to energy 
 71:                         val = 4.d0*eps*(sig6*idist6*(sig6*idist6 - 1.0d0) + rconst*dist2 + const) 
 72:                         potel = potel + val 
 73:  
 74:                         if (gtest) then 
 75:                            idist8 = idist2*idist6 
 76:                            idist14 = idist8*idist6 
 77:  
 78:                            ! calculate partial wrt distance 
 79:                            dvdr = -8.0d0*eps*(3.0d0*(2.0d0*idist14*(sig12)-idist8*sig6)-rconst) 
 80:  
 81:                            ! add contribution to gradient 
 82:                            g(j3-2:j3) = g(j3-2:j3) + dvdr*r(1:3) 
 83:                            g(j4-2:j4) = g(j4-2:j4) - dvdr*r(1:3) 
 84:  
 85:                            if (boxderivt) then 
 86:                               if (ortho) then 
 87:                                  box_paramsgrad(1:3) = box_paramsgrad(1:3) + dvdr*r(1:3)*r(1:3)/box_params(1:3) 
 88:                               endif ! ortho 
 89:                            endif ! box derivatives 
 90:  
 91:                         endif ! gradient 
 92:  
 93:                      endif ! cutoff 
 94:  
 95:                   enddo ! n 
 96:                enddo ! m 
 97:             enddo ! l 
 98:  
 99:          enddo ! atoms j 
100:       enddo ! atoms i 
101:  
102:       ! add contribution of atoms with periodic images of itself 
103:       eself = 0.0d0 
104:  
105:       ! iterate over cells 
106:       do l = -cell_range(1), cell_range(1) 
107:          do m = -cell_range(2), cell_range(2) 
108:             do n = -cell_range(3), cell_range(3) 
109:  
110:                ! check that not in central cell 
111:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
112:  
113:                   ! calculate atom-atom separation 
114:                   r(1) = box_params(1)*l 
115:                   r(2) = box_params(2)*m 
116:                   r(3) = box_params(3)*n 
117:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2 
118:  
119:                   ! check that distance within cutoff 
120:                   if (dist2 < rcut2) then 
121:                      idist2 = 1.d0/dist2 
122:                      idist6 = idist2**3 
123:  
124:                      ! calculate contribution to energy 
125:                      val = 2.d0*eps*(sig6*idist6*(sig6*idist6 - 1.0d0) + rconst*dist2 + const) 
126:                      eself = eself + val 
127:  
128:                      if (gtest) then 
129:                         idist8 = idist2*idist6 
130:                         idist14 = idist8*idist6 
131:  
132:                         ! calculate partial wrt distance 
133:                         dvdr = -4.0d0*eps*(3.0d0*(2.0d0*idist14*(sig12)-idist8*sig6)-rconst) 
134:  
135:                         ! add contribution to gradient for each atom 
136:                         do j1 = 1, natoms 
137:                            j3 = 3*j1 
138:  
139:                            g(j3-2:j3) = g(j3-2:j3) + dvdr*r(1:3) 
140:  
141:                            if (boxderivt) then 
142:                               if (ortho) then 
143:                                  box_paramsgrad(1:3) = box_paramsgrad(1:3) + dvdr*r(1:3)*r(1:3)/box_params(1:3) 
144:                               endif ! ortho 
145:                            endif ! box derivatives 
146:  
147:                         enddo ! atoms 
148:  
149:                      endif ! gradient 
150:  
151:                   endif ! cutoff 
152:                endif ! central box 
153:             enddo ! n 
154:          enddo ! m 
155:       enddo ! l 
156:  
157:       ! multiply energy by number of atoms 
158:       eself = eself*natoms 
159:       ! total potential energy 
160:       potel = potel + eself 
161:  
162:       end subroutine ljpshift_new 


r33142/main.F 2017-08-08 12:30:11.782339401 +0100 r33141/main.F 2017-08-08 12:30:15.922394749 +0100
204: ! csw34> Tell the user how many degrees of freedom there are in the system204: ! csw34> Tell the user how many degrees of freedom there are in the system
205:           WRITE(MYUNIT, '(A,I15)') " genrigid> rbodyconfig used to specifiy rigid bodies, degrees of freedom now ", DEGFREEDOMS205:           WRITE(MYUNIT, '(A,I15)') " genrigid> rbodyconfig used to specifiy rigid bodies, degrees of freedom now ", DEGFREEDOMS
206:           IF (GCBHT) THEN206:           IF (GCBHT) THEN
207: ! csw34> Make sure we aren't running GCBH with rigid bodies - very dangerous! Could be done but only with great care...207: ! csw34> Make sure we aren't running GCBH with rigid bodies - very dangerous! Could be done but only with great care...
208:               WRITE(MYUNIT, '(A)') " genrigid> ERROR: cannot use rigid bodies with GCBH! Stopping."208:               WRITE(MYUNIT, '(A)') " genrigid> ERROR: cannot use rigid bodies with GCBH! Stopping."
209:               STOP                209:               STOP                
210:           END IF210:           END IF
211:       END IF211:       END IF
212: 212: 
213: ! dj337: allocate charges for benzenes213: ! dj337: allocate charges for benzenes
214:       if (benzrigidewaldt.or.ewaldt) then214:       if (benzrigidewaldt) then
215:          ALLOCATE(STCHRG(NRIGIDBODY*NRBSITES))215:          ALLOCATE(STCHRG(NRIGIDBODY*NRBSITES))
216:          CALL DEFBENZENERIGIDEWALD()216:          CALL DEFBENZENERIGIDEWALD()
217:       endif217:       endif
218: 218: 
 219: 
219:       IF (MULTIPOTT) THEN220:       IF (MULTIPOTT) THEN
220:           CALL MULTIPOT_INITIALISE()221:           CALL MULTIPOT_INITIALISE()
221:       ENDIF222:       ENDIF
222: 223: 
223:       IF (CUDAT) THEN224:       IF (CUDAT) THEN
224:          IF ((CUDAPOT .EQ. 'A') .AND. (.NOT. AMBER12T)) THEN225:          IF ((CUDAPOT .EQ. 'A') .AND. (.NOT. AMBER12T)) THEN
225:             WRITE(MYUNIT,'(A)') " main> The AMBER12 keyword must be used with 'CUDA A'. "226:             WRITE(MYUNIT,'(A)') " main> The AMBER12 keyword must be used with 'CUDA A'. "
226:             STOP227:             STOP
227:          END IF228:          END IF
228:          IF (DEBUG) THEN229:          IF (DEBUG) THEN
352: !        though - but only from xyz format! Is there a hidden353: !        though - but only from xyz format! Is there a hidden
353: !        conversion?354: !        conversion?
354: !         355: !         
355:          OPEN(UNIT=1,FILE='compare',STATUS='OLD')356:          OPEN(UNIT=1,FILE='compare',STATUS='OLD')
356:          READ(1,*) (COORCOMP(J1),J1=1,3*NATOMS)357:          READ(1,*) (COORCOMP(J1),J1=1,3*NATOMS)
357:          CLOSE(1)358:          CLOSE(1)
358:       ENDIF359:       ENDIF
359: 360: 
360:       ALLOCATE(FF(NSAVE),QMIN(MAX(NSAVE,1)))361:       ALLOCATE(FF(NSAVE),QMIN(MAX(NSAVE,1)))
361:       ALLOCATE(QMINP(NSAVE,3*NATOMSALLOC))362:       ALLOCATE(QMINP(NSAVE,3*NATOMSALLOC))
362:       ! dj337: allocate array for saving box parameters 
363:       if (boxderivt) allocate(boxq(nsave,6)) 
364:       ALLOCATE(QMINNATOMS(NSAVE))363:       ALLOCATE(QMINNATOMS(NSAVE))
365:       ALLOCATE(AVOIDNATOMS(MAXSAVE))364:       ALLOCATE(AVOIDNATOMS(MAXSAVE))
366:       ALLOCATE(QMINT(NSAVE,NATOMSALLOC))365:       ALLOCATE(QMINT(NSAVE,NATOMSALLOC))
367:       ALLOCATE(NPCALL_QMIN(NSAVE))366:       ALLOCATE(NPCALL_QMIN(NSAVE))
368:       IF (MONITORT) THEN367:       IF (MONITORT) THEN
369:          ALLOCATE(LOWESTC(3*NATOMSALLOC))368:          ALLOCATE(LOWESTC(3*NATOMSALLOC))
370:       ENDIF369:       ENDIF
371: 370: 
372: !        csw34> ALLOCATE the interaction energy tracking arrays if A9INTE in data371: !        csw34> ALLOCATE the interaction energy tracking arrays if A9INTE in data
373:       IF (A9INTET.AND.AMBERT) THEN 372:       IF (A9INTET.AND.AMBERT) THEN 
380: 379: 
381:       IF (GAUSST) THEN380:       IF (GAUSST) THEN
382:          ALLOCATE(GAUSSKK(3*NATOMSALLOC,GMODES),GAUSSEE(GMODES),GKSMALL(3*NATOMSALLOC))381:          ALLOCATE(GAUSSKK(3*NATOMSALLOC,GMODES),GAUSSEE(GMODES),GKSMALL(3*NATOMSALLOC))
383:          CALL KEGEN ! INITIAL SETUP 382:          CALL KEGEN ! INITIAL SETUP 
384:          DO J1=1,GMODES383:          DO J1=1,GMODES
385:              PRINT *,J1,GAUSSEE(J1)384:              PRINT *,J1,GAUSSEE(J1)
386:          ENDDO385:          ENDDO
387:       ENDIF386:       ENDIF
388: 387: 
389:       QMINP(1:NSAVE,1:3*NATOMSALLOC)=0.0D0 ! to prevent reading from uninitialised memory388:       QMINP(1:NSAVE,1:3*NATOMSALLOC)=0.0D0 ! to prevent reading from uninitialised memory
390:       if (boxderivt) boxq(1:nsave,1:6) = 0.0d0 
391:       QMINT(1:NSAVE,1:NATOMSALLOC)=1 ! to prevent reading from uninitialised memory389:       QMINT(1:NSAVE,1:NATOMSALLOC)=1 ! to prevent reading from uninitialised memory
392:       QMINNATOMS(1:NSAVE)=NATOMS ! to prevent reading from uninitialised memory390:       QMINNATOMS(1:NSAVE)=NATOMS ! to prevent reading from uninitialised memory
393:       AVOIDNATOMS(1:MAXSAVE)=NATOMS ! as above391:       AVOIDNATOMS(1:MAXSAVE)=NATOMS ! as above
394:       COORDSO(1:3*NATOMSALLOC,1:NPAR)=0.0D0 ! to prevent reading from uninitialised memory392:       COORDSO(1:3*NATOMSALLOC,1:NPAR)=0.0D0 ! to prevent reading from uninitialised memory
395:       FF(1:NSAVE)=0 ! to prevent reading from uninitialised memorY393:       FF(1:NSAVE)=0 ! to prevent reading from uninitialised memorY
396:       VATO(1:NATOMSALLOC,1:NPAR)=0.0D0 ! to prevent reading from uninitialised memory394:       VATO(1:NATOMSALLOC,1:NPAR)=0.0D0 ! to prevent reading from uninitialised memory
397:       ALLOCATE(ESAVE(NTAB,NPAR),XINSAVE(NTAB,NPAR))395:       ALLOCATE(ESAVE(NTAB,NPAR),XINSAVE(NTAB,NPAR))
398:       ALLOCATE(VEC(NVEC))396:       ALLOCATE(VEC(NVEC))
399: 397: 
400: !     IF (SYMMETRIZE.AND.(.NOT.CENT)) THEN398: !     IF (SYMMETRIZE.AND.(.NOT.CENT)) THEN
673:          IF (A9INTET) THEN671:          IF (A9INTET) THEN
674:             CLOSE(3998)672:             CLOSE(3998)
675:             CLOSE(3999)673:             CLOSE(3999)
676:          ENDIF674:          ENDIF
677:       ENDIF675:       ENDIF
678: 676: 
679:       DEALLOCATE(SCREENC)677:       DEALLOCATE(SCREENC)
680:       DEALLOCATE(IATNUM, VT, ZSYM)678:       DEALLOCATE(IATNUM, VT, ZSYM)
681:       DEALLOCATE(FF,QMIN)679:       DEALLOCATE(FF,QMIN)
682:       DEALLOCATE(QMINP,QMINT,QMINNATOMS)680:       DEALLOCATE(QMINP,QMINT,QMINNATOMS)
683:       if (boxderivt) deallocate(boxq) 
684:       DEALLOCATE(ESAVE,XINSAVE)681:       DEALLOCATE(ESAVE,XINSAVE)
685:       DEALLOCATE(VEC)682:       DEALLOCATE(VEC)
686:       DEALLOCATE(FIXSTEP,FIXTEMP,FIXBOTH,TEMP,ACCRAT,STEP,ASTEP,OSTEP,BLOCK,NT,NQ,EPREV,683:       DEALLOCATE(FIXSTEP,FIXTEMP,FIXBOTH,TEMP,ACCRAT,STEP,ASTEP,OSTEP,BLOCK,NT,NQ,EPREV,
687:      &           JUMPMOVE,JUMPINT,JDUMP,COORDS,COORDSO,VAT,VATO,684:      &           JUMPMOVE,JUMPINT,JDUMP,COORDS,COORDSO,VAT,VATO,
688:      &         JUMPTO,SHELLMOVES,PTGROUP,NSURFMOVES,NCORE)685:      &         JUMPTO,SHELLMOVES,PTGROUP,NSURFMOVES,NCORE)
689:       DEALLOCATE(FROZEN)686:       DEALLOCATE(FROZEN)
690:       DEALLOCATE(FROZENRES)687:       DEALLOCATE(FROZENRES)
691:       DEALLOCATE(DONTMOVE)688:       DEALLOCATE(DONTMOVE)
692:       DEALLOCATE(DONTMOVERES)689:       DEALLOCATE(DONTMOVERES)
693:       DEALLOCATE(HARMONICFLIST)690:       DEALLOCATE(HARMONICFLIST)


r33142/mc.F 2017-08-08 12:30:12.250345631 +0100 r33141/mc.F 2017-08-08 12:30:16.150397798 +0100
 32:      &                      E_VDW, E_14_VDW, E_ELEC, E_14_ELEC, IGB, MACROIONT 32:      &                      E_VDW, E_14_VDW, E_ELEC, E_14_ELEC, IGB, MACROIONT
 33:       USE AMBER12_INTERFACE_MOD, ONLY : AMBER12_WRITE_RESTART, AMBER12_WRITE_PDB, POT_ENE_REC_C 33:       USE AMBER12_INTERFACE_MOD, ONLY : AMBER12_WRITE_RESTART, AMBER12_WRITE_PDB, POT_ENE_REC_C
 34:       USE CHIRALITY, ONLY : INIT_CHIRAL, INIT_CIS_TRANS 34:       USE CHIRALITY, ONLY : INIT_CHIRAL, INIT_CIS_TRANS
 35:       USE AMBER12_MUTATIONS, ONLY: AMBERMUT_STEP, REVERSE_MUTATION , MUTATION_E 35:       USE AMBER12_MUTATIONS, ONLY: AMBERMUT_STEP, REVERSE_MUTATION , MUTATION_E
 36:       USE porfuncs 36:       USE porfuncs
 37:       USE AMHGLOBALS, ONLY: NMRES,OMOVI,AVEP,NUMPRO,IRES 37:       USE AMHGLOBALS, ONLY: NMRES,OMOVI,AVEP,NUMPRO,IRES
 38:       USE AMH_INTERFACES, ONLY:E_WRITE 38:       USE AMH_INTERFACES, ONLY:E_WRITE
 39:       USE ROTAMER 39:       USE ROTAMER
 40:       USE LJ_GAUSS_MOD, ONLY: LJ_GAUSS_TAKESTEP 40:       USE LJ_GAUSS_MOD, ONLY: LJ_GAUSS_TAKESTEP
 41:       USE OPP_MOD, ONLY: OPP_TAKESTEP 41:       USE OPP_MOD, ONLY: OPP_TAKESTEP
 42:       USE BOX_DERIVATIVES, ONLY: BD_TAKESTEP 
 43:  42: 
 44:       IMPLICIT NONE 43:       IMPLICIT NONE
 45: #ifdef MPI 44: #ifdef MPI
 46:       INCLUDE 'mpif.h' 45:       INCLUDE 'mpif.h'
 47:       INTEGER MPIERR 46:       INTEGER MPIERR
 48:       LOGICAL HITANY,MPI_FINT 47:       LOGICAL HITANY,MPI_FINT
 49: #endif 48: #endif
 50:  49: 
 51:       INTEGER J1, NSUCCESS(NPAR), NFAIL(NPAR), NFAILT(NPAR), NSUCCESST(NPAR), J2, NSTEPS, JP, REJSTREAK, 50:       INTEGER J1, NSUCCESS(NPAR), NFAIL(NPAR), NFAILT(NPAR), NSUCCESST(NPAR), J2, NSTEPS, JP, REJSTREAK,
 52:      1        UNT, ITERATIONS, NSUPERCOUNT, NQTOT, JACCPREV, NREN, NLAST, NSTEPREN, BRUN,QDONE,JBEST(NPAR),GCJBEST(NPAR), 51:      1        UNT, ITERATIONS, NSUPERCOUNT, NQTOT, JACCPREV, NREN, NLAST, NSTEPREN, BRUN,QDONE,JBEST(NPAR),GCJBEST(NPAR),
 54:      &        GCJESTP(NPAR), GCNATOMSBESTP(NPAR), GCJBESTP(NPAR) 53:      &        GCJESTP(NPAR), GCNATOMSBESTP(NPAR), GCJBESTP(NPAR)
 55:       INTEGER :: NSYMCALL=0, NULLMOVES(NPAR), NULLMOVEST(NPAR), NSWAPS=0 54:       INTEGER :: NSYMCALL=0, NULLMOVES(NPAR), NULLMOVEST(NPAR), NSWAPS=0
 56:       DOUBLE PRECISION POTEL, SCALEFAC, RANDOM, DPRAND, DPRAND_UNIVERSAL,  55:       DOUBLE PRECISION POTEL, SCALEFAC, RANDOM, DPRAND, DPRAND_UNIVERSAL, 
 57:      1                 TIME, SPOTEL(NSUPER), SCOORDS(3*NATOMSALLOC,NSUPER), 56:      1                 TIME, SPOTEL(NSUPER), SCOORDS(3*NATOMSALLOC,NSUPER),
 58:      2                 EPPREV(NPAR), QSTART, QFINISH, RANNJ, RMIN, RMINO, RCOORDS(3*NATOMSALLOC),ELASTSYM(NPAR), 57:      2                 EPPREV(NPAR), QSTART, QFINISH, RANNJ, RMIN, RMINO, RCOORDS(3*NATOMSALLOC),ELASTSYM(NPAR),
 59:      3                 RCOORDSO(3*NATOMSALLOC), RVAT(NATOMSALLOC), RVATO(NATOMSALLOC), EPSSAVE, EBEST(NPAR), GCEBEST(NPAR),  58:      3                 RCOORDSO(3*NATOMSALLOC), RVAT(NATOMSALLOC), RVATO(NATOMSALLOC), EPSSAVE, EBEST(NPAR), GCEBEST(NPAR), 
 60:      4                 GCEBESTP(NPAR),  59:      4                 GCEBESTP(NPAR), 
 61:      4                 RMSD, VINIT, CTE, TEMPTRAJ(0:NPAR-1), GCBESTCOORDS(3*NATOMSALLOC,NPAR), 60:      4                 RMSD, VINIT, CTE, TEMPTRAJ(0:NPAR-1), GCBESTCOORDS(3*NATOMSALLOC,NPAR),
 62:      5                 T, BETA(0:NPAR-1), GRAD(3*NATOMSALLOC), E, W, GCBESTCOORDSP(3*NATOMSALLOC,NPAR), 61:      5                 T, BETA(0:NPAR-1), GRAD(3*NATOMSALLOC), E, W, GCBESTCOORDSP(3*NATOMSALLOC,NPAR),
 63:      &                 DUMMY1, DUMMY2, DUMMY3, INTE, OPOTEL, GCBESTVAT(NATOMSALLOC,NPAR), GCBESTVATP(NATOMSALLOC,NPAR),  62:      &                 DUMMY1, DUMMY2, DUMMY3, INTE, OPOTEL, GCBESTVAT(NATOMSALLOC,NPAR), GCBESTVATP(NATOMSALLOC,NPAR), 
 64:      &                 XMASS, YMASS, ZMASS, CMMAX, SAVEBOX_PARAMS(6), TEMPBOX_PARAMS(6) 63:      &                 XMASS, YMASS, ZMASS, CMMAX
 65:       DOUBLE PRECISION, ALLOCATABLE :: BESTCOORDS(:,:) , SAVECOORDS(:), TEMPCOORDS(:), SCREENC(:) 64:       DOUBLE PRECISION, ALLOCATABLE :: BESTCOORDS(:,:) , SAVECOORDS(:), TEMPCOORDS(:), SCREENC(:)
 66:       LOGICAL CHANGEDE, RES1, RES2, COMPON, QUENCHCOMP, MARKOVSTEP 65:       LOGICAL CHANGEDE, RES1, RES2, COMPON, QUENCHCOMP, MARKOVSTEP
 67:       LOGICAL CHIRALFAIL,AMIDEFAIL, LOGDUMMY, DISTOK 66:       LOGICAL CHIRALFAIL,AMIDEFAIL, LOGDUMMY, DISTOK
 68:       CHARACTER FNAME*9 67:       CHARACTER FNAME*9
 69:       CHARACTER (LEN= 3)  ISTR 68:       CHARACTER (LEN= 3)  ISTR
 70:       CHARACTER (LEN=20) QUENCHNUM, QUNAME , FMUTNAMEPDB , FMUTNAMERST 69:       CHARACTER (LEN=20) QUENCHNUM, QUNAME , FMUTNAMEPDB , FMUTNAMERST
 71:       CHARACTER (LEN=20) BESTNAME 70:       CHARACTER (LEN=20) BESTNAME
 72:       LOGICAL  CHANGED 71:       LOGICAL  CHANGED
 73: c  AMH  72: c  AMH 
 74:       INTEGER :: GLY_COUNT,III,I2,I500,SNAPCOUNT 73:       INTEGER :: GLY_COUNT,III,I2,I500,SNAPCOUNT
496:          IF (DEBUG .AND. PERCOLATET) PERCCOMPMARKOV = COMPON495:          IF (DEBUG .AND. PERCOLATET) PERCCOMPMARKOV = COMPON
497: ! jwrm2> end496: ! jwrm2> end
498:          EPPREV(JP)=0.0D0497:          EPPREV(JP)=0.0D0
499:          ELASTSYM(JP)=0.0D0498:          ELASTSYM(JP)=0.0D0
500:          IF (.NOT.RESTORET) EBEST(JP)=POTEL499:          IF (.NOT.RESTORET) EBEST(JP)=POTEL
501:          BESTCOORDS(1:3*NATOMS,JP)=COORDS(1:3*NATOMS,JP)500:          BESTCOORDS(1:3*NATOMS,JP)=COORDS(1:3*NATOMS,JP)
502:          JBEST(JP)=0501:          JBEST(JP)=0
503:          RMIN=POTEL502:          RMIN=POTEL
504:          RCOORDS(1:3*NATOMS)=COORDS(1:3*NATOMS,1)503:          RCOORDS(1:3*NATOMS)=COORDS(1:3*NATOMS,1)
505:          COORDSO(1:3*NATOMS,JP)=COORDS(1:3*NATOMS,JP)504:          COORDSO(1:3*NATOMS,JP)=COORDS(1:3*NATOMS,JP)
506:          if (boxderivt) box_paramso(1:6) = box_params(1:6) ! dj337: save box params 
507:          LABELSO(1:NATOMS,JP)=LABELS(1:NATOMS,JP) ! <ds656505:          LABELSO(1:NATOMS,JP)=LABELS(1:NATOMS,JP) ! <ds656
508:          VATO(1:NATOMS,JP)=VAT(1:NATOMS,JP)506:          VATO(1:NATOMS,JP)=VAT(1:NATOMS,JP)
509: !hk286 - otherwise NEWRESTART is always called when the keyword RESTORE is also used507: !hk286 - otherwise NEWRESTART is always called when the keyword RESTORE is also used
510:          IF (.NOT.RESTORET) THEN508:          IF (.NOT.RESTORET) THEN
511:             EBEST(JP)=POTEL509:             EBEST(JP)=POTEL
512:             JBEST(JP)=0510:             JBEST(JP)=0
513:             BESTCOORDS(1:3*NATOMS,JP)=COORDS(1:3*NATOMS,JP)511:             BESTCOORDS(1:3*NATOMS,JP)=COORDS(1:3*NATOMS,JP)
514:          ENDIF512:          ENDIF
515: !513: !
516: ! Set up data for relxation blocks with grand canonical BH514: ! Set up data for relxation blocks with grand canonical BH
851:                        DOMUTATIONSTEPT=.TRUE.849:                        DOMUTATIONSTEPT=.TRUE.
852:                        MUTATEDT=.TRUE.        !as we need to consider different tests if we mutate!850:                        MUTATEDT=.TRUE.        !as we need to consider different tests if we mutate!
853:                ELSE IF (AMBERMUTATIONT.AND..NOT.MOD(J1,MUTATIONFREQ).EQ.0) THEN851:                ELSE IF (AMBERMUTATIONT.AND..NOT.MOD(J1,MUTATIONFREQ).EQ.0) THEN
854:                       DOGROUPROT=.TRUE.852:                       DOGROUPROT=.TRUE.
855:                ENDIF853:                ENDIF
856: 854: 
857: !855: !
858: ! csw34> Coordinates are saved so that moves can be undone856: ! csw34> Coordinates are saved so that moves can be undone
859: !857: !
860:                SAVECOORDS(1:3*NATOMS)=COORDS(1:3*NATOMS,JP)858:                SAVECOORDS(1:3*NATOMS)=COORDS(1:3*NATOMS,JP)
861:                if (boxderivt) savebox_params(1:6) = box_params(1:6) ! dj337: save box params 
862: ! csw34> If you want to look at the effect of moves, you can dump out859: ! csw34> If you want to look at the effect of moves, you can dump out
863: ! the structure BEFORE the move here.860: ! the structure BEFORE the move here.
864: !                 CALL A9DUMPPDB(COORDS(:,JP),"beforemove")861: !                 CALL A9DUMPPDB(COORDS(:,JP),"beforemove")
865: !                 CALL CHARMMDUMP(COORDS(:,JP),'beforemove')862: !                 CALL CHARMMDUMP(COORDS(:,JP),'beforemove')
866:                IF (MACROIONT) THEN863:                IF (MACROIONT) THEN
867:                   IF(RANDOMSEEDT) THEN864:                   IF(RANDOMSEEDT) THEN
868:                     CALL DATE_AND_TIME(DATECHAR,TIMECHAR,ZONECHAR,VALUES)865:                     CALL DATE_AND_TIME(DATECHAR,TIMECHAR,ZONECHAR,VALUES)
869:                     ITIME1 = VALUES(6) * 60 + VALUES(7)866:                     ITIME1 = VALUES(6) * 60 + VALUES(7)
870:                     CALL SDPRND(ITIME1 + MYNODE)867:                     CALL SDPRND(ITIME1 + MYNODE)
871:                   END IF868:                   END IF
1416:                      GCEBEST(JP)=POTEL1413:                      GCEBEST(JP)=POTEL
1417:                      GCJBEST(JP)=J11414:                      GCJBEST(JP)=J1
1418:                      GCBESTCOORDS(1:3*NATOMS,JP)=COORDS(1:3*NATOMS,JP)1415:                      GCBESTCOORDS(1:3*NATOMS,JP)=COORDS(1:3*NATOMS,JP)
1419:                      GCBESTVAT(1:NATOMS,JP)=VAT(1:NATOMS,JP)1416:                      GCBESTVAT(1:NATOMS,JP)=VAT(1:NATOMS,JP)
1420:                      GCNATOMSBEST(JP)=NATOMS1417:                      GCNATOMSBEST(JP)=NATOMS
1421:                   ENDIF1418:                   ENDIF
1422: !1419: !
1423: ! ALL OTHER STEP TAKING1420: ! ALL OTHER STEP TAKING
1424: !1421: !
1425:                ELSE1422:                ELSE
1426:  
1427:                   ! dj337: take steps in unit cell parameters