hdiff output

r33129/benzgenrigid.f90 2017-08-07 15:30:41.589404213 +0100 r33128/benzgenrigid.f90 2017-08-07 15:30:48.565497016 +0100
  1: ! dj337: Anisotropic potential for polycyclic aromatic hydrocarbons.  1: ! dj337: Anisotropic potential for polycyclic aromatic hydrocarbons.
  2: ! Long-range electrostatic interactions are computed using Ewald summation.  2: ! Long-range electrostatic interactions are computed using Ewald summation.
  3: ! Implemented within the GENRIGID framework.  3: ! Implemented within the GENRIGID framework.
  4:   4: 
  5:       SUBROUTINE BENZGENRIGIDEWALD(X, G, ENERGY, GTEST)  5:       SUBROUTINE BENZGENRIGIDEWALD(X, G, ENERGY, GTEST)
  6:   6: 
  7:       USE COMMONS, ONLY: NATOMS, NCARBON, RBSTLA, RHOCC0, RHOCC10, RHOCC20, &  7:       USE COMMONS, ONLY: NATOMS, NCARBON, RBSTLA, RHOCC0, RHOCC10, RHOCC20, &
  8:      &                   RHOHH0, RHOHH10, RHOHH20, RHOCH0, RHOC10H, RHOCH10, RHOC20H, &  8:      &                   RHOHH0, RHOHH10, RHOHH20, RHOCH0, RHOC10H, RHOCH10, RHOC20H, &
  9:      &                   RHOCH20, ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ, &  9:      &                   RHOCH20, ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ
 10:      &                   EWALDREALC, BOX_PARAMS, BOX_PARAMSGRAD 
 11:  10: 
 12:       ! dj337: PAHA adapted to the genrigid framework 11:       ! dj337: PAHA adapted to the genrigid framework
 13:       USE GENRIGID, ONLY: NRIGIDBODY, ATOMRIGIDCOORDT, TRANSFORMCTORIGID, NSITEPERBODY, & 12:       USE GENRIGID, ONLY: NRIGIDBODY, ATOMRIGIDCOORDT, TRANSFORMCTORIGID, NSITEPERBODY, &
 14:      &                    MAXSITE, SITESRIGIDBODY, TRANSFORMRIGIDTOC, TRANSFORMGRAD, INVERSEMATRIX 13:      &                    MAXSITE, SITESRIGIDBODY, TRANSFORMRIGIDTOC, TRANSFORMGRAD
 15:  14: 
 16:       ! dj337: use Ewald summation to compute electrostatics 15:       ! dj337: use Ewald summation to compute electrostatics
 17:       USE EWALD 16:       USE EWALD
 18:       USE CARTDIST 
 19:       USE BOX_DERIVATIVES 
 20:  17: 
 21:       IMPLICIT NONE 18:       IMPLICIT NONE
 22:  19: 
 23:       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) 
 24:       INTEGER          :: NEWALDREAL(3) 
 25:       DOUBLE PRECISION :: X(3*NATOMS) 21:       DOUBLE PRECISION :: X(3*NATOMS)
 26:       DOUBLE PRECISION, INTENT(OUT) :: G(3*NATOMS) 22:       DOUBLE PRECISION, INTENT(OUT) :: G(3*NATOMS)
 27:       DOUBLE PRECISION :: XR(3*NATOMS), XC(3*NATOMS), G3C(3*NATOMS), G3(3*NATOMS), graddum(3*natoms) 23:       DOUBLE PRECISION :: XR(3*NATOMS), XC(3*NATOMS), G3C(3*NATOMS), G3(3*NATOMS), graddum(3*natoms)
 28:       DOUBLE PRECISION, INTENT(OUT) :: ENERGY 24:       DOUBLE PRECISION, INTENT(OUT) :: ENERGY
 29:       DOUBLE PRECISION :: R2, R6, ABSRIJ, DVDR, ENERGY1, ENERGY2, ENERGY3, diff, eplus, eminus 25:       DOUBLE PRECISION :: R2, R6, ABSRIJ, DVDR, ENERGY1, ENERGY2, ENERGY3, diff, eplus, eminus
 30:       DOUBLE PRECISION :: DMPFCT_SHIFT, EXPFCT_SHIFT, VSHIFT1, VSHIFT2, EWALDREALC2, RCOMMIN(3), RCOM(3) 26:       DOUBLE PRECISION :: DMPFCT_SHIFT, EXPFCT_SHIFT, VSHIFT1, VSHIFT2, EWALDREALC2
 31:       DOUBLE PRECISION :: RI(3), RR(3), RSS(3), RSSMIN(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) 
 32:       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)
 33:       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)
 34:       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)
 35:       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)
 36:       DOUBLE PRECISION :: RHOCC, RHOHH, RHOCH, COSTA, COSTB, DMPFCT, DDMPDR, EXPFCT  32:       DOUBLE PRECISION :: RHOCC, RHOHH, RHOCH, COSTA, COSTB, DMPFCT, DDMPDR, EXPFCT 
 37:       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)
 38:       DOUBLE PRECISION :: H(3,3), H_grad(3,3,6), H_inverse(3,3), rrfrac(3), rssfracmin(3), rrcom(3), rcomfrac(3) 
 39:       double precision :: rrcomfrac(3), rcomfracmin(3), rssfrac(3), vol, v_fact, dv_fact(3), c(3), s(3) 
 40:       double precision :: H_mat(3,3), rmatrix(3), reciplatvec(3,3), reciplatvec_grad(3,3,6) 
 41:       DOUBLE PRECISION, PARAMETER :: B = 1.6485D0 34:       DOUBLE PRECISION, PARAMETER :: B = 1.6485D0
 42:       double precision, parameter :: pi = 3.141592654d0 35:       LOGICAL          :: GTEST
 43:       integer, parameter          :: image_cutoff = 5 
 44:       LOGICAL          :: GTEST, keep_angles 
 45:  
 46:       !print *, 'box_params: ', box_params(1:6) 
 47:  
 48:       keep_angles = check_angles(box_params(4:6)) 
 49:  
 50:       if (.not.keep_angles) then 
 51:          !print *, 'rejecting' 
 52:          call reject(energy, g) 
 53:          return 
 54:       endif 
 55:  
 56:       call build_H(H, H_grad, gtest) 
 57:       call inversematrix(H, H_inverse) 
 58:       call get_volume(vol) 
 59:       call get_reciplatvec(reciplatvec,reciplatvec_grad, .false.) 
 60:  
 61:       newaldreal(1) = floor(ewaldrealc*dsqrt(sum(reciplatvec(1,:)**2))/(2.0d0*pi) + 0.5d0) 
 62:       newaldreal(2) = floor(ewaldrealc*dsqrt(sum(reciplatvec(2,:)**2))/(2.0d0*pi) + 0.5d0) 
 63:       newaldreal(3) = floor(ewaldrealc*dsqrt(sum(reciplatvec(3,:)**2))/(2.0d0*pi) + 0.5d0) 
 64:       !print *, 'newaldreal: ', newaldreal(:3) 
 65:  
 66:       if (.not. all(newaldreal.le.image_cutoff)) then 
 67:          !print *, 'rejecting' 
 68:          call reject(energy, g) 
 69:          return 
 70:       endif 
 71:  36: 
 72:       ! factorials 37:       ! factorials
 73:       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
 74:       ! initialize energy values 39:       ! initialize energy values
 75:       ! energy1 is due to short-range anisotropic interactions 40:       ! energy1 is due to short-range anisotropic interactions
 76:       ! energy2 is due to damped dispersion 41:       ! energy2 is due to damped dispersion
 77:       ! energy3 is due to long-range electrostatics (computed using Ewald) 42:       ! energy3 is due to long-range electrostatics (computed using Ewald)
 78:       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
 79:  44: 
 80:       ! initialize gradient if GTEST true 45:       ! initialize gradient if GTEST true
 81:       IF (GTEST) G(:) = 0.D0 46:       IF (GTEST) G(:) = 0.D0
 82:       IF (GTEST) G3C(:) = 0.D0 47:       IF (GTEST) G3C(:) = 0.D0
 83:  48: 
 84:       !print *, 'boxparams benzrigid: ', box_params(1:6) 
 85:       !print *, 'coords benzrigid   : ', x(1:25) 
 86:  
 87:       ! dj337: check if input coordinates are cartesian 49:       ! dj337: check if input coordinates are cartesian
 88:       ! assumes ATOMRIGIDCOORDT is correct 50:       ! assumes ATOMRIGIDCOORDT is correct
 89:       IF (ATOMRIGIDCOORDT) THEN ! if input is cartesian 51:       IF (ATOMRIGIDCOORDT) THEN ! if input is cartesian
 90:          !print *, 'converting...' 
 91:          ! convert to rigidbody coordinates 52:          ! convert to rigidbody coordinates
 92:          XR(:) = 0.D0 53:          XR(:) = 0.D0
 93:          CALL TRANSFORMCTORIGID(X, XR) 54:          CALL TRANSFORMCTORIGID(X, XR)
 94:          if (boxderivt) then 55:          X(:) = XR(:)
 95:             call frac2cart_rb_tri(nrigidbody, xdum, xr, H) 
 96:             !if (ortho) call frac2cart_rb_ortho(xdum, xr) 
 97:             x(:) = xdum(:) 
 98:          else 
 99:             x(:) = xr(:) 
100:          endif 
101:       ENDIF 56:       ENDIF
102:  57: 
103:       !print *, 'coords benzrigid   : ' 
104:       !do j1 = 1, 2*nrigidbody 
105:       !   print *, x(3*j1-2:3*j1) 
106:       !enddo 
107:  
108:       !call build_H(H, H_grad, gtest) 
109:       !call inversematrix(H, H_inverse) 
110:       !call get_volume(vol) 
111:       !call get_reciplatvec(reciplatvec,reciplatvec_grad, .false.) 
112:       ! compute v factor 
113:       c(:) = dcos(box_params(4:6)) 
114:       s(:) = dsin(box_params(4:6)) 
115:       v_fact = dsqrt(1.0d0 - c(1)**2-c(2)**2-c(3)**2 + 2.0d0*c(1)*c(2)*c(3)) 
116:       dv_fact(1) = s(1)*(c(1) - c(2)*c(3))/v_fact 
117:       dv_fact(2) = s(2)*(c(2) - c(1)*c(3))/v_fact 
118:       dv_fact(3) = s(3)*(c(3) - c(1)*c(2))/v_fact 
119:  
120:       EWALDREALC2 = EWALDREALC**2 58:       EWALDREALC2 = EWALDREALC**2
121:  59: 
122:       !print *, 'reciplatvec: ', reciplatvec(:3,:3) 
123:  
124:       ! OFFSET is number of CoM coords (3*NRIGIDBODY) 60:       ! OFFSET is number of CoM coords (3*NRIGIDBODY)
125:       OFFSET     = 3*NRIGIDBODY 61:       OFFSET     = 3*NRIGIDBODY
126:  62: 
127:       ! Computing Cartesian coordinates for the system.   63:       ! Computing Cartesian coordinates for the system.  
128:       DO J1 = 1, NRIGIDBODY 64:       DO J1 = 1, NRIGIDBODY
129:  65: 
130:          J3 = 3*J1 66:          J3 = 3*J1
131:          J5 = OFFSET + J3 67:          J5 = OFFSET + J3
132:          ! CoM coords for rigid body J1 68:          ! CoM coords for rigid body J1
133:          RI = X(J3-2:J3) 69:          RI = X(J3-2:J3)
160:                DE1(J4,:) = MATMUL(DRMI1(:,:),RBSTLA(J2,:)) 96:                DE1(J4,:) = MATMUL(DRMI1(:,:),RBSTLA(J2,:))
161:                DE2(J4,:) = MATMUL(DRMI2(:,:),RBSTLA(J2,:)) 97:                DE2(J4,:) = MATMUL(DRMI2(:,:),RBSTLA(J2,:))
162:                DE3(J4,:) = MATMUL(DRMI3(:,:),RBSTLA(J2,:)) 98:                DE3(J4,:) = MATMUL(DRMI3(:,:),RBSTLA(J2,:))
163:  99: 
164:             ENDIF100:             ENDIF
165: 101: 
166:          ENDDO102:          ENDDO
167: 103: 
168:       ENDDO104:       ENDDO
169: 105: 
170:       !print *, 'cart coords benzrigid   : ' 
171:       !do j1 = 1, natoms 
172:       !   print *, r(j1,:3) 
173:       !enddo 
174:  
175:       ! Now compute the actual potential.106:       ! Now compute the actual potential.
176:       ! loop over rigid bodies (A)107:       ! loop over rigid bodies (A)
177:       DO J1 = 1, NRIGIDBODY - 1108:       DO J1 = 1, NRIGIDBODY - 1
178: 109: 
179:          J3 = 3*J1110:          J3 = 3*J1
180:          J5 = OFFSET + J3111:          J5 = OFFSET + J3
181:          ! CoM coords for rigid body J1112:          ! CoM coords for rigid body J1
182:          RI(:)  = X(J3-2:J3)113:          RI(:)  = X(J3-2:J3)
183: 114: 
184:          ! loop over sites in the rigid body J1115:          ! loop over sites in the rigid body J1
195:                J4 = 3*J2126:                J4 = 3*J2
196:                J6 = OFFSET + J4127:                J6 = OFFSET + J4
197: 128: 
198:                ! loop over sites in the rigid body J2129:                ! loop over sites in the rigid body J2
199:                DO J = 1, NSITEPERBODY(J2)130:                DO J = 1, NSITEPERBODY(J2)
200: 131: 
201:                   ! J8 is index for site J132:                   ! J8 is index for site J
202:                   J8     = MAXSITE*(J2-1) + J133:                   J8     = MAXSITE*(J2-1) + J
203:                   ! EJ is Z-axis for site J134:                   ! EJ is Z-axis for site J
204:                   EJ(:)  = E(J8,:)135:                   EJ(:)  = E(J8,:)
205:                   rr(:) = r(j7,:) - r(j8,:)136:                   RSS(:) = R(J7,:) - R(J8,:)
206:                   ! convert to fractional coordinates 
207:                   rrfrac(:) = matmul(H_inverse, rr(:)) 
208:                   ! minimum image convention137:                   ! minimum image convention
209:                   rssfracmin(1) = rrfrac(1) - anint(rrfrac(1))138:                   RSSMIN(1) = RSS(1) - BOXLX*ANINT(RSS(1)/BOXLX)
210:                   rssfracmin(2) = rrfrac(2) - anint(rrfrac(2))139:                   RSSMIN(2) = RSS(2) - BOXLY*ANINT(RSS(2)/BOXLY)
211:                   rssfracmin(3) = rrfrac(3) - anint(rrfrac(3))140:                   RSSMIN(3) = RSS(3) - BOXLZ*ANINT(RSS(3)/BOXLZ)
212: 141:                   R2     = DOT_PRODUCT(RSSMIN(:),RSSMIN(:))
213:                   if (gtest.and.boxderivt) then142:                   ! check if distance within cutoff
214:                      ! get center of mass separation vector143:                   IF (R2 < EWALDREALC2) THEN
215:                      rrcom(:) = x(j3-2:j3) - x(j4-2:j4)144:                      !print *, j7, j8
216:                      ! convert to fractional coordinates145:                      !print *, 'r: ', rss(:3)
217:                      rrcomfrac(:) = matmul(H_inverse, rrcom(:))146:                      !print *, 'rmin: ', rssmin(:3)
218:                      ! minimum image convention147:                      ! ABSRIJ is site-site separation between I and J
219:                      rcomfracmin(1) = rrcomfrac(1) - anint(rrfrac(1))148:                      ABSRIJ = DSQRT(R2)
220:                      rcomfracmin(2) = rrcomfrac(2) - anint(rrfrac(2))149:                      ! NR is unit site-site vector from sites I to J
221:                      rcomfracmin(3) = rrcomfrac(3) - anint(rrfrac(3))150:                      NR(:)  = RSSMIN(:)/ABSRIJ
222:                   endif151:                      R2     = 1.D0/R2
223: 152:                      R6     = R2*R2*R2
224:                   do l = -newaldreal(1), newaldreal(1)153:    
225:                   rssfrac(1) = rssfracmin(1) + l154: !     CALCULATE THE DISPERSION DAMPING FACTOR
226: 155:    
227:                      do m = -newaldreal(2), newaldreal(2)156:                      ! initialize sum for the damping function and vertical shift
228:                      rssfrac(2) = rssfracmin(2) + m157:                      DMPFCT = 1.D0
229: 158:                      DMPFCT_SHIFT = 1.D0
230:                         do n = -newaldreal(3), newaldreal(3)159:                      ! initialize sum for the derivative of damping function
231:                         rssfrac(3) = rssfracmin(3) + n160:                      DDMPDR = B
232: 161:    
233:                         ! convert to absolute coordinates162:                      ! calculate sums
234:                         rss(:) = matmul(H, rssfrac(:))163:                      DO K = 1, 6
235: 164:    
236:                         ! get COM vector165:                         DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K))
237:                         if (gtest.and.boxderivt) then166:                         DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K))
238:                            rcomfrac(1) = rcomfracmin(1) + l167:                         IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1))
239:                            rcomfrac(2) = rcomfracmin(2) + m168:    
240:                            rcomfrac(3) = rcomfracmin(3) + n169:                      END DO
241:                            ! convert to absolute coordinates170:    
242:                            rcom(:) = matmul(H, rcomfrac(:))171:                      EXPFCT = DEXP(-B*ABSRIJ)
243:                         endif172:                      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
244:                      300:                      
245:                         R2     = DOT_PRODUCT(RSS(:),RSS(:))301:                            DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR 
246:                         !print *, 'r2: ', r2302:                            !print *, 'grad: ', dvdr
247:                         ! check if distance within cutoff303:                            FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) &
248:                         IF (R2 < EWALDREALC2) THEN304:                                    + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:))
249:                            !print *, j7, j8305:                            TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) &
250:                            !print *, 'r   : ', rss(:3)306:                                    + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:))
251:                            !print *, 'rmin: ', rssmin(1:3)307:                            TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) &
252:                            !print *, 'rcom: ', rcom(1:3)308:                                    + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:))
253:                            ! ABSRIJ is site-site separation between I and J309:    
254:                            ABSRIJ = DSQRT(R2) 
255:                            ! NR is unit site-site vector from sites I to J 
256:                            NR(:)  = RSS(:)/ABSRIJ 
257:                            R2     = 1.D0/R2 
258:                            R6     = R2*R2*R2 
259:                            !print *, 'absrij: ', absrij 
260:           
261:       !     CALCULATE THE DISPERSION DAMPING FACTOR 
262:           
263:                            ! initialize sum for the damping function and vertical shift 
264:                            DMPFCT = 1.D0 
265:                            DMPFCT_SHIFT = 1.D0 
266:                            ! initialize sum for the derivative of damping function 
267:                            DDMPDR = B 
268:           
269:                            ! calculate sums 
270:                            DO K = 1, 6 
271:           
272:                               DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K)) 
273:                               DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K)) 
274:                               IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1)) 
275:           
276:                            END DO 
277:           
278:                            EXPFCT = DEXP(-B*ABSRIJ) 
279:                            EXPFCT_SHIFT = DEXP(-B*EWALDREALC) 
280:                            ! DDMPDR is derivative of damping function with factor 1/Rab 
281:                            DDMPDR = (B*EXPFCT*DMPFCT - EXPFCT*DDMPDR)/ABSRIJ 
282:                            ! DMPFCT is damping function 
283:                            DMPFCT = 1.D0 - EXPFCT*DMPFCT 
284:                            ! DMPFCT_SHIFT is vertical shift for damping function 
285:                            DMPFCT_SHIFT = 1.D0 - EXPFCT_SHIFT*DMPFCT_SHIFT 
286:           
287:       !     NOW CALCULATE RHOAB 
288:           
289:                            ! calculate cos(theta)  
290:                            COSTA      =-DOT_PRODUCT(NR(:),EI(:)) 
291:                            COSTB      = DOT_PRODUCT(NR(:),EJ(:)) 
292:           
293:                            ! calculate terms relevant to derivatives 
294:                            IF (GTEST) THEN 
295:           
296:                               ! derivative of cos(theta) wrt r_ij 
297:                               DCADR(:)   =-EI(:)/ABSRIJ - COSTA*R2*RSS(:) 
298:                               DCBDR(:)   = EJ(:)/ABSRIJ - COSTB*R2*RSS(:) 
299:           
300:                               ! derivative of r_ij wrt pi 
301:                               DRIJDPI(1) = DOT_PRODUCT(RSS(:),DR1(J7,:)) 
302:                               DRIJDPI(2) = DOT_PRODUCT(RSS(:),DR2(J7,:)) 
303:                               DRIJDPI(3) = DOT_PRODUCT(RSS(:),DR3(J7,:)) 
304:           
305:                               ! derivative of r_ij wrt pj 
306:                               DRIJDPJ(1) =-DOT_PRODUCT(RSS(:),DR1(J8,:)) 
307:                               DRIJDPJ(2) =-DOT_PRODUCT(RSS(:),DR2(J8,:)) 
308:                               DRIJDPJ(3) =-DOT_PRODUCT(RSS(:),DR3(J8,:)) 
309:           
310:                               ! derivative of cos(theta) wrt pi 
311:                               DCADPI(1)  =-DOT_PRODUCT(DR1(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE1(J7,:)) &  
312:                                          - COSTA*R2*DRIJDPI(1) 
313:                               DCADPI(2)  =-DOT_PRODUCT(DR2(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE2(J7,:)) & 
314:                                          - COSTA*R2*DRIJDPI(2) 
315:                               DCADPI(3)  =-DOT_PRODUCT(DR3(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE3(J7,:)) & 
316:                                          - COSTA*R2*DRIJDPI(3) 
317:                               DCBDPI(1)  = DOT_PRODUCT(DR1(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(1) 
318:                               DCBDPI(2)  = DOT_PRODUCT(DR2(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(2) 
319:                               DCBDPI(3)  = DOT_PRODUCT(DR3(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(3) 
320:                           
321:                               ! derivative of cos(theta) wrt pj 
322:                               DCADPJ(1)  = DOT_PRODUCT(DR1(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(1) 
323:                               DCADPJ(2)  = DOT_PRODUCT(DR2(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(2) 
324:                               DCADPJ(3)  = DOT_PRODUCT(DR3(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(3) 
325:           
326:                               DCBDPJ(1)  =-DOT_PRODUCT(DR1(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE1(J8,:)) & 
327:                                          - COSTB*R2*DRIJDPJ(1) 
328:                               DCBDPJ(2)  =-DOT_PRODUCT(DR2(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE2(J8,:)) & 
329:                                          - COSTB*R2*DRIJDPJ(2) 
330:                               DCBDPJ(3)  =-DOT_PRODUCT(DR3(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE3(J8,:)) & 
331:                                          - COSTB*R2*DRIJDPJ(3) 
332:           
333:                            ENDIF 
334:             
335:                            ! calculate if I and J are both carbons  
336:                            IF (I <= NCARBON .AND. J <= NCARBON) THEN 
337:           
338:                               ! calculate rho_cc 
339:                               RHOCC   = RHOCC0 + RHOCC10*(COSTA + COSTB) + RHOCC20*(1.5D0*COSTA*COSTA &  
340:                                       + 1.5D0*COSTB*COSTB - 1.D0) 
341:                               ! ENERGY1 is energy due to short-range anisotropic interactions 
342:                               ! calculate vertical shift for first term 
343:                               EXPFCT  = KKJ*DEXP(-ALPHACC*(ABSRIJ - RHOCC)) 
344:                               VSHIFT1 = KKJ*DEXP(-ALPHACC*(EWALDREALC - RHOCC)) 
345:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
346:                               ! ENERGY2 is energy due to damped dispersion 
347:                               ! calculate vertical shift for second term 
348:                               VSHIFT2 = DC6CC*DMPFCT_SHIFT/(EWALDREALC**6) 
349:                               !print *, 'energy: ', dc6cc*dmpfct*r6 
350:                               ENERGY2 = ENERGY2 - DC6CC*DMPFCT*R6 + VSHIFT2 
351:           
352:                               IF (GTEST) THEN 
353:           
354:                                  ! DVDR is derivative of dispersion damping factor energy with factor 1/Rab 
355:                                  DVDR    = 6.D0*DC6CC*R6*R2*DMPFCT - DC6CC*R6*DDMPDR  
356:                                  !print *, 'grad: ', dvdr 
357:                                  ! FRIJ is derivative of ENERGY1 wrt r_ij with factor 1/Rab 
358:                                  FRIJ(:) = ALPHACC*EXPFCT*(-NR(:) + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADR(:) & 
359:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDR(:)) 
360:                                  ! TIJ is derivative of ENERGY1 wrt pi with factor 1/Rab 
361:                                  TIJ(:)  = ALPHACC*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPI(:) & 
362:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPI(:)) 
363:                                  ! TJI is derivative of ENERGY1 wrt pj with factor 1/Rab 
364:                                  TJI(:)  = ALPHACC*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPJ(:) & 
365:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPJ(:))  
366:           
367:                               ENDIF 
368:           
369:                            ! calculate if I and J are both hydorgens 
370:                            ELSEIF (I > NCARBON .AND. J > NCARBON) THEN 
371:           
372:                               RHOHH  = RHOHH0 + RHOHH10*(COSTA + COSTB) + RHOHH20*(1.5D0*COSTA*COSTA      & 
373:                                      + 1.5D0*COSTB*COSTB - 1.D0)  
374:                               EXPFCT  = KKJ*DEXP(-ALPHAHH*(ABSRIJ - RHOHH)) 
375:                               VSHIFT1 = KKJ*DEXP(-ALPHAHH*(EWALDREALC - RHOHH)) 
376:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
377:                               VSHIFT2 = DC6HH*DMPFCT_SHIFT/(EWALDREALC**6) 
378:                               !print *, 'energy: ', dc6hh*dmpfct*r6 
379:                               ENERGY2 = ENERGY2 - DC6HH*DMPFCT*R6 + VSHIFT2 
380:           
381:                               IF (GTEST) THEN 
382:           
383:                                  DVDR    = 6.D0*DC6HH*R6*R2*DMPFCT - DC6HH*R6*DDMPDR  
384:                                  !print *, 'grad: ', dvdr 
385:                                  FRIJ(:) = ALPHAHH*EXPFCT*(-NR(:) + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADR(:) & 
386:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDR(:)) 
387:                                  TIJ(:)  = ALPHAHH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPI(:) & 
388:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPI(:)) 
389:                                  TJI(:)  = ALPHAHH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPJ(:) & 
390:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPJ(:)) 
391:           
392:                               ENDIF 
393:           
394:                            ! calculate if I is carbon and J is hydrogen 
395:                            ELSE IF (I <= NCARBON .AND. J > NCARBON) THEN  
396:           
397:                               RHOCH  = RHOCH0 + RHOC10H*COSTA + RHOCH10*COSTB + RHOC20H*(1.5D0*COSTA*COSTA & 
398:                                      - 0.5D0) + RHOCH20*(1.5D0*COSTB*COSTB - 0.5D0) 
399:                               EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
400:                               VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
401:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
402:                               VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
403:                               !print *, 'energy: ', dc6ch*dmpfct*r6 
404:                               ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
405:           
406:                               IF (GTEST) THEN 
407:                             
408:                                  DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
409:                                  !print *, 'grad: ', dvdr 
410:                                  FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) & 
411:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:)) 
412:                                  TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) & 
413:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:)) 
414:                                  TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) & 
415:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:)) 
416:           
417:                               ENDIF 
418:           
419:                            ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN 
420:           
421:                               RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA & 
422:                                      - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0) 
423:                               EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
424:                               VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
425:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
426:                               VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
427:                               !print *, 'energy: ', dc6ch*dmpfct*r6 
428:                               ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
429:           
430:                               IF (GTEST) THEN 
431:           
432:                                  DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
433:                                  !print *, 'grad: ', dvdr 
434:                                  FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) & 
435:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:)) 
436:                                  TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) & 
437:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:)) 
438:                                  TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) & 
439:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:)) 
440:           
441:                               ENDIF 
442:           
443:                            ENDIF 
444:           
445:                            IF (GTEST) THEN 
446:           
447:                               ! total gradient wrt CoM coords for rigid body J1 
448:                               G(J3-2:J3) = G(J3-2:J3) + DVDR*RSS(:) + FRIJ(:) 
449:                               !g(j3-2:j3) = g(j3-2:j3) + frij(:) 
450:  
451:                               !box_paramsgrad(1:3) = box_paramsgrad(1:3) + (dvdr*rss(1:3)+frij(1:3))*rcom(1:3)/box_params(1:3) 
452:                               ! total gradient wrt CoM coords for rigid body J2 
453:                               G(J4-2:J4) = G(J4-2:J4) - DVDR*RSS(:) - FRIJ(:) 
454:                               !g(j4-2:j4) = g(j4-2:j4) - frij(:) 
455:  
456:                               ! total gradient wrt AA coords for rigid body J1 
457:                               G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPI(:) + TIJ(:) 
458:                               !g(j5-2:j5) = g(j5-2:j5) + tij(:) 
459:                               ! total gradient wrt AA coords for rigid body J2 
460:                               G(J6-2:J6) = G(J6-2:J6) + DVDR*DRIJDPJ(:) + TJI(:) 
461:                               !g(j6-2:j6) = g(j6-2:j6) + tji(:) 
462:  
463:                               ! TODO: this is if orientation of rigid body depends on cell parameters 
464:                               !H_mat(:,:) = (-1.0d0/(vol*v_fact))*dv_fact(1)*H(:,:) + (1.0d0/vol)*H_grad(:,:,4) 
465:                               !rmatrix(:) = matmul(H_inverse, vol*(rss(:)-rcom(:))) 
466:                               !box_paramsgrad(4) = box_paramsgrad(4) + dvdr*dot_product(rss(1:3), matmul(H_mat, rmatrix(:))) 
467:  
468:                               !box_paramsgrad(1) = box_paramsgrad(1) + dvdr*dot_product(rss(1:3), matmul(H_mat/vol, rmatrix(:))) 
469:  
470:                               do idx = 1, 6 
471:                                  box_paramsgrad(idx) = box_paramsgrad(idx) + dot_product((dvdr*rss(1:3) + frij(1:3)), matmul(H_grad(:,:,idx), rcomfrac(:))) 
472:                               enddo 
473:  
474:                            ENDIF 
475:        
476:                         ENDIF310:                         ENDIF
 311:    
 312:                      ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN
 313:    
 314:                         RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA &
 315:                                - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0)
 316:                         EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH))
 317:                         VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH))
 318:                         ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1
 319:                         VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6)
 320:                         !print *, 'energy: ', dc6ch*dmpfct*r6
 321:                         ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2
 322:    
 323:                         IF (GTEST) THEN
 324:    
 325:                            DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR 
 326:                            !print *, 'grad: ', dvdr
 327:                            FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) &
 328:                                    + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:))
 329:                            TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) &
 330:                                    + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:))
 331:                            TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) &
 332:                                    + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:))
 333:    
 334:                         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
477: 351: 
478:                      enddo352:                   ENDIF
479:                   enddo 
480:                enddo 
481: 353: 
482:                ENDDO354:                ENDDO
483: 355: 
484:             ENDDO356:             ENDDO
485:  357:  
486:          ENDDO358:          ENDDO
487: 359: 
488:       ENDDO360:       ENDDO
489: 361: 
490: ! INCLUDE CONTRIBUTION OF RIGID BODY WITH PERIODIC IMAGE OF ITSELF 
491:  
492:       ! loop over rigidbodies 
493:       do j1 = 1, nrigidbody 
494:          j3 = 3*j1 
495:          j5 = offset + j3 
496:          ri(:) = x(j3-2:j3) 
497:  
498:          ! loop over sites i 
499:          do i = 1, nsiteperbody(j1) 
500:             j7 = maxsite*(j1-1) + i 
501:             ei(:) = e(j7,:) 
502:  
503:             ! loop over sites j 
504:             do j = 1, nsiteperbody(j1) 
505:                j8 = maxsite*(j1-1) + j 
506:                ej(:) = e(j8,:) 
507:  
508:                !print *, 'new!!', j1, i, j 
509:                rr(:) = r(j7,:) - r(j8,:) 
510:                !print *, j7, r(j7,:3) 
511:                !print *, j8, r(j8,:3) 
512:                !print *, 'rr: ', rr(:3) 
513:                ! convert to fractional 
514:                rrfrac(:) = matmul(H_inverse, rr(:)) 
515:                !print *, 'rrfrac: ', rrfrac(:3) 
516:  
517:                ! loop over boxes 
518:                do l = -newaldreal(1), newaldreal(1) 
519:                   do m = -newaldreal(2), newaldreal(2) 
520:                      do n = -newaldreal(3), newaldreal(3) 
521:  
522:                      if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
523:  
524:                         rssfrac(1) = rrfrac(1) + l 
525:                         rssfrac(2) = rrfrac(2) + m 
526:                         rssfrac(3) = rrfrac(3) + n 
527:                         !print *, l, m, n 
528:                         !print *, 'rssfrac: ', rssfrac(:3) 
529:                         rss(:) = matmul(H, rssfrac(:)) 
530:  
531:                         if (gtest.and.boxderivt) then 
532:                            rcomfrac(1) = l 
533:                            rcomfrac(2) = m 
534:                            rcomfrac(3) = n 
535:                            rcom(:) = matmul(H, rcomfrac(:)) 
536:                         endif 
537:  
538:                         r2 = dot_product(rss(:), rss(:)) 
539:                         !print *, 'rssmin2: ', rss(1:3) 
540:                         if (r2 < ewaldrealc2) then 
541:  
542:                         !print *, 'rssmin3: ', rss(1:3) 
543:                         !print *, 'r2    : ', r2 
544:                         !print *, 'rcom  : ', rcom(1:3) 
545:                         absrij = dsqrt(r2) 
546:                         !print *, j7, j8 
547:                         !print *, absrij 
548:                         nr(:) = rss(:)/absrij 
549:                         r2 = 1.d0/r2 
550:                         r6 = r2*r2*r2 
551:  
552:                         ! CALCULATE DISPERSION DAMPING FACTOR 
553:  
554:                         ! initialize sum for the damping function and vertical shift 
555:                         DMPFCT = 1.D0 
556:                         DMPFCT_SHIFT = 1.D0 
557:                         ! initialize sum for the derivative of damping function 
558:                         DDMPDR = B 
559:  
560:                         ! calculate sums 
561:                         DO K = 1, 6 
562:  
563:                            DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K)) 
564:                            DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K)) 
565:                            !IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1)) 
566:  
567:                         END DO 
568:  
569:                         EXPFCT = DEXP(-B*ABSRIJ) 
570:                         EXPFCT_SHIFT = DEXP(-B*EWALDREALC) 
571:                         ! DDMPDR is derivative of damping function with factor 1/Rab 
572:                         DDMPDR = (B*EXPFCT*DMPFCT - EXPFCT*DDMPDR)/ABSRIJ 
573:                         ! DMPFCT is damping function 
574:                         DMPFCT = 1.D0 - EXPFCT*DMPFCT 
575:                         ! DMPFCT_SHIFT is vertical shift for damping function 
576:                         DMPFCT_SHIFT = 1.D0 - EXPFCT_SHIFT*DMPFCT_SHIFT 
577:  
578:                         ! CALCULATE RHOAB 
579:                         ! calculate cos(theta)  
580:                         COSTA      =-DOT_PRODUCT(NR(:),EI(:)) 
581:                         COSTB      = DOT_PRODUCT(NR(:),EJ(:)) 
582:  
583:                         ! calculate terms relevant to derivatives 
584:                         IF (GTEST) THEN 
585:  
586:                            ! derivative of cos(theta) wrt r_ij 
587:                            DCADR(:)   =-EI(:)/ABSRIJ - COSTA*R2*RSS(:) 
588:                            DCBDR(:)   = EJ(:)/ABSRIJ - COSTB*R2*RSS(:) 
589:  
590:                            ! derivative of r_ij wrt pi 
591:                            DRIJDPI(1) = DOT_PRODUCT(RSS(:),DR1(J7,:)) 
592:                            DRIJDPI(2) = DOT_PRODUCT(RSS(:),DR2(J7,:)) 
593:                            DRIJDPI(3) = DOT_PRODUCT(RSS(:),DR3(J7,:)) 
594:  
595:                            ! derivative of r_ij wrt pj 
596:                            DRIJDPJ(1) =-DOT_PRODUCT(RSS(:),DR1(J8,:)) 
597:                            DRIJDPJ(2) =-DOT_PRODUCT(RSS(:),DR2(J8,:)) 
598:                            DRIJDPJ(3) =-DOT_PRODUCT(RSS(:),DR3(J8,:)) 
599:  
600:                            ! derivative of cos(theta) wrt pi 
601:                            DCADPI(1)  =-DOT_PRODUCT(DR1(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE1(J7,:)) &  
602:                                       - COSTA*R2*DRIJDPI(1) 
603:                            DCADPI(2)  =-DOT_PRODUCT(DR2(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE2(J7,:)) & 
604:                                       - COSTA*R2*DRIJDPI(2) 
605:                            DCADPI(3)  =-DOT_PRODUCT(DR3(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE3(J7,:)) & 
606:                                       - COSTA*R2*DRIJDPI(3) 
607:                            DCBDPI(1)  = DOT_PRODUCT(DR1(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(1) 
608:                            DCBDPI(2)  = DOT_PRODUCT(DR2(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(2) 
609:                            DCBDPI(3)  = DOT_PRODUCT(DR3(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(3) 
610:  
611:                            ! derivative of cos(theta) wrt pj 
612:                            DCADPJ(1)  = DOT_PRODUCT(DR1(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(1) 
613:                            DCADPJ(2)  = DOT_PRODUCT(DR2(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(2) 
614:                            DCADPJ(3)  = DOT_PRODUCT(DR3(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(3) 
615:  
616:                            DCBDPJ(1)  =-DOT_PRODUCT(DR1(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE1(J8,:)) & 
617:                                       - COSTB*R2*DRIJDPJ(1) 
618:                            DCBDPJ(2)  =-DOT_PRODUCT(DR2(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE2(J8,:)) & 
619:                                       - COSTB*R2*DRIJDPJ(2) 
620:                            DCBDPJ(3)  =-DOT_PRODUCT(DR3(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE3(J8,:)) & 
621:                                       - COSTB*R2*DRIJDPJ(3) 
622:  
623:                         ENDIF 
624:  
625:                         ! calculate if I and J are both carbons  
626:                         IF (I <= NCARBON .AND. J <= NCARBON) THEN 
627:  
628:                            ! calculate rho_cc 
629:                            RHOCC   = RHOCC0 + RHOCC10*(COSTA + COSTB) + RHOCC20*(1.5D0*COSTA*COSTA &  
630:                                    + 1.5D0*COSTB*COSTB - 1.D0) 
631:                            ! ENERGY1 is energy due to short-range anisotropic interactions 
632:                            ! calculate vertical shift for first term 
633:                            EXPFCT  = KKJ*DEXP(-ALPHACC*(ABSRIJ - RHOCC)) 
634:                            VSHIFT1 = KKJ*DEXP(-ALPHACC*(EWALDREALC - RHOCC)) 
635:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
636:                            ! ENERGY2 is energy due to damped dispersion 
637:                            ! calculate vertical shift for second term 
638:                            VSHIFT2 = DC6CC*DMPFCT_SHIFT/(EWALDREALC**6) 
639:                            !print *, 'energy: ', dc6cc*dmpfct*r6 
640:                            ENERGY2 = ENERGY2 - DC6CC*DMPFCT*R6 + VSHIFT2 
641:                            !print *, 'vshift2     : ', vshift2 
642:                            !print *, 'contribution: ', -dc6cc*dmpfct*r6 
643:                            !print *, 'energy2     : ', energy2 
644:  
645:                            IF (GTEST) THEN 
646:  
647:                               ! DVDR is derivative of dispersion damping factor energy with factor 1/Rab 
648:                               DVDR    = 6.D0*DC6CC*R6*R2*DMPFCT - DC6CC*R6*DDMPDR  
649:                               !print *, 'dvdr        : ', dvdr 
650:                            !   !print *, 'grad: ', dvdr 
651:                            !   ! FRIJ is derivative of ENERGY1 wrt r_ij with factor 1/Rab 
652:                               FRIJ(:) = ALPHACC*EXPFCT*(-NR(:) + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADR(:) & 
653:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDR(:)) 
654:                               ! TIJ is derivative of ENERGY1 wrt pi with factor 1/Rab 
655:                               TIJ(:)  = ALPHACC*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPI(:) & 
656:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPI(:)) 
657:                            !   ! TJI is derivative of ENERGY1 wrt pj with factor 1/Rab 
658:                               TJI(:)  = ALPHACC*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPJ(:) & 
659:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPJ(:))  
660:  
661:                            ENDIF 
662:  
663:                         ! calculate if I and J are both hydorgens 
664:                         ELSEIF (I > NCARBON .AND. J > NCARBON) THEN 
665:  
666:                            RHOHH  = RHOHH0 + RHOHH10*(COSTA + COSTB) + RHOHH20*(1.5D0*COSTA*COSTA      & 
667:                                   + 1.5D0*COSTB*COSTB - 1.D0) 
668:                            EXPFCT  = KKJ*DEXP(-ALPHAHH*(ABSRIJ - RHOHH)) 
669:                            VSHIFT1 = KKJ*DEXP(-ALPHAHH*(EWALDREALC - RHOHH)) 
670:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
671:                            VSHIFT2 = DC6HH*DMPFCT_SHIFT/(EWALDREALC**6) 
672:                            !print *, 'energy: ', dc6hh*dmpfct*r6 
673:                            ENERGY2 = ENERGY2 - DC6HH*DMPFCT*R6 + VSHIFT2 
674:  
675:                            IF (GTEST) THEN 
676:  
677:                               DVDR    = 6.D0*DC6HH*R6*R2*DMPFCT - DC6HH*R6*DDMPDR  
678:                            !   !print *, 'grad: ', dvdr 
679:                               FRIJ(:) = ALPHAHH*EXPFCT*(-NR(:) + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADR(:) & 
680:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDR(:)) 
681:                               TIJ(:)  = ALPHAHH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPI(:) & 
682:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPI(:)) 
683:                               TJI(:)  = ALPHAHH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPJ(:) & 
684:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPJ(:)) 
685:  
686:                            ENDIF 
687:  
688:                         ! calculate if I is carbon and J is hydrogen 
689:                         ELSE IF (I <= NCARBON .AND. J > NCARBON) THEN  
690:  
691:                            RHOCH  = RHOCH0 + RHOC10H*COSTA + RHOCH10*COSTB + RHOC20H*(1.5D0*COSTA*COSTA & 
692:                                   - 0.5D0) + RHOCH20*(1.5D0*COSTB*COSTB - 0.5D0) 
693:                            EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
694:                            VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
695:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
696:                            VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
697:                            !print *, 'energy: ', dc6ch*dmpfct*r6 
698:                            ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
699:  
700:                            IF (GTEST) THEN 
701:  
702:                               DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
703:                            !   !print *, 'grad: ', dvdr 
704:                               FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) & 
705:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:)) 
706:                               TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) & 
707:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:)) 
708:                               TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) & 
709:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:)) 
710:  
711:                            ENDIF 
712:  
713:                         ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN 
714:  
715:                            RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA & 
716:                                   - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0) 
717:                            EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
718:                            VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
719:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
720:                            VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
721:                            !print *, 'energy: ', dc6ch*dmpfct*r6 
722:                            ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
723:  
724:                            IF (GTEST) THEN 
725:  
726:                               DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
727:                            !   !print *, 'grad: ', dvdr 
728:                               FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) & 
729:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:)) 
730:                               TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) & 
731:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:)) 
732:                               TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) & 
733:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:)) 
734:  
735:                            ENDIF 
736:  
737:                         ENDIF 
738:  
739:  
740:                         IF (GTEST) THEN 
741:  
742:                            ! total gradient wrt AA coords for rigid body J1 
743:                            G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPI(:) + TIJ(:) 
744:                            !g(j5-2:j5) = g(j5-2:j5) + tij(:) 
745:                            ! total gradient wrt AA coords for rigid body J2 
746:                            G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPJ(:) + TJI(:) 
747:                            !g(j5-2:j5) = g(j5-2:j5) + tji(:) 
748:                            !print *, 'dispersion:' 
749:                            !print *, dvdr*drijdpi(:3) 
750:                            !print *, dvdr*drijdpj(:3) 
751:                            !print *, 'energy2: ', energy2 
752:                            !print *, 'anisotropic:' 
753:                            !print *, tij(:3) 
754:                            !print *, tji(:3) 
755:  
756:                            do idx = 1, 6 
757:                                  box_paramsgrad(idx) = box_paramsgrad(idx) + dot_product((dvdr*rss(1:3) + frij(1:3)), matmul(H_grad(:,:,idx), rcomfrac(:))) 
758:                                  !box_paramsgrad(idx) = box_paramsgrad(idx) + dot_product(dvdr*rss(1:3), matmul(H_grad(:,:,idx), rcomfrac(:))) 
759:                            enddo 
760:  
761:                         ENDIF 
762:                         endif 
763:                     endif 
764:                   enddo 
765:                enddo 
766:             enddo 
767:             enddo 
768:          enddo 
769:       enddo 
770:  
771:       ! convert to cartesian coordinates362:       ! convert to cartesian coordinates
772:       XC(:) = 0.D0363:       XC(:) = 0.D0
773:       if (boxderivt) then 
774:          xdum(:) = x(:) 
775:          call cart2frac_rb_tri(nrigidbody, xdum, x, H_inverse) 
776:       endif 
777:       CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XC, X)364:       CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XC, X)
778:       ! restore cartesian rigid body coordinates 
779:       if (boxderivt) x(:) = xdum(:) 
780: 365: 
781: !      !!! ENERGY3 and G3 are energy and gradient due to electrostatics366:       ! ENERGY3 and G3 are energy and gradient due to electrostatics
782: !      !!! computed using Ewald summation367:       ! computed using Ewald summation
783:       CALL EWALDSUM(1, XC, G3C, ENERGY3, GTEST)368:       CALL EWALDSUM(1, XC, G3C, ENERGY3, GTEST)
784: !369: 
785: !      !!! convert Ewald contribution of gradient to rigidbody coordinates370: ! 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: 
 386:       ! convert Ewald contribution of gradient to rigidbody coordinates
786:       IF (GTEST) G3(:) = 0.D0387:       IF (GTEST) G3(:) = 0.D0
787:       CALL TRANSFORMGRAD(G3C, X, G3)388:       CALL TRANSFORMGRAD(G3C, X, G3)
788: !!      !print *, 'energy2: ', energy2 
789: 389: 
790:       !energy = (energy1+energy2)*2625.499d0 
791:       !if (gtest) g(:) = g(:)*2625.499d0 
792:       !energy = energy2*2625.499d0390:       !energy = energy2*2625.499d0
793:       !energy = (energy1+energy3)*2625.499d0391:       !if (gtest) g(:) = g(:)*2625.499d0
 392:       !energy = (energy3)*2625.499d0
794:       !if (gtest) g(:) = g3(:)*2625.499d0393:       !if (gtest) g(:) = g3(:)*2625.499d0
795:       !ENERGY = (ENERGY1 + ENERGY2 + ENERGY3)*2625.499D0 394:       ENERGY = (ENERGY1 + ENERGY2 + ENERGY3)*2625.499D0 
796:       !IF (GTEST) G(:) = (G(:) + G3(:))*2625.499D0395:       IF (GTEST) G(:) = (G(:) + G3(:))*2625.499D0
797:       !if (gtest) box_paramsgrad(1:6) = box_paramsgrad(1:6)*2625.499D0 
798:       !print *, 'box_paramsgrad: ', box_paramsgrad(1:3) 
799:       !print *, 'energy: ', energy2 
800: 396: 
801:       ! dj337: if input was cartesian, convert back to cartesian397:       ! dj337: if input was cartesian, convert back to cartesian
802:       ! assumes ATOMRIGIDCOORDT is correct398:       ! assumes ATOMRIGIDCOORDT is correct
803:       IF (ATOMRIGIDCOORDT) THEN399:       IF (ATOMRIGIDCOORDT) THEN
804: 400: 
805:          ! convert to cartesian coordinates401:          ! convert to cartesian coordinates
806:          if (boxderivt) then402:          XR(:) = 0.D0
807:             !print *, 'coords 708: ', x(1:3*natoms) 
808:             xdum(:) = x(:) 
809:             call cart2frac_rb_tri(nrigidbody, xdum, x, H_inverse) 
810:             !if (ortho) call cart2frac_rb_ortho(xdum, x) 
811:             !print *, 'coords 711: ', x(1:3*natoms) 
812:          endif 
813:          CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XR, X)403:          CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XR, X)
814:          X(:) = XR(:)404:          X(:) = XR(:)
815:       ENDIF 
816:  
817:       call constrain_volume(v_fact, dv_fact, energy1, box_paramsgrad(4:6), gtest) 
818: 405: 
819:       ENERGY = (ENERGY1 + ENERGY2 + ENERGY3)*2625.499D0406:       ENDIF
820:       IF (GTEST) G(:) = (G(:) + G3(:))*2625.499D0 
821:       if (gtest) box_paramsgrad(1:6) = box_paramsgrad(1:6)*2625.499D0 
822:       !print *, 'coords benzrigid    : ', x(1:3*natoms) 
823:       !print *, 'box params benzrigid: ', box_params(1:6) 
824:  
825:       !print *, 'energy: ', energy1, energy2, energy3 
826:       !print *, 'grad  : ' 
827:       !do j1 = 1, 2*nrigidbody 
828:       !   print *, g(3*j1-2:3*j1) 
829:       !enddo 
830:  
831:       !print *, 'contri: ', energy1, energy2, energy3 
832:       !print *, 'energy: ', energy !, box_params(1:6) 
833:       !print *, 'g1    : ', g(1:3) 
834:       !stop 
835: 407: 
836:       END SUBROUTINE BENZGENRIGIDEWALD408:       END SUBROUTINE BENZGENRIGIDEWALD
837: 409: 
838: !     ----------------------------------------------------------------------------------------------410: !     ----------------------------------------------------------------------------------------------
839: !411: !
840: !      SUBROUTINE DEFPAHARIGID()412: !      SUBROUTINE DEFPAHARIGID()
841: !413: !
842: !      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, &
843: !                         ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ, CCKJ415: !                         ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ, CCKJ
844: !416: !


r33129/benzgenrigid_ortho.f90 2017-08-07 15:30:41.813407193 +0100 r33128/benzgenrigid_ortho.f90 2017-08-07 15:30:48.785499942 +0100
  1: ! dj337: Anisotropic potential for polycyclic aromatic hydrocarbons.  1: ! dj337: Anisotropic potential for polycyclic aromatic hydrocarbons.
  2: ! Long-range electrostatic interactions are computed using Ewald summation.  2: ! Long-range electrostatic interactions are computed using Ewald summation.
  3: ! Implemented within the GENRIGID framework.  3: ! Implemented within the GENRIGID framework.
  4:   4: 
  5:       SUBROUTINE BENZGENRIGIDEWALD(X, G, ENERGY, GTEST)  5:       SUBROUTINE BENZGENRIGIDEWALD(X, G, ENERGY, GTEST)
  6:   6: 
  7:       USE COMMONS, ONLY: NATOMS, NCARBON, RBSTLA, RHOCC0, RHOCC10, RHOCC20, &  7:       USE COMMONS, ONLY: NATOMS, NCARBON, RBSTLA, RHOCC0, RHOCC10, RHOCC20, &
  8:      &                   RHOHH0, RHOHH10, RHOHH20, RHOCH0, RHOC10H, RHOCH10, RHOC20H, &  8:      &                   RHOHH0, RHOHH10, RHOHH20, RHOCH0, RHOC10H, RHOCH10, RHOC20H, &
  9:      &                   RHOCH20, ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ, &  9:      &                   RHOCH20, ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ
 10:      &                   EWALDREALC, BOX_PARAMS, BOX_PARAMSGRAD 
 11:  10: 
 12:       ! dj337: PAHA adapted to the genrigid framework 11:       ! dj337: PAHA adapted to the genrigid framework
 13:       USE GENRIGID, ONLY: NRIGIDBODY, ATOMRIGIDCOORDT, TRANSFORMCTORIGID, NSITEPERBODY, & 12:       USE GENRIGID, ONLY: NRIGIDBODY, ATOMRIGIDCOORDT, TRANSFORMCTORIGID, NSITEPERBODY, &
 14:      &                    MAXSITE, SITESRIGIDBODY, TRANSFORMRIGIDTOC, TRANSFORMGRAD, INVERSEMATRIX 13:      &                    MAXSITE, SITESRIGIDBODY, TRANSFORMRIGIDTOC, TRANSFORMGRAD
 15:  14: 
 16:       ! dj337: use Ewald summation to compute electrostatics 15:       ! dj337: use Ewald summation to compute electrostatics
 17:       USE EWALD 16:       USE EWALD
 18:       USE CARTDIST 
 19:       USE BOX_DERIVATIVES 
 20:  17: 
 21:       IMPLICIT NONE 18:       IMPLICIT NONE
 22:  19: 
 23:       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) 
 24:       INTEGER          :: NEWALDREAL(3) 
 25:       DOUBLE PRECISION :: X(3*NATOMS) 21:       DOUBLE PRECISION :: X(3*NATOMS)
 26:       DOUBLE PRECISION, INTENT(OUT) :: G(3*NATOMS) 22:       DOUBLE PRECISION, INTENT(OUT) :: G(3*NATOMS)
 27:       DOUBLE PRECISION :: XR(3*NATOMS), XC(3*NATOMS), G3C(3*NATOMS), G3(3*NATOMS), graddum(3*natoms) 23:       DOUBLE PRECISION :: XR(3*NATOMS), XC(3*NATOMS), G3C(3*NATOMS), G3(3*NATOMS), graddum(3*natoms)
 28:       DOUBLE PRECISION, INTENT(OUT) :: ENERGY 24:       DOUBLE PRECISION, INTENT(OUT) :: ENERGY
 29:       DOUBLE PRECISION :: R2, R6, ABSRIJ, DVDR, ENERGY1, ENERGY2, ENERGY3, diff, eplus, eminus 25:       DOUBLE PRECISION :: R2, R6, ABSRIJ, DVDR, ENERGY1, ENERGY2, ENERGY3, diff, eplus, eminus
 30:       DOUBLE PRECISION :: DMPFCT_SHIFT, EXPFCT_SHIFT, VSHIFT1, VSHIFT2, EWALDREALC2, RCOMMIN(3), RCOM(3) 26:       DOUBLE PRECISION :: DMPFCT_SHIFT, EXPFCT_SHIFT, VSHIFT1, VSHIFT2, EWALDREALC2
 31:       DOUBLE PRECISION :: RI(3), RR(3), RSS(3), RSSMIN(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) 
 32:       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)
 33:       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)
 34:       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)
 35:       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)
 36:       DOUBLE PRECISION :: RHOCC, RHOHH, RHOCH, COSTA, COSTB, DMPFCT, DDMPDR, EXPFCT  32:       DOUBLE PRECISION :: RHOCC, RHOHH, RHOCH, COSTA, COSTB, DMPFCT, DDMPDR, EXPFCT 
 37:       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)
 38:       DOUBLE PRECISION :: H(3,3), H_grad(3,3,6), H_inverse(3,3), rrfrac(3), rssfracmin(3), rrcom(3), rcomfrac(3) 
 39:       double precision :: rrcomfrac(3), rcomfracmin(3), rssfrac(3), vol, v_fact, dv_fact(3), c(3), s(3) 
 40:       double precision :: H_mat(3,3), rmatrix(3), reciplatvec(3,3), reciplatvec_grad(3,3,6) 
 41:       DOUBLE PRECISION, PARAMETER :: B = 1.6485D0 34:       DOUBLE PRECISION, PARAMETER :: B = 1.6485D0
 42:       double precision, parameter :: pi = 3.141592654d0 35:       LOGICAL          :: GTEST
 43:       integer, parameter          :: image_cutoff = 5 
 44:       LOGICAL          :: GTEST, keep_angles 
 45:  
 46:       !print *, 'box_params: ', box_params(1:6) 
 47:  
 48:       keep_angles = check_angles(box_params(4:6)) 
 49:  
 50:       if (.not.keep_angles) then 
 51:          !print *, 'rejecting' 
 52:          call reject(energy, g) 
 53:          return 
 54:       endif 
 55:  
 56:       call build_H(H, H_grad, gtest) 
 57:       call inversematrix(H, H_inverse) 
 58:       call get_volume(vol) 
 59:       call get_reciplatvec(reciplatvec,reciplatvec_grad, .false.) 
 60:  
 61:       newaldreal(1) = floor(ewaldrealc*dsqrt(sum(reciplatvec(1,:)**2))/(2.0d0*pi) + 0.5d0) 
 62:       newaldreal(2) = floor(ewaldrealc*dsqrt(sum(reciplatvec(2,:)**2))/(2.0d0*pi) + 0.5d0) 
 63:       newaldreal(3) = floor(ewaldrealc*dsqrt(sum(reciplatvec(3,:)**2))/(2.0d0*pi) + 0.5d0) 
 64:       !print *, 'newaldreal: ', newaldreal(:3) 
 65:  
 66:       if (.not. all(newaldreal.le.image_cutoff)) then 
 67:          !print *, 'rejecting' 
 68:          call reject(energy, g) 
 69:          return 
 70:       endif 
 71:  36: 
 72:       ! factorials 37:       ! factorials
 73:       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
 74:       ! initialize energy values 39:       ! initialize energy values
 75:       ! energy1 is due to short-range anisotropic interactions 40:       ! energy1 is due to short-range anisotropic interactions
 76:       ! energy2 is due to damped dispersion 41:       ! energy2 is due to damped dispersion
 77:       ! energy3 is due to long-range electrostatics (computed using Ewald) 42:       ! energy3 is due to long-range electrostatics (computed using Ewald)
 78:       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
 79:  44: 
 80:       ! initialize gradient if GTEST true 45:       ! initialize gradient if GTEST true
 81:       IF (GTEST) G(:) = 0.D0 46:       IF (GTEST) G(:) = 0.D0
 82:       IF (GTEST) G3C(:) = 0.D0 47:       IF (GTEST) G3C(:) = 0.D0
 83:  48: 
 84:       !print *, 'boxparams benzrigid: ', box_params(1:6) 
 85:       !print *, 'coords benzrigid   : ', x(1:25) 
 86:  
 87:       ! dj337: check if input coordinates are cartesian 49:       ! dj337: check if input coordinates are cartesian
 88:       ! assumes ATOMRIGIDCOORDT is correct 50:       ! assumes ATOMRIGIDCOORDT is correct
 89:       IF (ATOMRIGIDCOORDT) THEN ! if input is cartesian 51:       IF (ATOMRIGIDCOORDT) THEN ! if input is cartesian
 90:          !print *, 'converting...' 
 91:          ! convert to rigidbody coordinates 52:          ! convert to rigidbody coordinates
 92:          XR(:) = 0.D0 53:          XR(:) = 0.D0
 93:          CALL TRANSFORMCTORIGID(X, XR) 54:          CALL TRANSFORMCTORIGID(X, XR)
 94:          if (boxderivt) then 55:          X(:) = XR(:)
 95:             call frac2cart_rb_tri(nrigidbody, xdum, xr, H) 
 96:             !if (ortho) call frac2cart_rb_ortho(xdum, xr) 
 97:             x(:) = xdum(:) 
 98:          else 
 99:             x(:) = xr(:) 
100:          endif 
101:       ENDIF 56:       ENDIF
102:  57: 
103:       !print *, 'coords benzrigid   : ' 
104:       !do j1 = 1, 2*nrigidbody 
105:       !   print *, x(3*j1-2:3*j1) 
106:       !enddo 
107:  
108:       !call build_H(H, H_grad, gtest) 
109:       !call inversematrix(H, H_inverse) 
110:       !call get_volume(vol) 
111:       !call get_reciplatvec(reciplatvec,reciplatvec_grad, .false.) 
112:       ! compute v factor 
113:       c(:) = dcos(box_params(4:6)) 
114:       s(:) = dsin(box_params(4:6)) 
115:       v_fact = dsqrt(1.0d0 - c(1)**2-c(2)**2-c(3)**2 + 2.0d0*c(1)*c(2)*c(3)) 
116:       dv_fact(1) = s(1)*(c(1) - c(2)*c(3))/v_fact 
117:       dv_fact(2) = s(2)*(c(2) - c(1)*c(3))/v_fact 
118:       dv_fact(3) = s(3)*(c(3) - c(1)*c(2))/v_fact 
119:  
120:       EWALDREALC2 = EWALDREALC**2 58:       EWALDREALC2 = EWALDREALC**2
121:  59: 
122:       !print *, 'reciplatvec: ', reciplatvec(:3,:3) 
123:  
124:       ! OFFSET is number of CoM coords (3*NRIGIDBODY) 60:       ! OFFSET is number of CoM coords (3*NRIGIDBODY)
125:       OFFSET     = 3*NRIGIDBODY 61:       OFFSET     = 3*NRIGIDBODY
126:  62: 
127:       ! Computing Cartesian coordinates for the system.   63:       ! Computing Cartesian coordinates for the system.  
128:       DO J1 = 1, NRIGIDBODY 64:       DO J1 = 1, NRIGIDBODY
129:  65: 
130:          J3 = 3*J1 66:          J3 = 3*J1
131:          J5 = OFFSET + J3 67:          J5 = OFFSET + J3
132:          ! CoM coords for rigid body J1 68:          ! CoM coords for rigid body J1
133:          RI = X(J3-2:J3) 69:          RI = X(J3-2:J3)
160:                DE1(J4,:) = MATMUL(DRMI1(:,:),RBSTLA(J2,:)) 96:                DE1(J4,:) = MATMUL(DRMI1(:,:),RBSTLA(J2,:))
161:                DE2(J4,:) = MATMUL(DRMI2(:,:),RBSTLA(J2,:)) 97:                DE2(J4,:) = MATMUL(DRMI2(:,:),RBSTLA(J2,:))
162:                DE3(J4,:) = MATMUL(DRMI3(:,:),RBSTLA(J2,:)) 98:                DE3(J4,:) = MATMUL(DRMI3(:,:),RBSTLA(J2,:))
163:  99: 
164:             ENDIF100:             ENDIF
165: 101: 
166:          ENDDO102:          ENDDO
167: 103: 
168:       ENDDO104:       ENDDO
169: 105: 
170:       !print *, 'cart coords benzrigid   : ' 
171:       !do j1 = 1, natoms 
172:       !   print *, r(j1,:3) 
173:       !enddo 
174:  
175:       ! Now compute the actual potential.106:       ! Now compute the actual potential.
176:       ! loop over rigid bodies (A)107:       ! loop over rigid bodies (A)
177:       DO J1 = 1, NRIGIDBODY - 1108:       DO J1 = 1, NRIGIDBODY - 1
178: 109: 
179:          J3 = 3*J1110:          J3 = 3*J1
180:          J5 = OFFSET + J3111:          J5 = OFFSET + J3
181:          ! CoM coords for rigid body J1112:          ! CoM coords for rigid body J1
182:          RI(:)  = X(J3-2:J3)113:          RI(:)  = X(J3-2:J3)
183: 114: 
184:          ! loop over sites in the rigid body J1115:          ! loop over sites in the rigid body J1
195:                J4 = 3*J2126:                J4 = 3*J2
196:                J6 = OFFSET + J4127:                J6 = OFFSET + J4
197: 128: 
198:                ! loop over sites in the rigid body J2129:                ! loop over sites in the rigid body J2
199:                DO J = 1, NSITEPERBODY(J2)130:                DO J = 1, NSITEPERBODY(J2)
200: 131: 
201:                   ! J8 is index for site J132:                   ! J8 is index for site J
202:                   J8     = MAXSITE*(J2-1) + J133:                   J8     = MAXSITE*(J2-1) + J
203:                   ! EJ is Z-axis for site J134:                   ! EJ is Z-axis for site J
204:                   EJ(:)  = E(J8,:)135:                   EJ(:)  = E(J8,:)
205:                   rr(:) = r(j7,:) - r(j8,:)136:                   RSS(:) = R(J7,:) - R(J8,:)
206:                   ! convert to fractional coordinates 
207:                   rrfrac(:) = matmul(H_inverse, rr(:)) 
208:                   ! minimum image convention137:                   ! minimum image convention
209:                   rssfracmin(1) = rrfrac(1) - anint(rrfrac(1))138:                   RSSMIN(1) = RSS(1) - BOXLX*ANINT(RSS(1)/BOXLX)
210:                   rssfracmin(2) = rrfrac(2) - anint(rrfrac(2))139:                   RSSMIN(2) = RSS(2) - BOXLY*ANINT(RSS(2)/BOXLY)
211:                   rssfracmin(3) = rrfrac(3) - anint(rrfrac(3))140:                   RSSMIN(3) = RSS(3) - BOXLZ*ANINT(RSS(3)/BOXLZ)
212: 141:                   R2     = DOT_PRODUCT(RSSMIN(:),RSSMIN(:))
213:                   if (gtest.and.boxderivt) then142:                   ! check if distance within cutoff
214:                      ! get center of mass separation vector143:                   IF (R2 < EWALDREALC2) THEN
215:                      rrcom(:) = x(j3-2:j3) - x(j4-2:j4)144:                      !print *, j7, j8
216:                      ! convert to fractional coordinates145:                      !print *, 'r: ', rss(:3)
217:                      rrcomfrac(:) = matmul(H_inverse, rrcom(:))146:                      !print *, 'rmin: ', rssmin(:3)
218:                      ! minimum image convention147:                      ! ABSRIJ is site-site separation between I and J
219:                      rcomfracmin(1) = rrcomfrac(1) - anint(rrfrac(1))148:                      ABSRIJ = DSQRT(R2)
220:                      rcomfracmin(2) = rrcomfrac(2) - anint(rrfrac(2))149:                      ! NR is unit site-site vector from sites I to J
221:                      rcomfracmin(3) = rrcomfrac(3) - anint(rrfrac(3))150:                      NR(:)  = RSSMIN(:)/ABSRIJ
222:                   endif151:                      R2     = 1.D0/R2
223: 152:                      R6     = R2*R2*R2
224:                   do l = -newaldreal(1), newaldreal(1)153:    
225:                   rssfrac(1) = rssfracmin(1) + l154: !     CALCULATE THE DISPERSION DAMPING FACTOR
226: 155:    
227:                      do m = -newaldreal(2), newaldreal(2)156:                      ! initialize sum for the damping function and vertical shift
228:                      rssfrac(2) = rssfracmin(2) + m157:                      DMPFCT = 1.D0
229: 158:                      DMPFCT_SHIFT = 1.D0
230:                         do n = -newaldreal(3), newaldreal(3)159:                      ! initialize sum for the derivative of damping function
231:                         rssfrac(3) = rssfracmin(3) + n160:                      DDMPDR = B
232: 161:    
233:                         ! convert to absolute coordinates162:                      ! calculate sums
234:                         rss(:) = matmul(H, rssfrac(:))163:                      DO K = 1, 6
235: 164:    
236:                         ! get COM vector165:                         DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K))
237:                         if (gtest.and.boxderivt) then166:                         DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K))
238:                            rcomfrac(1) = rcomfracmin(1) + l167:                         IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1))
239:                            rcomfrac(2) = rcomfracmin(2) + m168:    
240:                            rcomfrac(3) = rcomfracmin(3) + n169:                      END DO
241:                            ! convert to absolute coordinates170:    
242:                            rcom(:) = matmul(H, rcomfrac(:))171:                      EXPFCT = DEXP(-B*ABSRIJ)
243:                         endif172:                      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
244:                      300:                      
245:                         R2     = DOT_PRODUCT(RSS(:),RSS(:))301:                            DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR 
246:                         !print *, 'r2: ', r2302:                            !print *, 'grad: ', dvdr
247:                         ! check if distance within cutoff303:                            FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) &
248:                         IF (R2 < EWALDREALC2) THEN304:                                    + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:))
249:                            !print *, j7, j8305:                            TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) &
250:                            !print *, 'r   : ', rss(:3)306:                                    + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:))
251:                            !print *, 'rmin: ', rssmin(1:3)307:                            TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) &
252:                            !print *, 'rcom: ', rcom(1:3)308:                                    + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:))
253:                            ! ABSRIJ is site-site separation between I and J309:    
254:                            ABSRIJ = DSQRT(R2) 
255:                            ! NR is unit site-site vector from sites I to J 
256:                            NR(:)  = RSS(:)/ABSRIJ 
257:                            R2     = 1.D0/R2 
258:                            R6     = R2*R2*R2 
259:                            !print *, 'absrij: ', absrij 
260:           
261:       !     CALCULATE THE DISPERSION DAMPING FACTOR 
262:           
263:                            ! initialize sum for the damping function and vertical shift 
264:                            DMPFCT = 1.D0 
265:                            DMPFCT_SHIFT = 1.D0 
266:                            ! initialize sum for the derivative of damping function 
267:                            DDMPDR = B 
268:           
269:                            ! calculate sums 
270:                            DO K = 1, 6 
271:           
272:                               DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K)) 
273:                               DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K)) 
274:                               IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1)) 
275:           
276:                            END DO 
277:           
278:                            EXPFCT = DEXP(-B*ABSRIJ) 
279:                            EXPFCT_SHIFT = DEXP(-B*EWALDREALC) 
280:                            ! DDMPDR is derivative of damping function with factor 1/Rab 
281:                            DDMPDR = (B*EXPFCT*DMPFCT - EXPFCT*DDMPDR)/ABSRIJ 
282:                            ! DMPFCT is damping function 
283:                            DMPFCT = 1.D0 - EXPFCT*DMPFCT 
284:                            ! DMPFCT_SHIFT is vertical shift for damping function 
285:                            DMPFCT_SHIFT = 1.D0 - EXPFCT_SHIFT*DMPFCT_SHIFT 
286:           
287:       !     NOW CALCULATE RHOAB 
288:           
289:                            ! calculate cos(theta)  
290:                            COSTA      =-DOT_PRODUCT(NR(:),EI(:)) 
291:                            COSTB      = DOT_PRODUCT(NR(:),EJ(:)) 
292:           
293:                            ! calculate terms relevant to derivatives 
294:                            IF (GTEST) THEN 
295:           
296:                               ! derivative of cos(theta) wrt r_ij 
297:                               DCADR(:)   =-EI(:)/ABSRIJ - COSTA*R2*RSS(:) 
298:                               DCBDR(:)   = EJ(:)/ABSRIJ - COSTB*R2*RSS(:) 
299:           
300:                               ! derivative of r_ij wrt pi 
301:                               DRIJDPI(1) = DOT_PRODUCT(RSS(:),DR1(J7,:)) 
302:                               DRIJDPI(2) = DOT_PRODUCT(RSS(:),DR2(J7,:)) 
303:                               DRIJDPI(3) = DOT_PRODUCT(RSS(:),DR3(J7,:)) 
304:           
305:                               ! derivative of r_ij wrt pj 
306:                               DRIJDPJ(1) =-DOT_PRODUCT(RSS(:),DR1(J8,:)) 
307:                               DRIJDPJ(2) =-DOT_PRODUCT(RSS(:),DR2(J8,:)) 
308:                               DRIJDPJ(3) =-DOT_PRODUCT(RSS(:),DR3(J8,:)) 
309:           
310:                               ! derivative of cos(theta) wrt pi 
311:                               DCADPI(1)  =-DOT_PRODUCT(DR1(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE1(J7,:)) &  
312:                                          - COSTA*R2*DRIJDPI(1) 
313:                               DCADPI(2)  =-DOT_PRODUCT(DR2(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE2(J7,:)) & 
314:                                          - COSTA*R2*DRIJDPI(2) 
315:                               DCADPI(3)  =-DOT_PRODUCT(DR3(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE3(J7,:)) & 
316:                                          - COSTA*R2*DRIJDPI(3) 
317:                               DCBDPI(1)  = DOT_PRODUCT(DR1(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(1) 
318:                               DCBDPI(2)  = DOT_PRODUCT(DR2(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(2) 
319:                               DCBDPI(3)  = DOT_PRODUCT(DR3(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(3) 
320:                           
321:                               ! derivative of cos(theta) wrt pj 
322:                               DCADPJ(1)  = DOT_PRODUCT(DR1(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(1) 
323:                               DCADPJ(2)  = DOT_PRODUCT(DR2(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(2) 
324:                               DCADPJ(3)  = DOT_PRODUCT(DR3(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(3) 
325:           
326:                               DCBDPJ(1)  =-DOT_PRODUCT(DR1(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE1(J8,:)) & 
327:                                          - COSTB*R2*DRIJDPJ(1) 
328:                               DCBDPJ(2)  =-DOT_PRODUCT(DR2(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE2(J8,:)) & 
329:                                          - COSTB*R2*DRIJDPJ(2) 
330:                               DCBDPJ(3)  =-DOT_PRODUCT(DR3(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE3(J8,:)) & 
331:                                          - COSTB*R2*DRIJDPJ(3) 
332:           
333:                            ENDIF 
334:             
335:                            ! calculate if I and J are both carbons  
336:                            IF (I <= NCARBON .AND. J <= NCARBON) THEN 
337:           
338:                               ! calculate rho_cc 
339:                               RHOCC   = RHOCC0 + RHOCC10*(COSTA + COSTB) + RHOCC20*(1.5D0*COSTA*COSTA &  
340:                                       + 1.5D0*COSTB*COSTB - 1.D0) 
341:                               ! ENERGY1 is energy due to short-range anisotropic interactions 
342:                               ! calculate vertical shift for first term 
343:                               EXPFCT  = KKJ*DEXP(-ALPHACC*(ABSRIJ - RHOCC)) 
344:                               VSHIFT1 = KKJ*DEXP(-ALPHACC*(EWALDREALC - RHOCC)) 
345:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
346:                               ! ENERGY2 is energy due to damped dispersion 
347:                               ! calculate vertical shift for second term 
348:                               VSHIFT2 = DC6CC*DMPFCT_SHIFT/(EWALDREALC**6) 
349:                               !print *, 'energy: ', dc6cc*dmpfct*r6 
350:                               ENERGY2 = ENERGY2 - DC6CC*DMPFCT*R6 + VSHIFT2 
351:           
352:                               IF (GTEST) THEN 
353:           
354:                                  ! DVDR is derivative of dispersion damping factor energy with factor 1/Rab 
355:                                  DVDR    = 6.D0*DC6CC*R6*R2*DMPFCT - DC6CC*R6*DDMPDR  
356:                                  !print *, 'grad: ', dvdr 
357:                                  ! FRIJ is derivative of ENERGY1 wrt r_ij with factor 1/Rab 
358:                                  FRIJ(:) = ALPHACC*EXPFCT*(-NR(:) + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADR(:) & 
359:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDR(:)) 
360:                                  ! TIJ is derivative of ENERGY1 wrt pi with factor 1/Rab 
361:                                  TIJ(:)  = ALPHACC*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPI(:) & 
362:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPI(:)) 
363:                                  ! TJI is derivative of ENERGY1 wrt pj with factor 1/Rab 
364:                                  TJI(:)  = ALPHACC*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPJ(:) & 
365:                                          + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPJ(:))  
366:           
367:                               ENDIF 
368:           
369:                            ! calculate if I and J are both hydorgens 
370:                            ELSEIF (I > NCARBON .AND. J > NCARBON) THEN 
371:           
372:                               RHOHH  = RHOHH0 + RHOHH10*(COSTA + COSTB) + RHOHH20*(1.5D0*COSTA*COSTA      & 
373:                                      + 1.5D0*COSTB*COSTB - 1.D0)  
374:                               EXPFCT  = KKJ*DEXP(-ALPHAHH*(ABSRIJ - RHOHH)) 
375:                               VSHIFT1 = KKJ*DEXP(-ALPHAHH*(EWALDREALC - RHOHH)) 
376:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
377:                               VSHIFT2 = DC6HH*DMPFCT_SHIFT/(EWALDREALC**6) 
378:                               !print *, 'energy: ', dc6hh*dmpfct*r6 
379:                               ENERGY2 = ENERGY2 - DC6HH*DMPFCT*R6 + VSHIFT2 
380:           
381:                               IF (GTEST) THEN 
382:           
383:                                  DVDR    = 6.D0*DC6HH*R6*R2*DMPFCT - DC6HH*R6*DDMPDR  
384:                                  !print *, 'grad: ', dvdr 
385:                                  FRIJ(:) = ALPHAHH*EXPFCT*(-NR(:) + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADR(:) & 
386:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDR(:)) 
387:                                  TIJ(:)  = ALPHAHH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPI(:) & 
388:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPI(:)) 
389:                                  TJI(:)  = ALPHAHH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPJ(:) & 
390:                                          + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPJ(:)) 
391:           
392:                               ENDIF 
393:           
394:                            ! calculate if I is carbon and J is hydrogen 
395:                            ELSE IF (I <= NCARBON .AND. J > NCARBON) THEN  
396:           
397:                               RHOCH  = RHOCH0 + RHOC10H*COSTA + RHOCH10*COSTB + RHOC20H*(1.5D0*COSTA*COSTA & 
398:                                      - 0.5D0) + RHOCH20*(1.5D0*COSTB*COSTB - 0.5D0) 
399:                               EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
400:                               VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
401:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
402:                               VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
403:                               !print *, 'energy: ', dc6ch*dmpfct*r6 
404:                               ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
405:           
406:                               IF (GTEST) THEN 
407:                             
408:                                  DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
409:                                  !print *, 'grad: ', dvdr 
410:                                  FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) & 
411:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:)) 
412:                                  TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) & 
413:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:)) 
414:                                  TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) & 
415:                                          + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:)) 
416:           
417:                               ENDIF 
418:           
419:                            ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN 
420:           
421:                               RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA & 
422:                                      - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0) 
423:                               EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
424:                               VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
425:                               ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
426:                               VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
427:                               !print *, 'energy: ', dc6ch*dmpfct*r6 
428:                               ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
429:           
430:                               IF (GTEST) THEN 
431:           
432:                                  DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
433:                                  !print *, 'grad: ', dvdr 
434:                                  FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) & 
435:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:)) 
436:                                  TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) & 
437:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:)) 
438:                                  TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) & 
439:                                          + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:)) 
440:           
441:                               ENDIF 
442:           
443:                            ENDIF 
444:           
445:                            IF (GTEST) THEN 
446:           
447:                               ! total gradient wrt CoM coords for rigid body J1 
448:                               G(J3-2:J3) = G(J3-2:J3) + DVDR*RSS(:) + FRIJ(:) 
449:                               !g(j3-2:j3) = g(j3-2:j3) + frij(:) 
450:  
451:                               !box_paramsgrad(1:3) = box_paramsgrad(1:3) + (dvdr*rss(1:3)+frij(1:3))*rcom(1:3)/box_params(1:3) 
452:                               ! total gradient wrt CoM coords for rigid body J2 
453:                               G(J4-2:J4) = G(J4-2:J4) - DVDR*RSS(:) - FRIJ(:) 
454:                               !g(j4-2:j4) = g(j4-2:j4) - frij(:) 
455:  
456:                               ! total gradient wrt AA coords for rigid body J1 
457:                               G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPI(:) + TIJ(:) 
458:                               !g(j5-2:j5) = g(j5-2:j5) + tij(:) 
459:                               ! total gradient wrt AA coords for rigid body J2 
460:                               G(J6-2:J6) = G(J6-2:J6) + DVDR*DRIJDPJ(:) + TJI(:) 
461:                               !g(j6-2:j6) = g(j6-2:j6) + tji(:) 
462:  
463:                               ! TODO: this is if orientation of rigid body depends on cell parameters 
464:                               !H_mat(:,:) = (-1.0d0/(vol*v_fact))*dv_fact(1)*H(:,:) + (1.0d0/vol)*H_grad(:,:,4) 
465:                               !rmatrix(:) = matmul(H_inverse, vol*(rss(:)-rcom(:))) 
466:                               !box_paramsgrad(4) = box_paramsgrad(4) + dvdr*dot_product(rss(1:3), matmul(H_mat, rmatrix(:))) 
467:  
468:                               !box_paramsgrad(1) = box_paramsgrad(1) + dvdr*dot_product(rss(1:3), matmul(H_mat/vol, rmatrix(:))) 
469:  
470:                               do idx = 1, 6 
471:                                  box_paramsgrad(idx) = box_paramsgrad(idx) + dot_product((dvdr*rss(1:3) + frij(1:3)), matmul(H_grad(:,:,idx), rcomfrac(:))) 
472:                               enddo 
473:  
474:                            ENDIF 
475:        
476:                         ENDIF310:                         ENDIF
 311:    
 312:                      ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN
 313:    
 314:                         RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA &
 315:                                - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0)
 316:                         EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH))
 317:                         VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH))
 318:                         ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1
 319:                         VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6)
 320:                         !print *, 'energy: ', dc6ch*dmpfct*r6
 321:                         ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2
 322:    
 323:                         IF (GTEST) THEN
 324:    
 325:                            DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR 
 326:                            !print *, 'grad: ', dvdr
 327:                            FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) &
 328:                                    + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:))
 329:                            TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) &
 330:                                    + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:))
 331:                            TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) &
 332:                                    + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:))
 333:    
 334:                         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
477: 351: 
478:                      enddo352:                   ENDIF
479:                   enddo 
480:                enddo 
481: 353: 
482:                ENDDO354:                ENDDO
483: 355: 
484:             ENDDO356:             ENDDO
485:  357:  
486:          ENDDO358:          ENDDO
487: 359: 
488:       ENDDO360:       ENDDO
489: 361: 
490: ! INCLUDE CONTRIBUTION OF RIGID BODY WITH PERIODIC IMAGE OF ITSELF 
491:  
492:       ! loop over rigidbodies 
493:       do j1 = 1, nrigidbody 
494:          j3 = 3*j1 
495:          j5 = offset + j3 
496:          ri(:) = x(j3-2:j3) 
497:  
498:          ! loop over sites i 
499:          do i = 1, nsiteperbody(j1) 
500:             j7 = maxsite*(j1-1) + i 
501:             ei(:) = e(j7,:) 
502:  
503:             ! loop over sites j 
504:             do j = 1, nsiteperbody(j1) 
505:                j8 = maxsite*(j1-1) + j 
506:                ej(:) = e(j8,:) 
507:  
508:                !print *, 'new!!', j1, i, j 
509:                rr(:) = r(j7,:) - r(j8,:) 
510:                !print *, j7, r(j7,:3) 
511:                !print *, j8, r(j8,:3) 
512:                !print *, 'rr: ', rr(:3) 
513:                ! convert to fractional 
514:                rrfrac(:) = matmul(H_inverse, rr(:)) 
515:                !print *, 'rrfrac: ', rrfrac(:3) 
516:  
517:                ! loop over boxes 
518:                do l = -newaldreal(1), newaldreal(1) 
519:                   do m = -newaldreal(2), newaldreal(2) 
520:                      do n = -newaldreal(3), newaldreal(3) 
521:  
522:                      if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
523:  
524:                         rssfrac(1) = rrfrac(1) + l 
525:                         rssfrac(2) = rrfrac(2) + m 
526:                         rssfrac(3) = rrfrac(3) + n 
527:                         !print *, l, m, n 
528:                         !print *, 'rssfrac: ', rssfrac(:3) 
529:                         rss(:) = matmul(H, rssfrac(:)) 
530:  
531:                         if (gtest.and.boxderivt) then 
532:                            rcomfrac(1) = l 
533:                            rcomfrac(2) = m 
534:                            rcomfrac(3) = n 
535:                            rcom(:) = matmul(H, rcomfrac(:)) 
536:                         endif 
537:  
538:                         r2 = dot_product(rss(:), rss(:)) 
539:                         !print *, 'rssmin2: ', rss(1:3) 
540:                         if (r2 < ewaldrealc2) then 
541:  
542:                         !print *, 'rssmin3: ', rss(1:3) 
543:                         !print *, 'r2    : ', r2 
544:                         !print *, 'rcom  : ', rcom(1:3) 
545:                         absrij = dsqrt(r2) 
546:                         !print *, j7, j8 
547:                         !print *, absrij 
548:                         nr(:) = rss(:)/absrij 
549:                         r2 = 1.d0/r2 
550:                         r6 = r2*r2*r2 
551:  
552:                         ! CALCULATE DISPERSION DAMPING FACTOR 
553:  
554:                         ! initialize sum for the damping function and vertical shift 
555:                         DMPFCT = 1.D0 
556:                         DMPFCT_SHIFT = 1.D0 
557:                         ! initialize sum for the derivative of damping function 
558:                         DDMPDR = B 
559:  
560:                         ! calculate sums 
561:                         DO K = 1, 6 
562:  
563:                            DMPFCT = DMPFCT + (B*ABSRIJ)**K/FLOAT(FCT(K)) 
564:                            DMPFCT_SHIFT = DMPFCT_SHIFT + (B*EWALDREALC)**K/FLOAT(FCT(K)) 
565:                            !IF (K > 1) DDMPDR = DDMPDR + (B**K)*(ABSRIJ)**(K-1)/FLOAT(FCT(K-1)) 
566:  
567:                         END DO 
568:  
569:                         EXPFCT = DEXP(-B*ABSRIJ) 
570:                         EXPFCT_SHIFT = DEXP(-B*EWALDREALC) 
571:                         ! DDMPDR is derivative of damping function with factor 1/Rab 
572:                         DDMPDR = (B*EXPFCT*DMPFCT - EXPFCT*DDMPDR)/ABSRIJ 
573:                         ! DMPFCT is damping function 
574:                         DMPFCT = 1.D0 - EXPFCT*DMPFCT 
575:                         ! DMPFCT_SHIFT is vertical shift for damping function 
576:                         DMPFCT_SHIFT = 1.D0 - EXPFCT_SHIFT*DMPFCT_SHIFT 
577:  
578:                         ! CALCULATE RHOAB 
579:                         ! calculate cos(theta)  
580:                         COSTA      =-DOT_PRODUCT(NR(:),EI(:)) 
581:                         COSTB      = DOT_PRODUCT(NR(:),EJ(:)) 
582:  
583:                         ! calculate terms relevant to derivatives 
584:                         IF (GTEST) THEN 
585:  
586:                            ! derivative of cos(theta) wrt r_ij 
587:                            DCADR(:)   =-EI(:)/ABSRIJ - COSTA*R2*RSS(:) 
588:                            DCBDR(:)   = EJ(:)/ABSRIJ - COSTB*R2*RSS(:) 
589:  
590:                            ! derivative of r_ij wrt pi 
591:                            DRIJDPI(1) = DOT_PRODUCT(RSS(:),DR1(J7,:)) 
592:                            DRIJDPI(2) = DOT_PRODUCT(RSS(:),DR2(J7,:)) 
593:                            DRIJDPI(3) = DOT_PRODUCT(RSS(:),DR3(J7,:)) 
594:  
595:                            ! derivative of r_ij wrt pj 
596:                            DRIJDPJ(1) =-DOT_PRODUCT(RSS(:),DR1(J8,:)) 
597:                            DRIJDPJ(2) =-DOT_PRODUCT(RSS(:),DR2(J8,:)) 
598:                            DRIJDPJ(3) =-DOT_PRODUCT(RSS(:),DR3(J8,:)) 
599:  
600:                            ! derivative of cos(theta) wrt pi 
601:                            DCADPI(1)  =-DOT_PRODUCT(DR1(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE1(J7,:)) &  
602:                                       - COSTA*R2*DRIJDPI(1) 
603:                            DCADPI(2)  =-DOT_PRODUCT(DR2(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE2(J7,:)) & 
604:                                       - COSTA*R2*DRIJDPI(2) 
605:                            DCADPI(3)  =-DOT_PRODUCT(DR3(J7,:),EI(:))/ABSRIJ - DOT_PRODUCT(NR(:),DE3(J7,:)) & 
606:                                       - COSTA*R2*DRIJDPI(3) 
607:                            DCBDPI(1)  = DOT_PRODUCT(DR1(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(1) 
608:                            DCBDPI(2)  = DOT_PRODUCT(DR2(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(2) 
609:                            DCBDPI(3)  = DOT_PRODUCT(DR3(J7,:),EJ(:))/ABSRIJ - COSTB*R2*DRIJDPI(3) 
610:  
611:                            ! derivative of cos(theta) wrt pj 
612:                            DCADPJ(1)  = DOT_PRODUCT(DR1(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(1) 
613:                            DCADPJ(2)  = DOT_PRODUCT(DR2(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(2) 
614:                            DCADPJ(3)  = DOT_PRODUCT(DR3(J8,:),EI(:))/ABSRIJ - COSTA*R2*DRIJDPJ(3) 
615:  
616:                            DCBDPJ(1)  =-DOT_PRODUCT(DR1(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE1(J8,:)) & 
617:                                       - COSTB*R2*DRIJDPJ(1) 
618:                            DCBDPJ(2)  =-DOT_PRODUCT(DR2(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE2(J8,:)) & 
619:                                       - COSTB*R2*DRIJDPJ(2) 
620:                            DCBDPJ(3)  =-DOT_PRODUCT(DR3(J8,:),EJ(:))/ABSRIJ + DOT_PRODUCT(NR(:),DE3(J8,:)) & 
621:                                       - COSTB*R2*DRIJDPJ(3) 
622:  
623:                         ENDIF 
624:  
625:                         ! calculate if I and J are both carbons  
626:                         IF (I <= NCARBON .AND. J <= NCARBON) THEN 
627:  
628:                            ! calculate rho_cc 
629:                            RHOCC   = RHOCC0 + RHOCC10*(COSTA + COSTB) + RHOCC20*(1.5D0*COSTA*COSTA &  
630:                                    + 1.5D0*COSTB*COSTB - 1.D0) 
631:                            ! ENERGY1 is energy due to short-range anisotropic interactions 
632:                            ! calculate vertical shift for first term 
633:                            EXPFCT  = KKJ*DEXP(-ALPHACC*(ABSRIJ - RHOCC)) 
634:                            VSHIFT1 = KKJ*DEXP(-ALPHACC*(EWALDREALC - RHOCC)) 
635:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
636:                            ! ENERGY2 is energy due to damped dispersion 
637:                            ! calculate vertical shift for second term 
638:                            VSHIFT2 = DC6CC*DMPFCT_SHIFT/(EWALDREALC**6) 
639:                            !print *, 'energy: ', dc6cc*dmpfct*r6 
640:                            ENERGY2 = ENERGY2 - DC6CC*DMPFCT*R6 + VSHIFT2 
641:                            !print *, 'vshift2     : ', vshift2 
642:                            !print *, 'contribution: ', -dc6cc*dmpfct*r6 
643:                            !print *, 'energy2     : ', energy2 
644:  
645:                            IF (GTEST) THEN 
646:  
647:                               ! DVDR is derivative of dispersion damping factor energy with factor 1/Rab 
648:                               DVDR    = 6.D0*DC6CC*R6*R2*DMPFCT - DC6CC*R6*DDMPDR  
649:                               !print *, 'dvdr        : ', dvdr 
650:                            !   !print *, 'grad: ', dvdr 
651:                            !   ! FRIJ is derivative of ENERGY1 wrt r_ij with factor 1/Rab 
652:                               FRIJ(:) = ALPHACC*EXPFCT*(-NR(:) + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADR(:) & 
653:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDR(:)) 
654:                               ! TIJ is derivative of ENERGY1 wrt pi with factor 1/Rab 
655:                               TIJ(:)  = ALPHACC*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPI(:) & 
656:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPI(:)) 
657:                            !   ! TJI is derivative of ENERGY1 wrt pj with factor 1/Rab 
658:                               TJI(:)  = ALPHACC*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCC10 + 3.D0*RHOCC20*COSTA)*DCADPJ(:) & 
659:                                       + (RHOCC10 + 3.D0*RHOCC20*COSTB)*DCBDPJ(:))  
660:  
661:                            ENDIF 
662:  
663:                         ! calculate if I and J are both hydorgens 
664:                         ELSEIF (I > NCARBON .AND. J > NCARBON) THEN 
665:  
666:                            RHOHH  = RHOHH0 + RHOHH10*(COSTA + COSTB) + RHOHH20*(1.5D0*COSTA*COSTA      & 
667:                                   + 1.5D0*COSTB*COSTB - 1.D0) 
668:                            EXPFCT  = KKJ*DEXP(-ALPHAHH*(ABSRIJ - RHOHH)) 
669:                            VSHIFT1 = KKJ*DEXP(-ALPHAHH*(EWALDREALC - RHOHH)) 
670:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
671:                            VSHIFT2 = DC6HH*DMPFCT_SHIFT/(EWALDREALC**6) 
672:                            !print *, 'energy: ', dc6hh*dmpfct*r6 
673:                            ENERGY2 = ENERGY2 - DC6HH*DMPFCT*R6 + VSHIFT2 
674:  
675:                            IF (GTEST) THEN 
676:  
677:                               DVDR    = 6.D0*DC6HH*R6*R2*DMPFCT - DC6HH*R6*DDMPDR  
678:                            !   !print *, 'grad: ', dvdr 
679:                               FRIJ(:) = ALPHAHH*EXPFCT*(-NR(:) + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADR(:) & 
680:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDR(:)) 
681:                               TIJ(:)  = ALPHAHH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPI(:) & 
682:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPI(:)) 
683:                               TJI(:)  = ALPHAHH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOHH10 + 3.D0*RHOHH20*COSTA)*DCADPJ(:) & 
684:                                       + (RHOHH10 + 3.D0*RHOHH20*COSTB)*DCBDPJ(:)) 
685:  
686:                            ENDIF 
687:  
688:                         ! calculate if I is carbon and J is hydrogen 
689:                         ELSE IF (I <= NCARBON .AND. J > NCARBON) THEN  
690:  
691:                            RHOCH  = RHOCH0 + RHOC10H*COSTA + RHOCH10*COSTB + RHOC20H*(1.5D0*COSTA*COSTA & 
692:                                   - 0.5D0) + RHOCH20*(1.5D0*COSTB*COSTB - 0.5D0) 
693:                            EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
694:                            VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
695:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
696:                            VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
697:                            !print *, 'energy: ', dc6ch*dmpfct*r6 
698:                            ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
699:  
700:                            IF (GTEST) THEN 
701:  
702:                               DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
703:                            !   !print *, 'grad: ', dvdr 
704:                               FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADR(:) & 
705:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDR(:)) 
706:                               TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPI(:) & 
707:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPI(:)) 
708:                               TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOC10H + 3.D0*RHOC20H*COSTA)*DCADPJ(:) & 
709:                                       + (RHOCH10 + 3.D0*RHOCH20*COSTB)*DCBDPJ(:)) 
710:  
711:                            ENDIF 
712:  
713:                         ELSE !IF(I > NCARBON .AND. J <= NCARBON) THEN 
714:  
715:                            RHOCH  = RHOCH0 + RHOCH10*COSTA + RHOC10H*COSTB + RHOCH20*(1.5D0*COSTA*COSTA & 
716:                                   - 0.5D0) + RHOC20H*(1.5D0*COSTB*COSTB - 0.5D0) 
717:                            EXPFCT  = KKJ*DEXP(-ALPHACH*(ABSRIJ - RHOCH)) 
718:                            VSHIFT1 = KKJ*DEXP(-ALPHACH*(EWALDREALC - RHOCH)) 
719:                            ENERGY1 = ENERGY1 + EXPFCT - VSHIFT1 
720:                            VSHIFT2 = DC6CH*DMPFCT_SHIFT/(EWALDREALC**6) 
721:                            !print *, 'energy: ', dc6ch*dmpfct*r6 
722:                            ENERGY2 = ENERGY2 - DC6CH*DMPFCT*R6 + VSHIFT2 
723:  
724:                            IF (GTEST) THEN 
725:  
726:                               DVDR    = 6.D0*DC6CH*R6*R2*DMPFCT - DC6CH*R6*DDMPDR  
727:                            !   !print *, 'grad: ', dvdr 
728:                               FRIJ(:) = ALPHACH*EXPFCT*(-NR(:) + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADR(:) & 
729:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDR(:)) 
730:                               TIJ(:)  = ALPHACH*EXPFCT*(-DRIJDPI(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPI(:) & 
731:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPI(:)) 
732:                               TJI(:)  = ALPHACH*EXPFCT*(-DRIJDPJ(:)/ABSRIJ + (RHOCH10 + 3.D0*RHOCH20*COSTA)*DCADPJ(:) & 
733:                                       + (RHOC10H + 3.D0*RHOC20H*COSTB)*DCBDPJ(:)) 
734:  
735:                            ENDIF 
736:  
737:                         ENDIF 
738:  
739:  
740:                         IF (GTEST) THEN 
741:  
742:                            ! total gradient wrt AA coords for rigid body J1 
743:                            G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPI(:) + TIJ(:) 
744:                            !g(j5-2:j5) = g(j5-2:j5) + tij(:) 
745:                            ! total gradient wrt AA coords for rigid body J2 
746:                            G(J5-2:J5) = G(J5-2:J5) + DVDR*DRIJDPJ(:) + TJI(:) 
747:                            !g(j5-2:j5) = g(j5-2:j5) + tji(:) 
748:                            !print *, 'dispersion:' 
749:                            !print *, dvdr*drijdpi(:3) 
750:                            !print *, dvdr*drijdpj(:3) 
751:                            !print *, 'energy2: ', energy2 
752:                            !print *, 'anisotropic:' 
753:                            !print *, tij(:3) 
754:                            !print *, tji(:3) 
755:  
756:                            do idx = 1, 6 
757:                                  box_paramsgrad(idx) = box_paramsgrad(idx) + dot_product((dvdr*rss(1:3) + frij(1:3)), matmul(H_grad(:,:,idx), rcomfrac(:))) 
758:                                  !box_paramsgrad(idx) = box_paramsgrad(idx) + dot_product(dvdr*rss(1:3), matmul(H_grad(:,:,idx), rcomfrac(:))) 
759:                            enddo 
760:  
761:                         ENDIF 
762:                         endif 
763:                     endif 
764:                   enddo 
765:                enddo 
766:             enddo 
767:             enddo 
768:          enddo 
769:       enddo 
770:  
771:       ! convert to cartesian coordinates362:       ! convert to cartesian coordinates
772:       XC(:) = 0.D0363:       XC(:) = 0.D0
773:       if (boxderivt) then 
774:          xdum(:) = x(:) 
775:          call cart2frac_rb_tri(nrigidbody, xdum, x, H_inverse) 
776:       endif 
777:       CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XC, X)364:       CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XC, X)
778:       ! restore cartesian rigid body coordinates 
779:       if (boxderivt) x(:) = xdum(:) 
780: 365: 
781: !      !!! ENERGY3 and G3 are energy and gradient due to electrostatics366:       ! ENERGY3 and G3 are energy and gradient due to electrostatics
782: !      !!! computed using Ewald summation367:       ! computed using Ewald summation
783:       CALL EWALDSUM(1, XC, G3C, ENERGY3, GTEST)368:       CALL EWALDSUM(1, XC, G3C, ENERGY3, GTEST)
784: !369: 
785: !      !!! convert Ewald contribution of gradient to rigidbody coordinates370: ! 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: 
 386:       ! convert Ewald contribution of gradient to rigidbody coordinates
786:       IF (GTEST) G3(:) = 0.D0387:       IF (GTEST) G3(:) = 0.D0
787:       CALL TRANSFORMGRAD(G3C, X, G3)388:       CALL TRANSFORMGRAD(G3C, X, G3)
788: !!      !print *, 'energy2: ', energy2 
789: 389: 
790:       !energy = (energy1+energy2)*2625.499d0 
791:       !if (gtest) g(:) = g(:)*2625.499d0 
792:       !energy = energy2*2625.499d0390:       !energy = energy2*2625.499d0
793:       !energy = (energy1+energy3)*2625.499d0391:       !if (gtest) g(:) = g(:)*2625.499d0
 392:       !energy = (energy3)*2625.499d0
794:       !if (gtest) g(:) = g3(:)*2625.499d0393:       !if (gtest) g(:) = g3(:)*2625.499d0
795:       !ENERGY = (ENERGY1 + ENERGY2 + ENERGY3)*2625.499D0 394:       ENERGY = (ENERGY1 + ENERGY2 + ENERGY3)*2625.499D0 
796:       !IF (GTEST) G(:) = (G(:) + G3(:))*2625.499D0395:       IF (GTEST) G(:) = (G(:) + G3(:))*2625.499D0
797:       !if (gtest) box_paramsgrad(1:6) = box_paramsgrad(1:6)*2625.499D0 
798:       !print *, 'box_paramsgrad: ', box_paramsgrad(1:3) 
799:       !print *, 'energy: ', energy2 
800: 396: 
801:       ! dj337: if input was cartesian, convert back to cartesian397:       ! dj337: if input was cartesian, convert back to cartesian
802:       ! assumes ATOMRIGIDCOORDT is correct398:       ! assumes ATOMRIGIDCOORDT is correct
803:       IF (ATOMRIGIDCOORDT) THEN399:       IF (ATOMRIGIDCOORDT) THEN
804: 400: 
805:          ! convert to cartesian coordinates401:          ! convert to cartesian coordinates
806:          if (boxderivt) then402:          XR(:) = 0.D0
807:             !print *, 'coords 708: ', x(1:3*natoms) 
808:             xdum(:) = x(:) 
809:             call cart2frac_rb_tri(nrigidbody, xdum, x, H_inverse) 
810:             !if (ortho) call cart2frac_rb_ortho(xdum, x) 
811:             !print *, 'coords 711: ', x(1:3*natoms) 
812:          endif 
813:          CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XR, X)403:          CALL TRANSFORMRIGIDTOC(1, NRIGIDBODY, XR, X)
814:          X(:) = XR(:)404:          X(:) = XR(:)
815:       ENDIF 
816:  
817:       call constrain_volume(v_fact, dv_fact, energy1, box_paramsgrad(4:6), gtest) 
818: 405: 
819:       ENERGY = (ENERGY1 + ENERGY2 + ENERGY3)*2625.499D0406:       ENDIF
820:       IF (GTEST) G(:) = (G(:) + G3(:))*2625.499D0 
821:       if (gtest) box_paramsgrad(1:6) = box_paramsgrad(1:6)*2625.499D0 
822:       !print *, 'coords benzrigid    : ', x(1:3*natoms) 
823:       !print *, 'box params benzrigid: ', box_params(1:6) 
824:  
825:       !print *, 'energy: ', energy1, energy2, energy3 
826:       !print *, 'grad  : ' 
827:       !do j1 = 1, 2*nrigidbody 
828:       !   print *, g(3*j1-2:3*j1) 
829:       !enddo 
830:  
831:       !print *, 'contri: ', energy1, energy2, energy3 
832:       !print *, 'energy: ', energy !, box_params(1:6) 
833:       !print *, 'g1    : ', g(1:3) 
834:       !stop 
835: 407: 
836:       END SUBROUTINE BENZGENRIGIDEWALD408:       END SUBROUTINE BENZGENRIGIDEWALD
837: 409: 
838: !     ----------------------------------------------------------------------------------------------410: !     ----------------------------------------------------------------------------------------------
839: !411: !
840: !      SUBROUTINE DEFPAHARIGID()412: !      SUBROUTINE DEFPAHARIGID()
841: !413: !
842: !      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, &
843: !                         ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ, CCKJ415: !                         ALPHACC, ALPHAHH, ALPHACH, DC6CC, DC6HH, DC6CH, KKJ, CCKJ
844: !416: !


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


r33129/cartdist.f90 2017-08-07 15:30:42.493416240 +0100 r33128/cartdist.f90 2017-08-07 15:30:49.217505691 +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 33128
  2: use commons, only: natoms, box_params, box_paramsgrad 
  3:  
  4: implicit none 
  5:  
  6: ! TODO 
  7: ! dj337: util modules 
  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:       !if (present(box_parameters)) then 
247:       !   box_lengths(:) = box_parameters(1:3) 
248:       !   box_angles(:) = box_parameters(4:6) 
249:       !else 
250:       !   box_lengths(:) = box_params(1:3) 
251:       !   box_angles(:) = box_params(4:6) 
252:       !endif 
253:  
254:       ! cosine of the angles 
255:       c(:) = dcos(box_angles(:)) 
256:       ! sine of the angles 
257:       s(:) = dsin(box_angles(:)) 
258:       ! factor that is related to the volume (but not quite volume) 
259:       v = dsqrt(1.0d0 - c(1)**2 - c(2)**2 - c(3)**2 + 2.0d0*c(1)*c(2)*c(3)) 
260:  
261:       ! define the H transformation matrix 
262:       ! first row of matrix 
263:       H(1,1) = box_lengths(1) 
264:       H(1,2) = box_lengths(2)*c(3) 
265:       H(1,3) = box_lengths(3)*c(2) 
266:       ! second row 
267:       H(2,2) = box_lengths(2)*s(3) 
268:       H(2,3) = box_lengths(3)*(c(1) - c(2)*c(3))/s(3) 
269:       ! third row 
270:       H(3,3) = box_lengths(3)*v/s(3) 
271:  
272:       ! compute derivatives of H matrix 
273:       if (gtest) then 
274:          ! wrt box length a 
275:          H_grad(1,1,1) = 1.0d0 
276:          ! wrt box length b 
277:          H_grad(1,2,2) = c(3) 
278:          H_grad(2,2,2) = s(3) 
279:          ! wrt box length c 
280:          H_grad(1,3,3) = c(2) 
281:          H_grad(2,3,3) = (c(1) - c(2)*c(3))/s(3) 
282:          H_grad(3,3,3) = v/s(3) 
283:          ! wrt box angle alpha 
284:          H_grad(2,3,4) = -box_lengths(3)*s(1)/s(3) 
285:          H_grad(3,3,4) = box_lengths(3)*(c(1)*s(1) - s(1)*c(2)*c(3))/(s(3)*v) 
286:          ! wrt box angle beta 
287:          H_grad(1,3,5) = -box_lengths(3)*s(2) 
288:          H_grad(2,3,5) = box_lengths(3)*s(2)*c(3)/s(3) 
289:          H_grad(3,3,5) = box_lengths(3)*s(2)*(c(2) - c(1)*c(3))/(s(3)*v) 
290:          ! wrt box angle gamma 
291:          H_grad(1,2,6) = -box_lengths(2)*s(3) 
292:          H_grad(2,2,6) = box_lengths(2)*c(3) 
293:          H_grad(2,3,6) = box_lengths(3)*(c(2) - c(1)*c(3))/s(3)**2 
294:          H_grad(3,3,6) = box_lengths(3)*((c(3) - c(1)*c(2))/v - v*c(3)/s(3)**2) 
295:       endif 
296:  
297:       return 
298:       end subroutine build_H 
299:  
300: ! ----------------------------------------------------------------------------------- 
301:  
302: ! COMPUTES CELL VOLUME. This works for any orthorhombic or triclinic unit cell. 
303: ! VARIABLES 
304: ! vol: cell volume 
305:  
306:        subroutine get_volume(vol) 
307:  
308:        use commons, only: ortho 
309:  
310:        implicit none 
311:  
312:        !double precision, intent(in), optional :: box_parameters(6) 
313:        double precision, intent(out)          :: vol 
314:        double precision                       :: box_lengths(3), box_angles(3), c(3) 
315:  
316:        box_lengths(:) = box_params(1:3) 
317:        box_angles(:) = box_params(4:6) 
318:  
319:        !if (present(box_parameters)) then 
320:        !   box_lengths(:) = box_parameters(1:3) 
321:        !   box_angles(:) = box_parameters(4:6) 
322:        !else 
323:        !   box_lengths(:) = box_params(1:3) 
324:        !   box_angles(:) = box_params(4:6) 
325:        !endif 
326:  
327:        vol = box_lengths(1)*box_lengths(2)*box_lengths(3) 
328:        if (.not.ortho) then 
329:           c(:) = dcos(box_angles(:)) 
330:           vol = vol * dsqrt(1.0d0 - c(1)**2 - c(2)**2 - c(3)**2 + 2.0d0*c(1)*c(2)*c(3)) 
331:        endif 
332:  
333:        end subroutine get_volume 
334:  
335: ! ----------------------------------------------------------------------------------- 
336:  
337: ! BUILDS THE K MATRIX whose columns are the reciprocal lattice vectors. If GTEST is 
338: ! true, computes the six derivative matrices of the K matrix with respects to the six 
339: ! cell parameters. This works for any triclinic unit cell. 
340: ! VARIABLES 
341: ! reciplatvec: matrix whose columns are the reciprocal lattice vectors 
342: !    first index corresponds to row, second to column 
343: ! reciplatvec_grad: derivatives of the reciprocal lattice vector matrix wrt cell parameters 
344: !    first index corresponds to row, second to column, third to cell parameter 
345:  
346:       subroutine get_reciplatvec(reciplatvec, reciplatvec_grad, gtest) 
347:  
348:       implicit none 
349:  
350:       double precision, intent(out) :: reciplatvec(3,3), reciplatvec_grad(3,3,6) 
351:       logical, intent(in)           :: gtest 
352:       double precision              :: box_lengths(3), box_angles(3) 
353:       double precision              :: c(3), s(3), v, dv(3), cfact 
354:       double precision, parameter   :: pi = 3.141592654d0 
355:  
356:       reciplatvec(:,:) = 0.0d0 
357:       reciplatvec_grad(:,:,:) = 0.0d0 
358:       box_lengths(:) = box_params(1:3) 
359:       box_angles(:) = box_params(4:6) 
360:         
361:       ! cosine of the angles 
362:       c(:) = dcos(box_angles(:)) 
363:       ! sine of the angles 
364:       s(:) = dsin(box_angles(:)) 
365:       ! factor that is related to the volume (but not quite volume) 
366:       !print *, 'box_params: ', box_params(:6) 
367:       !print *, 'v: ', v 
368:       !print *, 'v arg: ',(1.0d0 - c(1)**2 - c(2)**2 - c(3)**2 + 2.0d0*c(1)*c(2)*c(3))  
369:       v = dsqrt(1.0d0 - c(1)**2 - c(2)**2 - c(3)**2 + 2.0d0*c(1)*c(2)*c(3)) 
370:  
371:       ! define the reciprocal lattice vector matrix 
372:       ! first row of matrix 
373:       reciplatvec(1,1) = 1.0d0/box_lengths(1) 
374:       ! second row 
375:       reciplatvec(2,1) = -c(3)/(box_lengths(1)*s(3)) 
376:       reciplatvec(2,2) = 1.0d0/(box_lengths(2)*s(3)) 
377:       ! third row 
378:       reciplatvec(3,1) = (c(3)*(c(1) - c(2)*c(3)) - c(2)*s(3)**2)/(box_lengths(1)*v*s(3)) 
379:       reciplatvec(3,2) = -(c(1) - c(2)*c(3))/(box_lengths(2)*v*s(3)) 
380:       reciplatvec(3,3) = s(3)/(box_lengths(3)*v) 
381:       ! multiply by 2*pi 
382:       reciplatvec(:,:) = 2.0d0*pi*reciplatvec(:,:) 
383:  
384:       ! compute derivatives of reciprocal lattice vector matrix 
385:       if (gtest) then 
386:          ! gradient of v wrt cell angles 
387:          dv(1) = s(1)*(c(1)-c(2)*c(3))/v 
388:          dv(2) = s(2)*(c(2)-c(1)*c(3))/v 
389:          dv(3) = s(3)*(c(3)-c(1)*c(2))/v 
390:          ! cosine factor: cos(alpha) - cos(beta)cos(gamma) 
391:          cfact = c(1)-c(2)*c(3) 
392:  
393:          ! wrt box length a 
394:          reciplatvec_grad(1,1,1) = -1.0d0/box_lengths(1)**2  
395:          reciplatvec_grad(2,1,1) = c(3)/(box_lengths(1)**2*s(3)) 
396:          reciplatvec_grad(3,1,1) = (c(2)*s(3) - c(3)*cfact/s(3))/(box_lengths(1)**2*v) 
397:          ! wrt box length b 
398:          reciplatvec_grad(2,2,2) = -1.0d0/(box_lengths(2)**2*s(3)) 
399:          reciplatvec_grad(3,2,2) = cfact/(box_lengths(2)**2*s(3)*v) 
400:          ! wrt box length c 
401:          reciplatvec_grad(3,3,3) = -s(3)/(box_lengths(3)**2*v) 
402:          ! wrt cell angle alpha 
403:          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) 
404:          reciplatvec_grad(3,2,4) = (s(1) + cfact*dv(1)/v)/(box_lengths(2)*s(3)*v) 
405:          reciplatvec_grad(3,3,4) = -s(3)*dv(1)/(box_lengths(3)*v**2) 
406:          ! wrt cell angle beta 
407:          reciplatvec_grad(3,1,5) = ((s(2)*c(3)**2)/s(3) - c(3)*cfact*dv(2)/(s(3)*v) + & 
408:                                    s(2)*s(3) + c(2)*s(3)*dv(2)/v)/(box_lengths(1)*v) 
409:          reciplatvec_grad(3,2,5) = (-s(2)*c(3) + (cfact*dv(2)/v))/(box_lengths(2)*s(3)*v) 
410:          reciplatvec_grad(3,3,5) = -s(3)*dv(2)/(box_lengths(3)*v**2) 
411:          ! wrt cell angle gamma 
412:          reciplatvec_grad(2,1,6) = 1.0d0/(box_lengths(1)*s(3)**2) 
413:          reciplatvec_grad(2,2,6) = -c(3)/(box_lengths(2)*s(3)**2) 
414:          reciplatvec_grad(3,1,6) = (-cfact - c(3)**2*cfact/(s(3)**2) - c(3)*cfact*dv(3)/(s(3)*v) + & 
415:                                    c(2)*s(3)*dv(3)/v)/(box_lengths(1)*v) 
416:          reciplatvec_grad(3,2,6) = (-c(2)*s(3) + c(3)*cfact/s(3) + cfact*dv(3)/v)/(box_lengths(2)*s(3)*v) 
417:          reciplatvec_grad(3,3,6) = (c(3) - s(3)*dv(3)/v)/(box_lengths(3)*v) 
418:  
419:          ! multiply by 2*pi 
420:          reciplatvec_grad(:,:,:) = 2.0d0*pi*reciplatvec_grad(:,:,:) 
421:       endif 
422:  
423:       end subroutine get_reciplatvec 
424:  
425: ! ----------------------------------------------------------------------------------- 
426:  
427: end module 


r33129/checkd.f90 2017-08-07 15:30:42.713419166 +0100 r33128/checkd.f90 2017-08-07 15:30:49.437508616 +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  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:       !print *, 'checkd coords: ' 
 18:       !do j1 = 1, natoms 
 19:       !   print *, x(3*j1-2:3*j1) 
 20:       !enddo 
 21:  
 22:       print *, 'DELX: ', DELX 
 23:  
 24: ! jwrm2> Turning compression on, if required 14: ! jwrm2> Turning compression on, if required
 25:       IF (COMPRESST .OR. PERCOLATET) COMPON = .TRUE. 15:       IF (COMPRESST .OR. PERCOLATET) COMPON = .TRUE.
 26:  16: 
 27: ! jwrm2> Converting GTHOMSON coordinates to polars 17: ! jwrm2> Converting GTHOMSON coordinates to polars
 28:       IF (GTHOMSONT) THEN 18:       IF (GTHOMSONT) THEN
 29:         CALL GTHOMSONCTOANG(X(1:3*NATOMS), TMPCOORDS(1:3*NATOMS), NATOMS) 19:         CALL GTHOMSONCTOANG(X(1:3*NATOMS), TMPCOORDS(1:3*NATOMS), NATOMS)
 30:         X(1:3*NATOMS) = TMPCOORDS(1:3*NATOMS) 20:         X(1:3*NATOMS) = TMPCOORDS(1:3*NATOMS)
 31:       END IF 21:       END IF
 32:  22: 
 33:       STEST = .FALSE. 23:       STEST = .FALSE.
 34:  24: 
 35:       IF (CHECKDID == 0) THEN 25:       IF (CHECKDID == 0) THEN
 36:          GTEST = .FALSE. 26:          GTEST = .FALSE.
 37:          CALL POTENTIAL (X, G, ENERGY, GTEST, STEST) 27:          CALL POTENTIAL (X, G, ENERGY, GTEST, STEST)
 38:          WRITE(*, *) 'Energy  = ', ENERGY 28:          WRITE(*, *) 'Energy  = ', ENERGY
 39:  29: 
 40:       ELSEIF (CHECKDID == 1) THEN 30:       ELSEIF (CHECKDID == 1) THEN
 41:  31: 
 42: !     Checks gradients 32: !     Checks gradients
 43:  33: 
 44:       ! dj337: if box derivatives are computed 34:       DO IVRNO = 1, 3*NATOMS
 45:       IF (BOXDERIVT) THEN 35: 
 46:          !IF (ORTHO) THEN 36:          WRITE(*, *) IVRNO
 47:             ! check derivatives wrt atomic positions 
 48:             DO IVRNO = 1, DEGFREEDOMS!3*NATOMS 
 49:                WRITE(*, *) IVRNO 
 50:  
 51:                if (rigidinit.and.atomrigidcoordt) then 
 52:                   !print *, 'oh heyyyy' 
 53:                   call transformctorigid(x, tmpcoords) 
 54:                   x(1:degfreedoms) = tmpcoords(1:degfreedoms) 
 55:                   x(degfreedoms+1:3*natoms) = 0.0d0 
 56:                   atomrigidcoordt = .false. 
 57:                endif 
 58:  
 59:                !print *, x(1:3*natoms) 
 60:                GTEST = .FALSE. 
 61:                X(IVRNO) = X(IVRNO) - DELX 
 62:                !write(*, *) 'X minus  = ', x(ivrno) 
 63:                CALL POTENTIAL(X, G, FM, GTEST, STEST) 
 64:                !write(*, *) 'X minus2 = ', x(ivrno) 
 65:                !WRITE(*, *) 'Energy minus = ', FM 
 66:  
 67:                if (rigidinit.and.atomrigidcoordt) then 
 68:                   call transformctorigid(x, tmpcoords) 
 69:                   x(1:degfreedoms) = tmpcoords(1:degfreedoms) 
 70:                   x(degfreedoms+1:3*natoms) = 0.0d0 
 71:                   atomrigidcoordt = .false. 
 72:                endif 
 73:  
 74:                X(IVRNO) = X(IVRNO) + 2.D0*DELX 
 75:                !write(*, *) 'X plus   = ', x(ivrno) 
 76:                CALL POTENTIAL(X, G, FP, GTEST, STEST) 
 77:                !WRITE(*, *) 'Energy plus  = ', FP 
 78:                !write(*, *) 'X plus2  = ', x(ivrno) 
 79:       
 80:                if (rigidinit.and.atomrigidcoordt) then 
 81:                   call transformctorigid(x, tmpcoords) 
 82:                   x(1:degfreedoms) = tmpcoords(1:degfreedoms) 
 83:                   x(degfreedoms+1:3*natoms) = 0.0d0 
 84:                   atomrigidcoordt = .false.  
 85:                endif 
 86:   
 87:                GTEST = .TRUE. 
 88:                X(IVRNO) = X(IVRNO) - DELX 
 89:                !write(*, *) 'X       = ', x(ivrno) 
 90:                CALL POTENTIAL(X, G, ENERGY, GTEST, STEST) 
 91:                !write(*, *) 'X2      = ', x(ivrno) 
 92:                DFN = (FP - FM) / (2.D0*DELX) 
 93:                IF (ABS(DFN).LT.1.0D-10) DFN = 0.D0 
 94:                DFA = G(IVRNO) 
 95:  
 96:                WRITE(*, *) 'Gradient numerical  = ', DFN 
 97:                WRITE(*, *) 'Gradient analytical = ', DFA 
 98:  
 99:                IF (ABS(DFN - DFA) > ERRLIM) WRITE(*, *) IVRNO, DFN, DFA, ABS(DFN-DFA) 
100:                !stop 
101:             ENDDO 
102:  
103:             print *, 'New system: ' 
104:             ! check lattice derivatives 
105:             DO IVRNO = 1,6 
106:  
107:                if (rigidinit.and.atomrigidcoordt) then 
108:                   call transformctorigid(x, tmpcoords) 
109:                   x(1:degfreedoms) = tmpcoords(1:degfreedoms) 
110:                   atomrigidcoordt = .false. 
111:                endif 
112:  
113:                WRITE(*, *) 'Box parameter ', IVRNO 
114:  
115:                GTEST = .FALSE. 
116:                !box_paramsold(:) = box_params(:) 
117:                !print *, 'box_paramsold: ', box_paramsold(1:6) 
118:                BOX_PARAMS(IVRNO) = BOX_PARAMS(IVRNO) - DELX 
119:                !print *, 'atomrigidcoordt: ', atomrigidcoordt 
120:                !call rotate_bodies(box_paramsold, x) 
121:                !write(*, *) 'Box minus  = ', box_params(ivrno) 
122:                CALL POTENTIAL(X, G, FM, GTEST, STEST) 
123:                !WRITE(*, *) 'Box minus2 = ', BOX_PARAMS(IVRNO) 
124:                WRITE(*, *) 'Energy minus = ', FM 
125:  
126:                !box_paramsold(:) = box_params(:) 
127:                !print *, 'box_paramsold: ', box_paramsold(1:6) 
128:                BOX_PARAMS(IVRNO) = BOX_PARAMS(IVRNO) + 2.D0*DELX 
129:                !print *, 'atomrigidcoordt: ', atomrigidcoordt 
130:                !call rotate_bodies(box_paramsold, x) 
131:                !write(*, *), 'Box plus  = ', box_params(ivrno) 
132:                CALL POTENTIAL(X, G, FP, GTEST, STEST) 
133:                !WRITE(*, *) 'Box plus2  = ', BOX_PARAMS(IVRNO) 
134:                WRITE(*, *) 'Energy plus  = ', FP 
135:  
136:                GTEST = .TRUE. 
137:                !box_paramsold(:) = box_params(:) 
138:                !print *, 'box_paramsold: ', box_paramsold(1:6) 
139:                BOX_PARAMS(IVRNO) = BOX_PARAMS(IVRNO) - DELX 
140:                !print *, 'atomrigidcoordt: ', atomrigidcoordt 
141:                !call rotate_bodies(box_paramsold, x) 
142:                !write(*, *), 'Box       = ', box_params(ivrno)  
143:                CALL POTENTIAL(X, G, ENERGY, GTEST, STEST) 
144:                !write(*, *), 'Box2      = ', box_params(ivrno) 
145:                DFN = (FP - FM) / (2.D0*DELX) 
146:                IF (ABS(DFN).LT.1.0D-10) DFN = 0.D0 
147:                DFA = BOX_PARAMSGRAD(IVRNO) 
148:  
149:                WRITE(*, *) 'Box gradient numerical  = ', DFN 
150:                WRITE(*, *) 'Box gradient analytical = ', DFA 
151:  
152:                IF (ABS(DFN - DFA) > ERRLIM) WRITE(*, *) IVRNO, DFN, DFA, ABS(DFN-DFA) 
153:  
154:             ENDDO 
155:          !ENDIF 
156:  
157:       ELSE ! if no box derivatives 
158:  
159:          DO IVRNO = 1, 3*NATOMS!DEGFREEDOMS 
160:  
161:             WRITE(*, *) IVRNO 
162:  
163:             GTEST    = .FALSE. 
164:             X(IVRNO) = X(IVRNO) - DELX 
165:             CALL POTENTIAL (X, G, FM, GTEST, STEST) 
166:             WRITE(*, *) 'Energy minus = ', FM 
167:  
168:             X(IVRNO) = X(IVRNO) + 2.D0*DELX 
169:             CALL POTENTIAL (X, G,  FP, GTEST, STEST) 
170:             WRITE(*, *) 'Energy plus  = ', FP 
171:  
172:             GTEST = .TRUE. 
173:             X(IVRNO) = X(IVRNO) - DELX 
174:             CALL POTENTIAL (X, G, ENERGY, GTEST, STEST) 
175:             DFN = (FP - FM) / (2.D0*DELX) 
176:             IF (ABS(DFN) .LT. 1.0D-10) DFN = 0.D0 
177:             DFA = G(IVRNO) 
178:  37: 
179:             WRITE(*, *) 'Gradient numerical  = ', DFN 38:          GTEST    = .FALSE.
180:             WRITE(*, *) 'Gradient analytical = ', DFA 39:          X(IVRNO) = X(IVRNO) - DELX
  40:          CALL POTENTIAL (X, G, FM, GTEST, STEST)
  41:          WRITE(*, *) 'Energy minus = ', FM
  42: 
  43:          X(IVRNO) = X(IVRNO) + 2.D0*DELX
  44:          CALL POTENTIAL (X, G,  FP, GTEST, STEST)
  45:          WRITE(*, *) 'Energy plus  = ', FP
  46: 
  47:          GTEST = .TRUE.
  48:          X(IVRNO) = X(IVRNO) - DELX
  49:          CALL POTENTIAL (X, G, ENERGY, GTEST, STEST)
  50:          DFN = (FP - FM) / (2.D0*DELX)
  51:          IF (ABS(DFN) .LT. 1.0D-10) DFN = 0.D0
  52:          DFA = G(IVRNO)
181:  53: 
182:             IF (ABS(DFN - DFA) > ERRLIM) WRITE(*, *) IVRNO, DFN, DFA, ABS(DFN-DFA) 54:          WRITE(*, *) 'Gradient numerical  = ', DFN
  55:          WRITE(*, *) 'Gradient analytical = ', DFA
183:  56: 
184:          ENDDO 57:          IF (ABS(DFN - DFA) > ERRLIM) WRITE(*, *) IVRNO, DFN, DFA, ABS(DFN-DFA)
185:  58: 
186:       ENDIF 59:       ENDDO
187:  60: 
188:       ELSE IF (CHECKDID == 2) THEN 61:       ELSE IF (CHECKDID == 2) THEN
189:  62: 
190:          IF (.NOT. ALLOCATED(HESS)) ALLOCATE(HESS(3*NATOMS,3*NATOMS)) 63:          IF (.NOT. ALLOCATED(HESS)) ALLOCATE(HESS(3*NATOMS,3*NATOMS))
191:  64: 
192:          DO IVRNO1 = 1, 3*NATOMS 65:          DO IVRNO1 = 1, 3*NATOMS
193:             DO IVRNO2 = 1, 3*NATOMS 66:             DO IVRNO2 = 1, 3*NATOMS
194:                WRITE(*,*) IVRNO1, IVRNO2 67:                WRITE(*,*) IVRNO1, IVRNO2
195:                X(IVRNO1) = X(IVRNO1) - DELX 68:                X(IVRNO1) = X(IVRNO1) - DELX
196:                CALL POTENTIAL (X,G,ENERGY,.TRUE.,.FALSE.) 69:                CALL POTENTIAL (X,G,ENERGY,.TRUE.,.FALSE.)


r33129/commons.f90 2017-08-07 15:30:42.937422146 +0100 r33128/commons.f90 2017-08-07 15:30:49.657511542 +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, & 44:      &        SQNM_WRITEMAX, NEWALDREAL(3), NEWALDRECIP(3), EWALDN, MLPNEIGH
 45:      &        BOXSTEPFREQ 
 46:       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, &
 47:      &                 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),&
 48:      &                 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, &
 49:      &                 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, &
 50:      &                 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, &
 51:      &                 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,&
 52:      &                 TRENORM, HISTMIN, HISTMAX, HISTFAC, EPSSPHERE, FINALCUTOFF, SHELLPROB, RINGROTSCALE, & 51:      &                 TRENORM, HISTMIN, HISTMAX, HISTFAC, EPSSPHERE, FINALCUTOFF, SHELLPROB, RINGROTSCALE, &
 53:      &                 HISTFACMUL, HPERCENT, AVOIDDIST, MAXERISE, MAXEFALL, TSTART, MATDIFF, STICKYSIG, SDTOL, & 52:      &                 HISTFACMUL, HPERCENT, AVOIDDIST, MAXERISE, MAXEFALL, TSTART, MATDIFF, STICKYSIG, SDTOL, &
 54:      &                 MinimalTemperature, MaximalTemperature, SwapProb, hdistconstraint, COREFRAC, TSTAR, & 53:      &                 MinimalTemperature, MaximalTemperature, SwapProb, hdistconstraint, COREFRAC, TSTAR, &
 55:      &                 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, &
 80:      &                 MSTART,MFINISH,MBSTART1,MBFINISH1,MBSTART2,MBFINISH2,MBHEIGHT1,MBHEIGHT2,ME1,ME2,ME3, & 79:      &                 MSTART,MFINISH,MBSTART1,MBFINISH1,MBSTART2,MBFINISH2,MBHEIGHT1,MBHEIGHT2,ME1,ME2,ME3, &
 81:      &                 BSPTQMAX, BSPTQMIN, PFORCE, CSMNORM, CSMGUIDENORM, CSMEPS, PERCCUT, PERCGROUPCUT, & 80:      &                 BSPTQMAX, BSPTQMIN, PFORCE, CSMNORM, CSMGUIDENORM, CSMEPS, PERCCUT, PERCGROUPCUT, &
 82:      &                 LOWESTE, PERTSTEP, GCPLUS, & 81:      &                 LOWESTE, PERTSTEP, GCPLUS, &
 83:      &                 KINT, INTFREEZETOL, IMSEPMIN, IMSEPMAX, CONCUTABS, CONCUTFRAC, & 82:      &                 KINT, INTFREEZETOL, IMSEPMIN, IMSEPMAX, CONCUTABS, CONCUTFRAC, &
 84:      &                 LPDGEOMDIFFTOL, INTCONFRAC, MAXCONE, INTRMSTOL, BFGSTSTOL, ORBITTOL, & 83:      &                 LPDGEOMDIFFTOL, INTCONFRAC, MAXCONE, INTRMSTOL, BFGSTSTOL, ORBITTOL, &
 85:      &                 INTCONSTRAINTTOL, INTCONSTRAINTDEL, RBCUTOFF, INTCONSTRAINTREP, INTCONSTRAINREPCUT, & 84:      &                 INTCONSTRAINTTOL, INTCONSTRAINTDEL, RBCUTOFF, INTCONSTRAINTREP, INTCONSTRAINREPCUT, &
 86:      &                 INTLJTOL, INTLJDEL, INTLJEPS, REPCON, INTDGUESS, CHECKREPCUTOFF, INTMINFAC, FREEZETOL, & 85:      &                 INTLJTOL, INTLJDEL, INTLJEPS, REPCON, INTDGUESS, CHECKREPCUTOFF, INTMINFAC, FREEZETOL, &
 87:      &                 LOCALPERMCUT, LOCALPERMCUT2, INTCONCUT, QCIRADSHIFT, MLPLAMBDA, & 86:      &                 LOCALPERMCUT, LOCALPERMCUT2, INTCONCUT, QCIRADSHIFT, MLPLAMBDA, &
 88:      &                 CAPSIDRHO,CAPSIDEPS,SIGMAPENT,RADPENT,SIGMAHEX,RADHEX,SIGMAPH, KLIM, SCA, & 87:      &                 CAPSIDRHO,CAPSIDEPS,SIGMAPENT,RADPENT,SIGMAHEX,RADHEX,SIGMAPH, KLIM, SCA, &
 89:      &                 QCIADDREPCUT, QCIADDREPEPS, MLQLAMBDA, TANHFAC, LJADDCUTOFF,LJADDREFNORM, & 88:      &                 QCIADDREPCUT, QCIADDREPEPS, MLQLAMBDA, TANHFAC, LJADDCUTOFF,LJADDREFNORM, &
 90:  89:      &                 ALPHAATT, NNCUTOFF
 91: ! dj337: parameters for box derivatives 
 92:      &                 BOX_PARAMS(6), BOX_PARAMSGRAD(6), BOX_PARAMSO(6) 
 93:  90: 
 94:       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, &
 95:      &        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, &
 96:      &        MSORIGT, SQUEEZET, PERIODIC, SCT, MSCT, MGUPTAT, RESIZET, TIP, RIGID, CALCQT, MPIT, GBHT, JMT, LJCOULT, LJ_GAUSST, SETCENT, & 93:      &        MSORIGT, SQUEEZET, PERIODIC, SCT, MSCT, MGUPTAT, RESIZET, TIP, RIGID, CALCQT, MPIT, GBHT, JMT, LJCOULT, LJ_GAUSST, OPPT, SETCENT, &
 97:      &        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, &
 98:      &        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, &
 99:      &        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, &
100:      &        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, &
101:      &        FRAUSIT, ANGST, SELFT, STEPOUT, WENZEL, THRESHOLDT, THOMSONT, MULLERBROWNT, CHARMMENERGIES, & 98:      &        FRAUSIT, ANGST, SELFT, STEPOUT, WENZEL, THRESHOLDT, THOMSONT, MULLERBROWNT, CHARMMENERGIES, &
102:      &        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, &
103:      &        BLJCLUSTER, BLJCLUSTER_NOCUT, COMPRESST, FIX, FIXT, BFGS, LBFGST, DBRENTT, DZTEST, FNI, FAL, CPMD, TNT, ZETT1, &100:      &        BLJCLUSTER, BLJCLUSTER_NOCUT, COMPRESST, FIX, FIXT, BFGS, LBFGST, DBRENTT, DZTEST, FNI, FAL, CPMD, TNT, ZETT1, &
104:      &        ZETT2, GBH_RESTART, RESTART, CONJG, NEWRESTART, AVOID, NATBT, DIFFRACTT, CHRMMT, INTMINT, LB2T, &101:      &        ZETT2, GBH_RESTART, RESTART, CONJG, NEWRESTART, AVOID, NATBT, DIFFRACTT, CHRMMT, INTMINT, LB2T, &
105:      &        PTMC, BINSTRUCTURES, PROGRESS, MODEL1T, NEWRESTART_MD, CHANGE_TEMP, NOCISTRANS, CHECKCHIRALITY, &102:      &        PTMC, BINSTRUCTURES, PROGRESS, MODEL1T, NEWRESTART_MD, CHANGE_TEMP, NOCISTRANS, CHECKCHIRALITY, &
106:      &        GBT, GBDT, GBDPT, GEMT, LINRODT, RADIFT, CAPBINT, DBPT, DBPTDT, DMBLMT, DMBLPYT, EFIELDT, PAHAT, STOCKAAT, MORSEDPT, &103:      &        GBT, GBDT, GBDPT, GEMT, LINRODT, RADIFT, CAPBINT, DBPT, DBPTDT, DMBLMT, DMBLPYT, EFIELDT, PAHAT, STOCKAAT, MORSEDPT, &
113:      &        LJSITECOORDST, VGW, ACKLANDT, G46, DF1T, PULLT, LOCALSAMPLET, CSMT, A9INTET, INTERESTORE, COLDFUSION, &110:      &        LJSITECOORDST, VGW, ACKLANDT, G46, DF1T, PULLT, LOCALSAMPLET, CSMT, A9INTET, INTERESTORE, COLDFUSION, &
114:      &        CSMGUIDET, MULTISITEPYT, CHAPERONINT, AVOIDRESEEDT, OHCELLT, UNFREEZEFINALQ, PERCOLATET, PERCT, PERCACCEPTED, PERCCOMPMARKOV, PERCGROUPT, &111:      &        CSMGUIDET, MULTISITEPYT, CHAPERONINT, AVOIDRESEEDT, OHCELLT, UNFREEZEFINALQ, PERCOLATET, PERCT, PERCACCEPTED, PERCCOMPMARKOV, PERCGROUPT, &
115:      &        GENALT, MINDENSITYT, RESTRICTREGION, RESTRICTREGIONTEST, RESTRICTCYL, ACK1, ACK2, HARMONICF, PERCGROUPRESEEDT, &112:      &        GENALT, MINDENSITYT, RESTRICTREGION, RESTRICTREGIONTEST, RESTRICTCYL, ACK1, ACK2, HARMONICF, PERCGROUPRESEEDT, &
116:      &        HARMONICDONTMOVE, DUMPUNIQUE, FREEZESAVE, TBP, RBSYMT, PTMCDUMPSTRUCT, PTMCDUMPENERT, PYCOLDFUSION, MONITORT,&113:      &        HARMONICDONTMOVE, DUMPUNIQUE, FREEZESAVE, TBP, RBSYMT, PTMCDUMPSTRUCT, PTMCDUMPENERT, PYCOLDFUSION, MONITORT,&
117:      &        CHARMMDFTBT, PERMINVOPT, BLOCKMOVET, MAXERISE_SET, PYT, BINARY_EXAB, CHIROT, POLYT, SANDBOXT, &114:      &        CHARMMDFTBT, PERMINVOPT, BLOCKMOVET, MAXERISE_SET, PYT, BINARY_EXAB, CHIROT, POLYT, SANDBOXT, &
118:      &        RESERVOIRT, DISTOPT, ONEDAPBCT, ONEDPBCT, TWODAPBCT, TWODPBCT, THREEDAPBCT, THREEDPBCT, RATIOT, &115:      &        RESERVOIRT, DISTOPT, ONEDAPBCT, ONEDPBCT, TWODAPBCT, TWODPBCT, THREEDAPBCT, THREEDPBCT, RATIOT, &
119:      &        PTRANDOM, PTINTERVAL, PTSINGLE, PTSETS, CHEMSHIFT, CHEMSHIFT2, CSH, DEBUGss2029, UNIFORMMOVE, RANSEEDT, &116:      &        PTRANDOM, PTINTERVAL, PTSINGLE, PTSETS, CHEMSHIFT, CHEMSHIFT2, CSH, DEBUGss2029, UNIFORMMOVE, RANSEEDT, &
120:      &        TTM3T, NOINVERSION, RIGIDCONTOURT, UPDATERIGIDREFT, HYBRIDMINT, COMPRESSRIGIDT, MWFILMT, &117:      &        TTM3T, NOINVERSION, RIGIDCONTOURT, UPDATERIGIDREFT, HYBRIDMINT, COMPRESSRIGIDT, MWFILMT, &
121:      &        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, &
122:      &        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, &
123:      &        SAVEMULTIMINONLY, GRADPROBLEMT, INTLJT, CONDATT, QCIPERMCHECK, &120:      &        SAVEMULTIMINONLY, GRADPROBLEMT, INTLJT, CONDATT, QCIPERMCHECK, RIGIDMBPOLT, &
124:      &        INTCONSTRAINTT, INTFREEZET, CHECKCONINT, CONCUTABST, CONCUTFRACT, INTERPCOSTFUNCTION, &121:      &        INTCONSTRAINTT, INTFREEZET, CHECKCONINT, CONCUTABST, CONCUTFRACT, INTERPCOSTFUNCTION, &
125:      &        RBAAT, FREEZENODEST, DUMPINTEOS, DUMPINTXYZ, QCIPOTT, QCIPOT2T, INTSPRINGACTIVET, LPERMDIST, LOCALPERMDIST, QCIRADSHIFTT, &122:      &        RBAAT, FREEZENODEST, DUMPINTEOS, DUMPINTXYZ, QCIPOTT, QCIPOT2T, INTSPRINGACTIVET, LPERMDIST, LOCALPERMDIST, QCIRADSHIFTT, &
126:      &        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, &
127:      &        DUMPMQT, MLQT, MLQPROB, LJADD2T, MLPVB3T, NOREGBIAS, PYADDT, PYADD2T, LJADD3T, REORDERADDT,  LJADD4T, &124:      &        DUMPMQT, MLQT, MLQPROB, LJADD2T, MLPVB3T, NOREGBIAS, PYADDT, PYADD2T, LJADD3T, REORDERADDT,  LJADD4T, &
128:      &        SQNMT, SQNM_DEBUGT, SQNM_BIOT, BENZRIGIDEWALDT, ORTHO, EWALDT, BOXDERIVT125:      &        SQNMT, SQNM_DEBUGT, SQNM_BIOT, BENZRIGIDEWALDT, ORTHO, EWALDT, WATERMETHANET, MLPVB3NNT, CLATHRATET, LJADD3GUIDET
129: !126: !
130:       DOUBLE PRECISION, ALLOCATABLE :: SEMIGRAND_MU(:)127:       DOUBLE PRECISION, ALLOCATABLE :: SEMIGRAND_MU(:)
131:       DOUBLE PRECISION, ALLOCATABLE :: ATMASS(:)128:       DOUBLE PRECISION, ALLOCATABLE :: ATMASS(:)
132:       DOUBLE PRECISION, ALLOCATABLE :: SPECMASS(:)129:       DOUBLE PRECISION, ALLOCATABLE :: SPECMASS(:)
133: 130: 
134: ! dj337: Ewald summation variables131: ! dj337: Ewald summation variables
135:       DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: RERHOARRAY, IMRHOARRAY132:       DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: RERHOARRAY, IMRHOARRAY
136: 133: 
137: ! csw34> FREEZEGROUP variables134: ! csw34> FREEZEGROUP variables
138: !135: !
139:       INTEGER :: GROUPCENTRE136:       INTEGER :: GROUPCENTRE
140:       DOUBLE PRECISION :: GROUPRADIUS137:       DOUBLE PRECISION :: GROUPRADIUS
141:       CHARACTER (LEN=2) :: FREEZEGROUPTYPE138:       CHARACTER (LEN=2) :: FREEZEGROUPTYPE
142:       LOGICAL :: FREEZEGROUPT139:       LOGICAL :: FREEZEGROUPT
143: ! END140: ! END
144: 141: 
145: !142: !
146: ! csw34> DONTMOVE variables143: ! csw34> DONTMOVE variables
147: !144: 
148:       INTEGER :: NDONTMOVE, DONTMOVECENTRE145:       INTEGER :: NDONTMOVE, DONTMOVECENTRE
149:       DOUBLE PRECISION :: DONTMOVERADIUS146:       DOUBLE PRECISION :: DONTMOVERADIUS
150:       CHARACTER (LEN=2) :: DONTMOVEGROUPTYPE147:       CHARACTER (LEN=2) :: DONTMOVEGROUPTYPE
151:       LOGICAL :: DONTMOVET, DONTMOVEGROUPT, DONTMOVEREST, DONTMOVEALL, DOMOVEREST148:       LOGICAL :: DONTMOVET, DONTMOVEGROUPT, DONTMOVEREST, DONTMOVEALL, DOMOVEREST
152:       LOGICAL, ALLOCATABLE :: DONTMOVE(:),DONTMOVERES(:)149:       LOGICAL, ALLOCATABLE :: DONTMOVE(:),DONTMOVERES(:)
153:       INTEGER, ALLOCATABLE :: DUMPXYZUNIT(:), DUMPVUNIT(:)150:       INTEGER, ALLOCATABLE :: DUMPXYZUNIT(:), DUMPVUNIT(:)
154: !151: !
155: ! csw34> PAIRDIST variables152: ! csw34> PAIRDIST variables
156: !153: !
157:       INTEGER :: NPAIRS154:       INTEGER :: NPAIRS
361: !ds656> Stress tensor358: !ds656> Stress tensor
362:       LOGICAL :: STRESST359:       LOGICAL :: STRESST
363:       INTEGER :: STRESS_MODE360:       INTEGER :: STRESS_MODE
364:       DOUBLE PRECISION, ALLOCATABLE :: STRESS(:,:,:)361:       DOUBLE PRECISION, ALLOCATABLE :: STRESS(:,:,:)
365: 362: 
366: !ds656> A saw-tooth temperature protocol363: !ds656> A saw-tooth temperature protocol
367:       LOGICAL :: SAWTOOTH364:       LOGICAL :: SAWTOOTH
368:       INTEGER :: SAWTOOTH_NREJMAX365:       INTEGER :: SAWTOOTH_NREJMAX
369:       DOUBLE PRECISION :: SAWTOOTH_TMAX, SAWTOOTH_TFAC, &366:       DOUBLE PRECISION :: SAWTOOTH_TMAX, SAWTOOTH_TFAC, &
370:            SAWTOOTH_SFAC, SAWTOOTH_SFAC2367:            SAWTOOTH_SFAC, SAWTOOTH_SFAC2
371: 368: !cv320> Variable for clathrates
 369:       INTEGER :: NWATER
372: !ds656> Dump current Markov state at regular intervals370: !ds656> Dump current Markov state at regular intervals
373:       LOGICAL :: DUMP_MARKOV371:       LOGICAL :: DUMP_MARKOV
374:       INTEGER :: DUMP_MARKOV_NWAIT, DUMP_MARKOV_NFREQ372:       INTEGER :: DUMP_MARKOV_NWAIT, DUMP_MARKOV_NFREQ
375: 373: 
376: !   allocatables374: !   allocatables
377: 375: 
378:       INTEGER,ALLOCATABLE,DIMENSION(:) :: MOVABLEATOMLIST         ! a list containing the movable atom indices376:       INTEGER,ALLOCATABLE,DIMENSION(:) :: MOVABLEATOMLIST         ! a list containing the movable atom indices
379:       LOGICAL,ALLOCATABLE,DIMENSION(:) :: MOVABLEATOMLISTLOGICAL  ! is atom i movable?377:       LOGICAL,ALLOCATABLE,DIMENSION(:) :: MOVABLEATOMLISTLOGICAL  ! is atom i movable?
380:       INTEGER,ALLOCATABLE,DIMENSION(:) :: ATOMSINBLOCK            ! for BLOCKMOVE, to split movableatoms into separate blocks378:       INTEGER,ALLOCATABLE,DIMENSION(:) :: ATOMSINBLOCK            ! for BLOCKMOVE, to split movableatoms into separate blocks
381:       INTEGER,ALLOCATABLE,DIMENSION(:) :: NSPECIES(:), NSPECIES_INI(:)             ! for multicomponent systems379:       INTEGER,ALLOCATABLE,DIMENSION(:) :: NSPECIES(:), NSPECIES_INI(:)             ! for multicomponent systems
654:       INTEGER, ALLOCATABLE ::  MLPOUTCOME(:)652:       INTEGER, ALLOCATABLE ::  MLPOUTCOME(:)
655:       DOUBLE PRECISION, ALLOCATABLE ::  MLQDAT(:,:)653:       DOUBLE PRECISION, ALLOCATABLE ::  MLQDAT(:,:)
656:       INTEGER, ALLOCATABLE ::  MLQOUTCOME(:)654:       INTEGER, ALLOCATABLE ::  MLQOUTCOME(:)
657:       INTEGER, ALLOCATABLE ::  LJADDNN(:,:)655:       INTEGER, ALLOCATABLE ::  LJADDNN(:,:)
658: 656: 
659:       INTEGER, DIMENSION(:,:), ALLOCATABLE :: BONDS !for QCIAMBER657:       INTEGER, DIMENSION(:,:), ALLOCATABLE :: BONDS !for QCIAMBER
660: 658: 
661: !OPEP interface659: !OPEP interface
662:       LOGICAL :: OPEPT, OPEP_RNAT660:       LOGICAL :: OPEPT, OPEP_RNAT
663: 661: 
 662: !AMBER mutational steps
 663:       LOGICAL :: AMBERMUTATIONT
 664:       INTEGER :: MUTUNIT,NMUTATION,MUTATIONFREQ,MUTTESTSTEPS,AMBERMUTFF,AMBERMUTIGB,MUTENERGY,MUTTERMID
 665: 
 666: !Orbital variables
 667:       LOGICAL :: ORBITALS
 668:       INTEGER :: NROTS, NORBS, ORBVAREXPONENT
 669:       DOUBLE PRECISION, ALLOCATABLE :: R2INTS(:,:), DIPINTS(:,:,:)
664: END MODULE COMMONS670: END MODULE COMMONS


r33129/ewald.f90 2017-08-07 15:30:43.157425072 +0100 r33128/ewald.f90 2017-08-07 15:30:49.877514469 +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:       double precision, parameter  :: pi = 3.141592654D0 
522:  
523:       ! reciprocal-space cutoff 
524:       ewaldrecipc2 = ewaldrecipc**2 
525:  
526:       ! make sure allocated arrays for structure factors are the correct size 
527:       dims(:) = 2*newaldrecip(1:3)+1  
528:       if (.not.allocated(rerhoarray)) allocate(rerhoarray(dims(1), dims(2), dims(3))) 
529:       if (.not.allocated(imrhoarray)) allocate(imrhoarray(dims(1), dims(2), dims(3))) 
530:  
531:       if (.not.(size(rerhoarray,1).eq.dims(1).and.size(rerhoarray,2).eq.dims(2).and.size(rerhoarray,3).eq.dims(3))) then 
532:          deallocate(rerhoarray)  
533:          deallocate(imrhoarray) 
534:          allocate(rerhoarray(dims(1), dims(2), dims(3))) 
535:          allocate(imrhoarray(dims(1), dims(2), dims(3))) 
536:       endif 
537:  
538:       ! get reciprocal lattice vectors 
539:       call get_reciplatvec(reciplatvec, reciplatvec_grad, .false.) 
540:  
541:       ! iterate over boxes and calculate reciprocal lattice vectors257:       ! iterate over boxes and calculate reciprocal lattice vectors
542:       ! note: because of anti/symmetry in sine and cosine functions,258:       ! note: because of anti/symmetry in sine and cosine functions,
543:       ! only need to calculate terms for half of the k-values259:       ! only need to calculate terms for half of the k-values
544:       do l = 0,newaldrecip(1)260:       do l = 0,newaldrecip(1)
545:          do m = -newaldrecip(2), newaldrecip(2)261:          k(1) = 2*pi*l/boxlx
546:             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
547:                ! check not in central box266:                ! check not in central box
548:                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
549:                   k = l*reciplatvec(:,1) + m*reciplatvec(:,2) + n*reciplatvec(:,3) 
550:                   k2 = k(1)**2 + k(2)**2 + k(3)**2268:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
551:                   rerho=0.0d0 
552:                   imrho=0.0d0 
553:                   if (k2 < ewaldrecipc2) then269:                   if (k2 < ewaldrecipc2) then
 270:                      rerho=0.0d0
 271:                      imrho=0.0d0
554:                      ! iterate over atoms272:                      ! iterate over atoms
555:                      do j1 = 1, natoms273:                      do j1 = 1, natoms
556:                         j3 = 3*j1274:                         j3 = 3*j1
557:                         q1 = stchrg(j1)275:                         q1 = stchrg(j1)
558:                         r(:) = x(j3-2:j3)276:                         r(1) = x(j3-2)
 277:                         r(2) = x(j3-1)
 278:                         r(3) = x(j3)
559:                         ! dot product of k and ri279:                         ! dot product of k and ri
560:                         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)
561:                         ! rerho = sum_i(Qi*cos(k*ri))281:                         ! rerho = sum_i(Qi*cos(k*ri))
562:                         rerho = rerho + q1*dcos(kdotr)282:                         rerho = rerho + q1*dcos(kdotr)
563:                         ! imrho = sum_i(Qi*sin(k*ri))283:                         ! imrho = sum_i(Qi*sin(k*ri))
564:                         imrho = imrho + q1*dsin(kdotr)284:                         imrho = imrho + q1*dsin(kdotr)
565:                      enddo ! atoms285:                      enddo
566:                   endif ! within cutoff286:                   endif
567:                   ! store rerho and imrho values287:                   ! store rerho and imrho values
568:                   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
569:                   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
570:                   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
571:                   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
572:                endif ! not in central box292:                endif
573:             enddo ! n293:             enddo
574:          enddo ! m294:          enddo
575:       enddo ! l295:       enddo
576: 296: 
577:       return297:       return
578:       end subroutine ftdensity_tri298:       endsubroutine
579:  
580: ! ----------------------------------------------------------------------------------- 
581: ! Calculates long-range contribution to Coulomb energy. Uses terms calculated by 
582: ! ftdensity_ortho subroutine (structure factors) to simplify computation. 
583:  
584: ! Assumes orthorhombic unit cell. 
585: ! ----------------------------------------------------------------------------------- 
586:       subroutine coulombrecip_ortho(x, newaldrecip, erecip) 
587: 299: 
588:       use commons, only: rerhoarray, imrhoarray300: ! ---------------------------------------
589:       use cartdist, only: get_volume301: ! dj337: Calculates energy contributions to Coulomb sum due to
 302: ! reciprocal-space sum. Uses terms calculated by ftdensity subroutine
 303: ! to use structure factors to simplify computation.
 304: !
 305: ! Assumes orthogonal lattice vectors.
 306: ! ---------------------------------------
 307:       subroutine coulombrecip(x, erecip)
590: 308: 
591:       implicit none309:       implicit none
592: 310: 
593:       integer                         :: l, m, n311:       integer                         :: l, m, n
594:       integer, intent(in)             :: newaldrecip(3) 
595:       double precision, intent(in)    :: x(3*natoms)312:       double precision, intent(in)    :: x(3*natoms)
596:       double precision                :: vol, ewaldrecipc2, k(3)313:       double precision                :: k(3)
 314:       double precision                :: vol, ewaldrecipc2
597:       double precision                :: k2, rerho, imrho, esum315:       double precision                :: k2, rerho, imrho, esum
598:       double precision, intent(inout) :: erecip316:       double precision, intent(inout) :: erecip
599:       double precision, parameter     :: pi = 3.141592654D0317:       double precision, parameter     :: pi = 3.141592654D0
600: 318: 
601:       ! cell volume319:       ! cell volume
602:       call get_volume(vol)320:       call volume(vol)
603:       ! reciprocal-space cutoff 
604:       ewaldrecipc2 = ewaldrecipc**2 
605:       ! compute / store structure factors 
606:       call ftdensity_ortho(x, newaldrecip) 
607:       esum = 0.0d0 
608:  
609:       ! compute reciprocal-space sum 
610:       ! U_f = (2*pi/V)*(sum_k(exp(-k**2/4*alpha**2)*S(k)S(-k)/k**2) 
611:       ! iterate over boxes and calculate reciprocal lattice vectors 
612:       do l = -newaldrecip(1), newaldrecip(1) 
613:          k(1) = 2*pi*l/box_params(1) 
614:          do m = -newaldrecip(2), newaldrecip(2) 
615:             k(2) = 2*pi*m/box_params(2) 
616:             do n = -newaldrecip(3), newaldrecip(3) 
617:                k(3) = 2*pi*n/box_params(3) 
618:                ! check not in central box 
619:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
620:                   k2 = k(1)**2 + k(2)**2 + k(3)**2 
621:                   if (k2 < ewaldrecipc2) then 
622:                      ! get structure factors 
623:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) 
624:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) 
625:                      ! calculate long-range contribution 
626:                      esum = esum + dexp(-k2/(4.0d0*ewaldalpha**2))*(rerho**2+imrho**2)/k2 
627:                   endif ! within cutoff 
628:                endif ! not in central box 
629:             enddo ! n 
630:          enddo ! m 
631:       enddo ! l 
632:  
633:       ! multiply sum by factor of 2*pi/vol 
634:       erecip = erecip + 2.0d0*pi*esum/vol 
635:  
636:       return 
637:       end subroutine coulombrecip_ortho 
638:  
639: ! ----------------------------------------------------------------------------------- 
640: ! Calculates long-range contribution to Coulomb energy. Uses terms calculated by 
641: ! ftdensity_ortho subroutine (structure factors) to simplify computation. 
642:  
643: ! Assumes triclinic unit cell. 
644: ! ----------------------------------------------------------------------------------- 
645:       subroutine coulombrecip_tri(x, newaldrecip, erecip) 
646:  
647:       use commons, only: rerhoarray, imrhoarray 
648:       use cartdist, only: get_volume, get_reciplatvec 
649:  
650:       implicit none 
651:  
652:       integer                         :: l, m, n 
653:       integer, intent(in)             :: newaldrecip(3) 
654:       double precision, intent(in)    :: x(3*natoms) 
655:       double precision                :: reciplatvec(3,3), reciplatvec_grad(3,3,6), k(3) 
656:       double precision                :: vol, ewaldrecipc2, k2, rerho, imrho, esum 
657:       double precision, intent(inout) :: erecip 
658:       double precision, parameter     :: pi = 3.141592654D0 
659:  
660:       ! cell volume 
661:       call get_volume(vol) 
662:       ! reciprocal lattice vectors 
663:       call get_reciplatvec(reciplatvec, reciplatvec_grad, .false.) 
664:       ! reciprocal-space cutoff321:       ! reciprocal-space cutoff
665:       ewaldrecipc2 = ewaldrecipc**2322:       ewaldrecipc2 = ewaldrecipc**2
666:       ! compute / store structure factors323:       call ftdensity(x)
667:       call ftdensity_tri(x, newaldrecip) 
668:       esum = 0.0d0324:       esum = 0.0d0
669: 325: 
670:       ! compute reciprocal-space sum326:       ! compute reciprocal-space sum
671:       ! 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)
672:       ! iterate over boxes and calculate reciprocal lattice vectors328:       ! iterate over boxes and calculate reciprocal lattice vectors
673:       do l = -newaldrecip(1), newaldrecip(1)329:       do l = -newaldrecip(1), newaldrecip(1)
 330:          k(1) = 2*pi*l/boxlx
674:          do m = -newaldrecip(2), newaldrecip(2)331:          do m = -newaldrecip(2), newaldrecip(2)
 332:             k(2) = 2*pi*m/boxly
675:             do n = -newaldrecip(3), newaldrecip(3)333:             do n = -newaldrecip(3), newaldrecip(3)
 334:                k(3) = 2*pi*n/boxlz
676:                ! check not in central box335:                ! check not in central box
677:                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
678:                   k = l*reciplatvec(:,1) + m*reciplatvec(:,2) + n*reciplatvec(:,3) 
679:                   k2 = k(1)**2 + k(2)**2 + k(3)**2337:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
680:                   if (k2 < ewaldrecipc2) then338:                   if (k2 < ewaldrecipc2) then
681:                      ! get structure factors 
682:                      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)
683:                      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)
684:                      ! calculate long-range contribution341:                      ! calculate long-range contribution
685:                      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
686:                   endif ! within cutoff343:                   endif
687:                endif ! not in central box344:                endif
688:             enddo ! n345:             enddo
689:          enddo ! m346:          enddo
690:       enddo ! l347:       enddo
691: 348: 
692:       ! multiply sum by factor of 2*pi/vol349:       ! multiply sum by factor of 2*pi/vol
693:       erecip = erecip + 2.0d0*pi*esum/vol350:       erecip = erecip + 2.0d0*pi*esum/vol
694: 351: 
695:       return352:       return
696:       end subroutine coulombrecip_tri353:       end subroutine
697: 354: 
698: ! -----------------------------------------------------------------------------------355: ! ---------------------------------------
699: ! Calculates the real-space contribution to the gradient with respects to atomic356: ! dj337: Calculates the real-space contribution to the gradient
700: ! positions. Also calculates real-space contribution to the gradient wrt lattice357: ! of the Coulomb sum. 
701: ! vectors, if BOXDERIVT is true.358: !
702: 359: ! Assumes orthogonal lattice vectors.
703: ! Assumes orthorhombic unit cell.360: ! ---------------------------------------
704: ! -----------------------------------------------------------------------------------361:       subroutine coulombrealgrad(x, g)
705:       subroutine coulombrealgrad_ortho(x, newaldreal, g) 
706: 362: 
707:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, gr_weights363:       use commons
708: 364: 
709:       implicit none365:       implicit none
710: 366: 
711:       integer                         :: j1, j3, j2, j4, l, m, n367:       integer                         :: j1, j3, j2, j4, l, m, n
712:       integer, intent(in)             :: newaldreal(3) 
713:       double precision, intent(in)    :: x(3*natoms)368:       double precision, intent(in)    :: x(3*natoms)
714:       double precision, intent(inout) :: g(3*natoms)369:       double precision, intent(inout) :: g(3*natoms)
715:       double precision                :: com(3), mass, comcoords(3*natoms)370:       double precision                :: r(3), rmin(3), f(3)
716:       double precision                :: rss(3), rmin(3), r(3), rcommin(3), rcom(3), f(3)371:       double precision                :: ewaldrealc2
717:       double precision                :: ewaldrealc2, q1, q2, mul, dist, dist2372:       double precision                :: q1, q2, mul, dist, dist2
718:       double precision, parameter     :: pi = 3.141592654d0373:       double precision, parameter     :: pi = 3.141592654d0
719: 374: 
720:       ! if rigid bodies, calculate COM coordinates 
721:       ! to compute box derivatives 
722:       if (rigidinit.and.boxderivt) then 
723:          do j1 = 1, nrigidbody 
724:             ! calculate COM 
725:             com(:) = 0.0d0 
726:             mass = 0.0d0 
727:             do j2 = 1, nsiteperbody(j1) 
728:                j3 = rigidgroups(j2, j1) 
729:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3) 
730:                mass = mass + gr_weights(j3) 
731:             enddo 
732:             com(1:3) = com(1:3) / mass 
733:             ! store COM coords 
734:             do j2 = 1, nsiteperbody(j1) 
735:                j3 = rigidgroups(j2, j1) 
736:                comcoords(3*j3-2:3*j3) = com(1:3) 
737:             enddo 
738:          enddo 
739:       endif 
740:  
741:       ! real-space cutoff375:       ! real-space cutoff
742:       ewaldrealc2 = ewaldrealc**2376:       ewaldrealc2 = ewaldrealc**2
743: 377: 
744:       ! compute real-space contribution to gradient378:       ! compute real-space contribution to gradient
745:       ! 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))
746:       ! iterate over atoms i380:       ! iterate over atoms i
747:       do j1 = 1, natoms381:       do j1 = 1, natoms
748:          j3 = 3*j1382:          j3 = 3*j1
749:          q1 = stchrg(j1)383:          q1 = stchrg(j1)
750: 384: 
751:          ! iterate over atoms i > j385:          ! iterate over atoms i > j
752:          do j2 = j1+1, natoms386:          do j2 = j1+1, natoms
753:             j4 = 3*j2387:             j4 = 3*j2
754:             q2 = stchrg(j2)388:             q2 = stchrg(j2)
755: 389: 
756:             ! get distance between atoms390:             ! get distance between atoms
757:             rss(1) = x(j3-2)-x(j4-2)391:             rmin(1) = x(j3-2)-x(j4-2)
758:             rss(2) = x(j3-1)-x(j4-1)392:             rmin(2) = x(j3-1)-x(j4-1)
759:             rss(3) = x(j3)-x(j4) 393:             rmin(3) = x(j3)-x(j4)
760:             ! minimum image convention394:             ! minimum image convention
761:             rmin(1) = rss(1) - box_params(1)*anint(rss(1)/box_params(1))395:             rmin(1) = rmin(1)-boxlx*anint(rmin(1)/boxlx)
762:             rmin(2) = rss(2) - box_params(2)*anint(rss(2)/box_params(2))396:             rmin(2) = rmin(2)-boxly*anint(rmin(2)/boxly)
763:             rmin(3) = rss(3) - box_params(3)*anint(rss(3)/box_params(3))397:             rmin(3) = rmin(3)-boxlz*anint(rmin(3)/boxlz)
764:  
765:             ! get minimum distance between COM 
766:             ! NOTE: use rss for minimum image convention to ensure COM corresponds to right atoms 
767:             if (rigidinit.and.boxderivt) then 
768:                rcommin(1) = comcoords(j3-2)-comcoords(j4-2) - box_params(1)*anint(rss(1)/box_params(1)) 
769:                rcommin(2) = comcoords(j3-1)-comcoords(j4-1) - box_params(2)*anint(rss(2)/box_params(2)) 
770:                rcommin(3) = comcoords(j3)-comcoords(j4) - box_params(3)*anint(rss(3)/box_params(3)) 
771:             endif 
772: 398: 
773:             ! get gradient contribution per box399:             ! get gradient contribution per box
774:             f(:) = 0.0d0400:             f(:) = 0.0d0
775: 401: 
776:             ! iterate over boxes402:             ! iterate over boxes
777:             do l = -newaldreal(1), newaldreal(1)403:             do l = -newaldreal(1),newaldreal(1)
778:                r(1) = rmin(1)+box_params(1)*l404:                r(1) = rmin(1)+boxlx*l
779:                do m = -newaldreal(2), newaldreal(2)405:                do m = -newaldreal(2),newaldreal(2)
780:                   r(2) = rmin(2)+box_params(2)*m406:                   r(2) = rmin(2)+boxly*m
781:                   do n = -newaldreal(3), newaldreal(3)407:                   do n = -newaldreal(3),newaldreal(3)
782:                      r(3) = rmin(3)+box_params(3)*n408:                      r(3) = rmin(3)+boxlz*n
783:  
784:                      if (rigidinit.and.boxderivt) then 
785:                         rcom(1) = rcommin(1)+box_params(1)*l 
786:                         rcom(2) = rcommin(2)+box_params(2)*m 
787:                         rcom(3) = rcommin(3)+box_params(3)*n 
788:                      endif 
789:  
790:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2409:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2
791:                      if (dist2 < ewaldrealc2) then410:                      if (dist2 < ewaldrealc2) then
792:                         dist = dsqrt(dist2)411:                         dist = dsqrt(dist2)
793:                         ! calculate short-range gradient contribution per box412:                         ! calculate short-range gradient contribution per box
794:                         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))
795:                         f(1) = f(1) + mul*r(1)414:                         f(1) = f(1) + mul*r(1)
796:                         f(2) = f(2) + mul*r(2)415:                         f(2) = f(2) + mul*r(2)
797:                         f(3) = f(3) + mul*r(3)416:                         f(3) = f(3) + mul*r(3)
798: 417:                      endif
799:                         ! compute contribution to box derivatives418:                   enddo
800:                         if (boxderivt) then419:                enddo
801:                            if (rigidinit) then420:             enddo
802:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) - mul*r(1:3)*rcom(1:3)/box_params(1:3) 
803:                            else ! not rigid bodies 
804:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) - mul*r(1:3)*r(1:3)/box_params(1:3) 
805:                            endif  
806:                         endif  
807:  
808:                      endif ! within cutoff 
809:                   enddo ! n 
810:                enddo ! m 
811:             enddo ! l 
812: 421: 
813:             ! add gradient contribution422:             ! add gradient contribution
814:             g(j3-2) = g(j3-2)-f(1)423:             g(j3-2) = g(j3-2)-f(1)
815:             g(j3-1) = g(j3-1)-f(2)424:             g(j3-1) = g(j3-1)-f(2)
816:             g(j3)   = g(j3)-f(3)425:             g(j3)   = g(j3)-f(3)
817:             g(j4-2) = g(j4-2)+f(1)426:             g(j4-2) = g(j4-2)+f(1)
818:             g(j4-1) = g(j4-1)+f(2)427:             g(j4-1) = g(j4-1)+f(2)
819:             g(j4)   = g(j4)+f(3)428:             g(j4)   = g(j4)+f(3)
820:          enddo ! atoms j429:          enddo
821:       enddo ! atoms i430:       enddo
822: 431: 
823:       ! include contribution due to interaction of j1 with periodic images of itself432:       ! include contribution due to interaction of j1 with periodic images of itself
824:       ! (separated due to efficiency)433:       ! (separated due to efficiency)
825:       ! 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)))
826:       ! iterate over boxes435:       ! iterate over boxes
827:       do l = -newaldreal(1), newaldreal(1)436:       do l = -newaldreal(1),newaldreal(1)
828:          rmin(1) = box_params(1)*l437:          rmin(1) = boxlx*l
829:          do m = -newaldreal(2), newaldreal(2)438:          do m = -newaldreal(2),newaldreal(2)
830:             rmin(2) = box_params(2)*m439:             rmin(2) = boxly*m
831:             do n = -newaldreal(3), newaldreal(3)440:             do n = -newaldreal(3),newaldreal(3)
832:                rmin(3) = box_params(3)*n441:                rmin(3) = boxlz*n
833:                ! check not in central box442:                ! check not in central box
834:                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
835:                   dist2 = rmin(1)**2 + rmin(2)**2 + rmin(3)**2444:                   dist2 = rmin(1)**2 + rmin(2)**2 + rmin(3)**2
836:                   if (dist2 < ewaldrealc2) then445:                   if (dist2 < ewaldrealc2) then
837:                      dist = dsqrt(dist2)446:                      dist = dsqrt(dist2)
838: 447:                      mul = erfc(ewaldalpha*dist)/dist**2 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist**2)
839:                      if (rigidinit.and.boxderivt) then 
840:                         rcom(1) = box_params(1)*l 
841:                         rcom(2) = box_params(2)*m 
842:                         rcom(3) = box_params(3)*n 
843:                      endif 
844:  
845:                      mul = erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2) 
846:                      ! iterate over atoms and calculate gradient terms448:                      ! iterate over atoms and calculate gradient terms
847:                      do j1 = 1, natoms449:                      do j1 = 1, natoms
848:                         j3 = 3*j1450:                         j3 = 3*j1
849:                         q1 = stchrg(j1)451:                         q1 = stchrg(j1)
850:                         g(j3-2) = g(j3-2) - q1*q1*mul*rmin(1)452:                         g(j3-2) = g(j3-2) - q1*q1*mul*rmin(1)
851:                         g(j3-1) = g(j3-1) - q1*q1*mul*rmin(2)453:                         g(j3-1) = g(j3-1) - q1*q1*mul*rmin(2)
852:                         g(j3)   = g(j3)   - q1*q1*mul*rmin(3)454:                         g(j3)   = g(j3)   - q1*q1*mul*rmin(3)
853: 455:                      enddo
854:                         ! compute contribution to box derivatives456:                   endif
855:                         if (boxderivt) then457:                endif
856:                            if (rigidinit) then 
857:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) - q1*q1*mul*rmin(1:3)*rcom(1:3)/box_params(1:3) 
858:                            else ! not rigid bodies 
859:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) + q1*q1*mul*rmin(1:3)*rmin(1:3)/box_params(1:3) 
860:                            endif 
861:                         endif  
862:  
863:                      enddo ! atoms 
864:                   endif ! within cutoff 
865:                endif ! not in central box 
866:             enddo ! n 
867:          enddo ! m 
868:       enddo ! l 
869:  
870:       return 
871:       end subroutine coulombrealgrad_ortho 
872:  
873: ! ----------------------------------------------------------------------------------- 
874: ! Calculates the real-space contribution to the gradient with respects to atomic 
875: ! positions. Also calculates real-space contribution to the gradient wrt lattice 
876: ! vectors, if BOXDERIVT is true. 
877:  
878: ! Assumes triclinic unit cell. 
879: ! ----------------------------------------------------------------------------------- 
880:       subroutine coulombrealgrad_tri(x, newaldreal, g) 
881:  
882:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, & 
883:       &                   gr_weights, inversematrix 
884:       use cartdist, only: build_H 
885:  
886:       implicit none 
887:  
888:       integer                         :: j1, j3, j2, j4, l, m, n, idx 
889:       integer, intent(in)             :: newaldreal(3) 
890:       double precision, intent(in)    :: x(3*natoms) 
891:       double precision, intent(inout) :: g(3*natoms) 
892:       double precision                :: com(3), mass, comcoords(3*natoms) 
893:       double precision                :: rr(3), rrfrac(3), rrfracmin(3), r(3), f(3) 
894:       double precision                :: rcom(3), rcomfracmin(3), rcomfrac(3) 
895:       double precision                :: H(3,3), H_grad(3,3,6), H_inverse(3,3) 
896:       double precision                :: ewaldrealc2, q1, q2, mul, dist, dist2 
897:       double precision, parameter     :: pi = 3.141592654d0 
898:  
899:       ! if rigid bodies, calculate COM coordinates 
900:       ! to compute box derivatives 
901:       if (rigidinit.and.boxderivt) then 
902:          do j1 = 1, nrigidbody 
903:             ! calculate COM 
904:             com(:) = 0.0d0 
905:             mass = 0.0d0 
906:             do j2 = 1, nsiteperbody(j1) 
907:                j3 = rigidgroups(j2, j1) 
908:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3) 
909:                mass = mass + gr_weights(j3) 
910:             enddo 
911:             com(1:3) = com(1:3) / mass 
912:             ! store COM coords 
913:             do j2 = 1, nsiteperbody(j1) 
914:                j3 = rigidgroups(j2, j1) 
915:                comcoords(3*j3-2:3*j3) = com(1:3) 
916:             enddo458:             enddo
917:          enddo459:          enddo
918:       endif460:       enddo
919:  
920:       ! real-space cutoff 
921:       ewaldrealc2 = ewaldrealc**2 
922:  
923:       ! get H matrix and inverse 
924:       call build_H(H, H_grad, boxderivt) 
925:       call inversematrix(H, H_inverse) 
926:  
927:       ! compute real-space contribution to gradient 
928:       ! G_r = sum_L,i>j(-Qij*r*((erfc(alpha*rij)/(alpha*dist)**3) + 2*alpha*exp(-(alpha*rij)**2)/(sqrt(pi)*rij**2)) 
929:       ! iterate over atoms i 
930:       do j1 = 1, natoms 
931:          j3 = 3*j1 
932:          q1 = stchrg(j1) 
933:  
934:          ! iterate over atoms i > j 
935:          do j2 = j1+1, natoms 
936:             j4 = 3*j2 
937:             q2 = stchrg(j2) 
938:  
939:             ! get distance between atoms 
940:             rr(:) = x(j3-2:j3) - x(j4-2:j4) 
941:             ! convert to fractional coordinates 
942:             rrfrac(:) = matmul(H_inverse, rr(:)) 
943:             ! minimum image convention 
944:             rrfracmin(1) = rrfrac(1) - anint(rrfrac(1)) 
945:             rrfracmin(2) = rrfrac(2) - anint(rrfrac(2)) 
946:             rrfracmin(3) = rrfrac(3) - anint(rrfrac(3)) 
947:  
948:             ! get minimum distance between COM 
949:             if (rigidinit.and.boxderivt) then 
950:                rcom(:) = comcoords(j3-2:j3) - comcoords(j4-2:j4) 
951:                ! convert to fractional coords 
952:                rcomfracmin(:) = matmul(H_inverse, rcom(:)) 
953:                ! minimum image convention 
954:                ! NOTE: use rrfrac for minimum image convention to ensure COM corresponds to right atoms 
955:                rcomfracmin(1) = rcomfracmin(1) - anint(rrfrac(1)) 
956:                rcomfracmin(2) = rcomfracmin(2) - anint(rrfrac(2)) 
957:                rcomfracmin(3) = rcomfracmin(3) - anint(rrfrac(3)) 
958:             endif 
959:  
960:             ! get gradient contribution per box 
961:             f(:) = 0.0d0 
962:  
963:             ! iterate over boxes 
964:             do l = -newaldreal(1), newaldreal(1) 
965:                rrfrac(1) = rrfracmin(1) + l 
966:                do m = -newaldreal(2), newaldreal(2) 
967:                   rrfrac(2) = rrfracmin(2) + m 
968:                   do n = -newaldreal(3), newaldreal(3) 
969:                      rrfrac(3) = rrfracmin(3) + n 
970:  
971:                      ! convert to absolute coordinates 
972:                      r(:) = matmul(H, rrfrac(:)) 
973:  
974:                      if (rigidinit.and.boxderivt) then 
975:                         rcomfrac(1) = rcomfracmin(1) + l 
976:                         rcomfrac(2) = rcomfracmin(2) + m 
977:                         rcomfrac(3) = rcomfracmin(3) + n 
978:                      endif 
979:  
980:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2 
981:                      if (dist2 < ewaldrealc2) then 
982:                         dist = dsqrt(dist2) 
983:                         ! calculate short-range gradient contribution per box 
984:                         mul = q1*q2*(erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2)) 
985:                         f(1) = f(1) + mul*r(1) 
986:                         f(2) = f(2) + mul*r(2) 
987:                         f(3) = f(3) + mul*r(3) 
988:  
989:                         ! compute contribution to box derivatives 
990:                         if (boxderivt) then 
991:                            if (rigidinit) then 
992:                               ! iterate over cell parameters 
993:                               do idx = 1,6 
994:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx),rcomfrac)) 
995:                               enddo 
996:                            else ! not rigid bodies 
997:                               ! iterate over cell parameters 
998:                               do idx = 1, 6 
999:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx), rrfrac)) 
1000:                               enddo 
1001:                            endif  
1002:                         endif  
1003:  
1004:                      endif ! within cutoff 
1005:                   enddo ! n 
1006:                enddo ! m 
1007:             enddo ! l 
1008:  
1009:             ! add gradient contribution 
1010:             g(j3-2) = g(j3-2)-f(1) 
1011:             g(j3-1) = g(j3-1)-f(2) 
1012:             g(j3)   = g(j3)-f(3) 
1013:             g(j4-2) = g(j4-2)+f(1) 
1014:             g(j4-1) = g(j4-1)+f(2) 
1015:             g(j4)   = g(j4)+f(3) 
1016:          enddo ! atoms j 
1017:       enddo ! atoms i 
1018:  
1019:       ! include contribution due to interaction of j1 with periodic images of itself 
1020:       ! (separated due to efficiency) 
1021:       ! G_periodic-self = sum_L(Qi**2*rL*(erfc(alpha*rL)/rL**3 + 2*alpha*exp(-(alpha*rL)**2)/(sqrt(pi)*rL**2))) 
1022:       ! iterate over boxes 
1023:       do l = -newaldreal(1), newaldreal(1) 
1024:          rrfrac(1) = l 
1025:          do m = -newaldreal(2), newaldreal(2) 
1026:             rrfrac(2) = m 
1027:             do n = -newaldreal(3), newaldreal(3) 
1028:                rrfrac(3) = n 
1029:                ! check not in central box 
1030:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
1031:                   ! convert from fractional to absolute 
1032:                   r(:) = matmul(H, rrfrac(:)) 
1033:  
1034:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2 
1035:                   if (dist2 < ewaldrealc2) then 
1036:                      dist = dsqrt(dist2) 
1037:  
1038:                      if (rigidinit.and.boxderivt) then 
1039:                         rcomfrac(1) = l 
1040:                         rcomfrac(2) = m 
1041:                         rcomfrac(3) = n 
1042:                      endif 
1043:  
1044:                      mul = erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2) 
1045:                      ! iterate over atoms and calculate gradient terms 
1046:                      do j1 = 1, natoms 
1047:                         j3 = 3*j1 
1048:                         q1 = stchrg(j1) 
1049:                         g(j3-2) = g(j3-2) - q1*q1*mul*r(1) 
1050:                         g(j3-1) = g(j3-1) - q1*q1*mul*r(2) 
1051:                         g(j3)   = g(j3)   - q1*q1*mul*r(3) 
1052:  
1053:                         ! compute contribution to box derivatives 
1054:                         if (boxderivt) then 
1055:                            if (rigidinit) then 
1056:                               ! iterate over cell parameters 
1057:                               do idx = 1,6 
1058:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx),rcomfrac)) 
1059:                               enddo 
1060:                            else ! not rigid bodies 
1061:                               ! iterate over cell parameters 
1062:                               do idx = 1, 6 
1063:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx), rrfrac)) 
1064:                               enddo 
1065:                            endif 
1066:                         endif 
1067:  
1068:                      enddo ! atoms 
1069:                   endif ! within cutoff 
1070:                endif ! not in central box 
1071:             enddo ! n 
1072:          enddo ! m 
1073:       enddo ! l 
1074: 461: 
1075:       return462:       return
1076:       end subroutine coulombrealgrad_tri463:       endsubroutine
1077: 464: 
1078: ! -----------------------------------------------------------------------------------465: ! ---------------------------------------
1079: ! Calculates the reciprocal-space contribution to the gradient with respects to atomic466: ! dj337: Calculates the reipcrocal-space contribution to the gradient
1080: ! positions. Also calculates reciprocal-space contribution to the gradient wrt lattice467: ! of the Coulomb sum. Uses terms calculated by ftdensity subroutine
1081: ! vectors, if BOXDERIVT is true. Uses structure factors to simplify computation.468: ! to use structure factors to simplify computation.
1082: 469: !
1083: ! Assumes orthorhombic unit cell.470: ! Assumes orthogonal lattice vectors.
1084: ! -----------------------------------------------------------------------------------471: ! ---------------------------------------
1085:       subroutine coulombrecipgrad_ortho(x, newaldrecip, g)472:       subroutine coulombrecipgrad(x, g)
1086: 473: 
1087:       use commons, only: rerhoarray, imrhoarray474:       use commons
1088:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, gr_weights 
1089:       use cartdist, only: get_volume 
1090: 475: 
1091:       implicit none476:       implicit none
1092: 477: 
1093:       integer                         :: l, m, n, j1, j2, j3478:       integer                         :: l, m, n, j1, j3
1094:       integer, intent(in)             :: newaldrecip(3) 
1095:       double precision, intent(in)    :: x(3*natoms)479:       double precision, intent(in)    :: x(3*natoms)
1096:       double precision, intent(inout) :: g(3*natoms)480:       double precision, intent(inout) :: g(3*natoms)
1097:       double precision                :: vol, ewaldrecipc2, k(3), r(3)481:       double precision                :: k(3), r(3)
 482:       double precision                :: vol, ewaldrecipc2
1098:       double precision                :: k2, kdotr, rerho, imrho, q1, mul, mul2483:       double precision                :: k2, kdotr, rerho, imrho, q1, mul, mul2
1099:       double precision                :: com(3), mass, comcoords(3*natoms) 
1100:       double precision, parameter     :: pi = 3.141592654D0484:       double precision, parameter     :: pi = 3.141592654D0
1101: 485: 
1102:       ! cell volume486:       ! cell volume
1103:       call get_volume(vol)487:       call volume (vol)
1104:       ! reciprocal-space cutoff488:       ! reciprocal-space cutoff
1105:       ewaldrecipc2 = ewaldrecipc**2489:       ewaldrecipc2 = ewaldrecipc**2
1106: 490: 
1107:       ! if rigid bodies, compute COM coords 
1108:       ! to compute box derivatives 
1109:       if (rigidinit.and.boxderivt) then 
1110:          do j1 = 1, nrigidbody 
1111:             com(:) = 0.0d0 
1112:             mass = 0.0d0 
1113:             ! compute COM 
1114:             do j2 = 1, nsiteperbody(j1) 
1115:                j3 = rigidgroups(j2, j1) 
1116:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3) 
1117:                mass = mass + gr_weights(j3) 
1118:             enddo 
1119:             com(1:3) = com(1:3) / mass 
1120:             ! store COM coords 
1121:             do j2 = 1, nsiteperbody(j1) 
1122:                j3 = rigidgroups(j2, j1) 
1123:                comcoords(3*j3-2:3*j3) = com(1:3) 
1124:             enddo 
1125:          enddo 
1126:       endif 
1127:  
1128:       ! compute reciprocal-space gradient491:       ! compute reciprocal-space gradient
1129:       ! 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))))
1130:       ! iterate over boxes and calculate repciprocal lattice vectors493:       ! iterate over boxes and calculate repciprocal lattice vectors
1131:       do l = -newaldrecip(1), newaldrecip(1)494:       do l = -newaldrecip(1), newaldrecip(1)
1132:          k(1) = 2*pi*l/box_params(1)495:          k(1) = 2*pi*l/boxlx
1133:          do m = -newaldrecip(2), newaldrecip(2)496:          do m = -newaldrecip(2), newaldrecip(2)
1134:             k(2) = 2*pi*m/box_params(2)497:             k(2) = 2*pi*m/boxly
1135:             do n = -newaldrecip(3), newaldrecip(3)498:             do n = -newaldrecip(3), newaldrecip(3)
1136:                k(3) = 2*pi*n/box_params(3)499:                k(3) = 2*pi*n/boxlz
1137:                ! check not in central box500:                ! check not in central box
1138:                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
1139:                   k2 = k(1)**2 + k(2)**2 + k(3)**2502:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
1140:                   if (k2 < ewaldrecipc2) then503:                   if (k2 < ewaldrecipc2) then
1141:                      ! calculate multiplicative factor504:                      ! calculate multiplicative factor
1142:                      mul = -4.0d0*pi*dexp(-k2/(4.0d0*ewaldalpha**2))/(vol*k2)505:                      mul = -4*pi*dexp(-k2/(4.0d0*ewaldalpha**2))/(vol*k2)
1143:                      ! get structure factors 
1144:                      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)
1145:                      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)
1146:  
1147:                      ! add contribution to box derivatives 
1148:                      if (boxderivt) then 
1149:                         box_paramsgrad(1:3) = box_paramsgrad(1:3) + mul*(rerho**2+imrho**2)* & 
1150:                                               (1.0d0 - (k2 + 4.0d0*ewaldalpha**2)*k(1:3)*k(1:3)/ & 
1151:                                               (2.0d0*ewaldalpha**2*k2))/(2.0d0*box_params(1:3)) 
1152:                      endif 
1153:  
1154:                      ! iterate over atoms and calculate long-range gradient terms508:                      ! iterate over atoms and calculate long-range gradient terms
1155:                      do j1 = 1, natoms509:                      do j1 = 1,natoms
1156:                         j3 = 3*j1510:                         j3 = 3*j1
1157:                         r(:) = x(j3-2:j3)511:                         r(1) = x(j3-2)
 512:                         r(2) = x(j3-1)
 513:                         r(3) = x(j3)
1158:                         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)
1159:                         q1 = stchrg(j1)515:                         q1 = stchrg(j1)
1160:                         mul2 = mul*q1*(dsin(kdotr)*rerho - dcos(kdotr)*imrho)516:                         mul2 = mul*q1*(dsin(kdotr)*rerho - dcos(kdotr)*imrho)
1161:                          
1162:                         ! add contribution to gradient  
1163:                         g(j3-2) = g(j3-2) + mul2*k(1)517:                         g(j3-2) = g(j3-2) + mul2*k(1)
1164:                         g(j3-1) = g(j3-1) + mul2*k(2)518:                         g(j3-1) = g(j3-1) + mul2*k(2)
1165:                         g(j3)   = g(j3)   + mul2*k(3)519:                         g(j3)   = g(j3)   + mul2*k(3)
1166: 520:                      enddo
1167:                         ! add contribution to box derivatives from rigid bodies521:                   endif
1168:                         ! NOTE: no contribition if not using rigid bodies522:                endif
1169:                         if (rigidinit.and.boxderivt) then 
1170:                            box_paramsgrad(1:3) = box_paramsgrad(1:3) - mul2*k(1:3)*(x(j3-2:j3)-comcoords(j3-2:j3))/box_params(1:3) 
1171:                         endif 
1172:  
1173:                      enddo ! atoms 
1174:  
1175:                   endif ! within cutoff 
1176:                endif ! not in central box 
1177:             enddo ! n 
1178:          enddo ! m 
1179:       enddo ! l 
1180:  
1181:       return 
1182:       end subroutine coulombrecipgrad_ortho 
1183:  
1184: ! ----------------------------------------------------------------------------------- 
1185: ! Calculates the reciprocal-space contribution to the gradient with respects to atomic 
1186: ! positions. Also calculates reciprocal-space contribution to the gradient wrt lattice 
1187: ! vectors, if BOXDERIVT is true. Uses structure factors to simplify computation. 
1188:  
1189: ! Assumes triclinic unit cell. 
1190: ! ----------------------------------------------------------------------------------- 
1191:       subroutine coulombrecipgrad_tri(x, newaldrecip, g) 
1192:  
1193:       use commons, only: rerhoarray, imrhoarray 
1194:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, gr_weights, inversematrix 
1195:       use cartdist, only: get_volume, get_reciplatvec, build_H, cart2frac_tri 
1196:  
1197:       implicit none 
1198:  
1199:       integer                         :: l, m, n, j1, j2, j3, idx 
1200:       integer, intent(in)             :: newaldrecip(3) 
1201:       double precision, intent(in)    :: x(3*natoms) 
1202:       double precision, intent(inout) :: g(3*natoms) 
1203:       double precision                :: vol, ewaldrecipc2, c(3), s(3), abc, vfact, dvol(6), r(3) 
1204:       double precision                :: reciplatvec(3,3), reciplatvec_grad(3,3,6), xfrac(3*natoms) 
1205:       double precision                :: H(3,3), H_grad(3,3,6), H_inverse(3,3), k(3), k_grad(3,6) 
1206:       double precision                :: k2, kdotr, rerho, imrho, q1, mul, mul2 
1207:       double precision                :: com(3), mass, comcoords(3*natoms), comcoordsfrac(3*natoms) 
1208:       double precision, parameter     :: pi = 3.141592654D0 
1209:  
1210:       ! cell volume 
1211:       call get_volume(vol) 
1212:       ! gradient of volume wrt cell parameters 
1213:       if (boxderivt) then 
1214:          c(:) = dcos(box_params(4:6)) 
1215:          s(:) = dsin(box_params(4:6)) 
1216:          abc = box_params(1)*box_params(2)*box_params(3) 
1217:          vfact = vol/abc 
1218:          dvol(1) = vol/box_params(1) 
1219:          dvol(2) = vol/box_params(2) 
1220:          dvol(3) = vol/box_params(3) 
1221:          dvol(4) = s(1)*(c(1)-c(2)*c(3)) 
1222:          dvol(5) = s(2)*(c(2)-c(1)*c(3)) 
1223:          dvol(6) = s(3)*(c(3)-c(1)*c(2)) 
1224:          dvol(4:6) = abc*dvol(4:6)/vfact 
1225:       endif 
1226:  
1227:       ! reciprocal lattice vectors 
1228:       call get_reciplatvec(reciplatvec, reciplatvec_grad, boxderivt) 
1229:       ! get H matrix and inverse 
1230:       call build_H(H, H_grad, boxderivt) 
1231:       call inversematrix(H, H_inverse) 
1232:       ! get fractional coordinates 
1233:       if (boxderivt) call cart2frac_tri(x, xfrac, H_inverse) 
1234:       ! reciprocal-space cutoff 
1235:       ewaldrecipc2 = ewaldrecipc**2 
1236:  
1237:       ! if rigid bodies, compute COM coords 
1238:       ! to compute box derivatives 
1239:       if (rigidinit.and.boxderivt) then 
1240:          do j1 = 1, nrigidbody 
1241:             com(:) = 0.0d0 
1242:             mass = 0.0d0 
1243:             ! compute COM 
1244:             do j2 = 1, nsiteperbody(j1) 
1245:                j3 = rigidgroups(j2, j1) 
1246:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3) 
1247:                mass = mass + gr_weights(j3) 
1248:             enddo 
1249:             com(1:3) = com(1:3) / mass 
1250:             ! store COM coords 
1251:             do j2 = 1, nsiteperbody(j1) 
1252:                j3 = rigidgroups(j2, j1) 
1253:                comcoords(3*j3-2:3*j3) = com(1:3) 
1254:             enddo523:             enddo
1255:          enddo524:          enddo
1256:          ! convert to fractional525:       enddo
1257:          call cart2frac_tri(comcoords, comcoordsfrac, H_inverse) 
1258:       endif 
1259:  
1260:       ! compute reciprocal-space gradient 
1261:       ! 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)))) 
1262:       ! iterate over boxes and calculate repciprocal lattice vectors 
1263:       do l = -newaldrecip(1), newaldrecip(1) 
1264:          do m = -newaldrecip(2), newaldrecip(2) 
1265:             do n = -newaldrecip(3), newaldrecip(3) 
1266:                ! check not in central box 
1267:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then 
1268:                   k = l*reciplatvec(:,1) + m*reciplatvec(:,2) + n*reciplatvec(:,3) 
1269:                   k2 = k(1)**2 + k(2)**2 + k(3)**2 
1270:                   if (k2 < ewaldrecipc2) then 
1271:  
1272:                      ! get gradient of reciprocal lattice vector wrt cell parameters 
1273:                      if (boxderivt) then 
1274:                         do idx = 1,6 
1275:                            k_grad(:,idx) = l*reciplatvec_grad(:,1,idx) + m*reciplatvec_grad(:,2,idx) + n*reciplatvec_grad(:,3,idx) 
1276:                         enddo 
1277:                      endif 
1278:                       
1279:                      ! calculate multiplicative factor 
1280:                      mul = -4.0d0*pi*dexp(-k2/(4.0d0*ewaldalpha**2))/(vol*k2) 
1281:                      ! get structure factors 
1282:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) 
1283:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) 
1284:  
1285:                      ! add contribution to box derivatives 
1286:                      if (boxderivt) then 
1287:                         ! iterate over cell parameters 
1288:                         do idx = 1, 6 
1289:                             box_paramsgrad(idx) = box_paramsgrad(idx) + & 
1290:                                                   mul*(rerho**2+imrho**2)*(dvol(idx)/(2.0d0*vol) + & 
1291:                                                   (k2 + 4.0d0*ewaldalpha**2)*dot_product(k, k_grad(:,idx))/ & 
1292:                                                   (4.0d0*ewaldalpha**2*k2)) 
1293:                         enddo 
1294:                      endif 
1295:  
1296:                      ! iterate over atoms and calculate long-range gradient terms 
1297:                      do j1 = 1, natoms 
1298:                         j3 = 3*j1 
1299:                         r(:) = x(j3-2:j3) 
1300:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3) 
1301:                         q1 = stchrg(j1) 
1302:                         mul2 = mul*q1*(dsin(kdotr)*rerho - dcos(kdotr)*imrho) 
1303:                          
1304:                         ! add contribution to gradient  
1305:                         g(j3-2) = g(j3-2) + mul2*k(1) 
1306:                         g(j3-1) = g(j3-1) + mul2*k(2) 
1307:                         g(j3)   = g(j3)   + mul2*k(3) 
1308:  
1309:                         ! add contribution to box derivatives 
1310:                         if (boxderivt) then 
1311:                            if (rigidinit) then 
1312:                               ! iterate over cell parameters 
1313:                               do idx = 1,6 
1314:                                  box_paramsgrad(idx) = box_paramsgrad(idx) + & 
1315:                                                        mul2*(dot_product(k_grad(:,idx), r) + & 
1316:                                                        dot_product(k, matmul(H_grad(:,:,idx), comcoordsfrac(j3-2:j3)))) 
1317:                               enddo 
1318:                            else ! not rigid bodies 
1319:                               ! iterate over cell parameters 
1320:                               do idx = 1,6 
1321:                                  box_paramsgrad(idx) = box_paramsgrad(idx) + & 
1322:                                                        mul2*(dot_product(k_grad(:,idx), r) + & 
1323:                                                        dot_product(k, matmul(H_grad(:,:,idx), xfrac(j3-2:j3)))) 
1324:                               enddo 
1325:                            endif 
1326:                         endif 
1327:  
1328:                      enddo ! atoms 
1329:  
1330:                   endif ! within cutoff 
1331:                endif ! not in central box 
1332:             enddo ! n 
1333:          enddo ! m 
1334:       enddo ! l 
1335: 526: 
1336:       return527:       return
1337:       end subroutine coulombrecipgrad_tri528:       end subroutine
1338: 529: 
1339: end module530: end module


r33129/finalio.f90 2017-08-07 15:30:43.377427999 +0100 r33128/finalio.f90 2017-08-07 15:30:50.101517448 +0100
 16: !   along with this program; if not, write to the Free Software 16: !   along with this program; if not, write to the Free Software
 17: !   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA 17: !   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 18: ! 18: !
 19: SUBROUTINE FINALIO 19: SUBROUTINE FINALIO
 20:   USE COMMONS 20:   USE COMMONS
 21:   USE GENRIGID, ONLY : RIGIDINIT, NRIGIDBODY, NSITEPERBODY 21:   USE GENRIGID, ONLY : RIGIDINIT, NRIGIDBODY, NSITEPERBODY
 22:   USE MODAMBER 22:   USE MODAMBER
 23:   USE MODAMBER9, ONLY : COORDS1,IH,M04,AMBFINALIO_NODE 23:   USE MODAMBER9, ONLY : COORDS1,IH,M04,AMBFINALIO_NODE
 24:   USE AMBER12_INTERFACE_MOD, ONLY : AMBER12_FINISH, AMBER12_WRITE_RESTART, AMBER12_WRITE_PDB, & 24:   USE AMBER12_INTERFACE_MOD, ONLY : AMBER12_FINISH, AMBER12_WRITE_RESTART, AMBER12_WRITE_PDB, &
 25:        AMBER12_WRITE_XYZ 25:        AMBER12_WRITE_XYZ
  26:   USE AMBER12_MUTATIONS, ONLY : FINISH_AMBERMUT
 26:   USE OPEP_INTERFACE_MOD, ONLY: OPEP_FINISH, OPEP_WRITE_PDB 27:   USE OPEP_INTERFACE_MOD, ONLY: OPEP_FINISH, OPEP_WRITE_PDB
 27:   USE QMODULE 28:   USE QMODULE
 28:   USE MODCHARMM 29:   USE MODCHARMM
 29:   USE AMHGLOBALS, ONLY:NMRES,IRES 30:   USE AMHGLOBALS, ONLY:NMRES,IRES
 30:   USE BGUPMOD 31:   USE BGUPMOD
 31:   USE PERMU 32:   USE PERMU
 32:   USE MODHESS, ONLY : HESS, MASSWT 33:   USE MODHESS, ONLY : HESS, MASSWT
 33:   USE CONVEX_POLYHEDRA_MODULE, ONLY: VIEW_POLYHEDRA 34:   USE CONVEX_POLYHEDRA_MODULE, ONLY: VIEW_POLYHEDRA
 34:   USE LJ_GAUSS_MOD, ONLY: VIEW_LJ_GAUSS 35:   USE LJ_GAUSS_MOD, ONLY: VIEW_LJ_GAUSS
  36:   USE OPP_MOD, ONLY: VIEW_OPP
  37:   USE ORBITALS_MOD, ONLY: ORBITALS_FINISH
 35:  38: 
 36:   IMPLICIT NONE 39:   IMPLICIT NONE
 37:  40: 
 38:   !   MCP 41:&nbs