hdiff output

r33135/amber_mutations.F90 2017-08-07 17:30:33.177086746 +0100 r33134/amber_mutations.F90 2017-08-07 17:30:44.001230509 +0100
  1: !Subroutines to set up and use mutations as moves in a general BH run  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/GMIN/source/amber_mutations.F90' in revision 33134
  2: MODULE AMBER12_MUTATIONS 
  3:   USE COMMONS 
  4:   USE PORFUNCS 
  5:   USE CHIRALITY, ONLY: DEALLOC_STATES_MUTATION 
  6:   USE AMBER12_INTERFACE_MOD 
  7:   USE QMODULE 
  8:   IMPLICIT NONE 
  9:  
 10:  
 11: !****************************************************************************** 
 12: ! Types to represent mutation information. 
 13:   TYPE RESIDUE_MUTATION 
 14:      INTEGER                           :: RESNUM          !residue number 
 15:      INTEGER                           :: NMUTATIONS      !number of mutations so far 
 16:      INTEGER                           :: NENTRIES        !number of possible residues 
 17:      CHARACTER(LEN=4)                  :: CURRENT_RES     !current residue 
 18:      CHARACTER(LEN=4) , DIMENSION(:) , ALLOCATABLE :: RESCHOICE       !residues to choose for mutations 
 19:      DOUBLE PRECISION , DIMENSION(:) , ALLOCATABLE :: PROBABILITIES   !selection probability for selection 
 20:   END TYPE RESIDUE_MUTATION 
 21:  
 22:   CHARACTER(LEN=4), ALLOCATABLE , SAVE :: AMBER12_RESNAME(:) 
 23:   INTEGER , SAVE :: NRESIDUES , NRESMUT , MUNIT 
 24:   INTEGER , ALLOCATABLE , SAVE :: TERMINI_RES(:), AMBER12_RESSTART(:), AMBER12_RESEND(:), AMBER12_RESNATOM(:) 
 25:   TYPE(RESIDUE_MUTATION) , DIMENSION(:) , ALLOCATABLE ,SAVE :: MUTATION_INFO , PREVIOUS_MUTATION 
 26:  
 27:   CONTAINS 
 28:   !setup mutational system, initialise coordinates correctly, and according to the right size 
 29:   SUBROUTINE AMBERMUTATION_SETUP()   
 30:      IMPLICIT NONE 
 31:      INTEGER :: MIUNIT,GETUNIT,J1,J2,NENTRIES,NTERMINI,TESTINT 
 32:      LOGICAL :: YESNO , NTERT 
 33:      CHARACTER(200) ENTRY_ 
 34:      CHARACTER(25) , DIMENSION(:) , ALLOCATABLE :: ENTRIES 
 35:  
 36:      !check there is a file contianing the mutational information 
 37:      YESNO = .FALSE. 
 38:      INQUIRE(FILE='amber_mutations',EXIST=YESNO) 
 39:      IF (.NOT.YESNO) THEN 
 40:         WRITE(MYUNIT,'(A)') ' ambermut> No mutation information given' 
 41:         STOP 
 42:      ENDIF 
 43:      !get the number of residues, and their atom positions 
 44:      CALL TOPOLOGY_READER() 
 45:      !open the mutation information 
 46:      MIUNIT = GETUNIT() 
 47:      OPEN(UNIT=MIUNIT,FILE='amber_mutations',status='unknown') 
 48:      WRITE(MYUNIT,*) 'ambermut> Reading in mutations allowed' 
 49:      READ(MIUNIT,*) NRESMUT 
 50:      WRITE(MYUNIT,*) 'ambermut> ',NRESIDUES,' residues, of which ',NRESMUT,'can be mutated' 
 51:      !all allocations and reallocations are taken care of here, as we will not chnage the number of residues 
 52:      ALLOCATE(TERMINI_RES(NRESIDUES)) 
 53:      IF (ALLOCATED(MUTATION_INFO)) DEALLOCATE(MUTATION_INFO) 
 54:      ALLOCATE(MUTATION_INFO(NRESMUT)) 
 55:      IF (ALLOCATED(PREVIOUS_MUTATION)) DEALLOCATE(PREVIOUS_MUTATION) 
 56:      ALLOCATE(PREVIOUS_MUTATION(NRESMUT)) 
 57:      IF (ALLOCATED(TERMINI_RES)) DEALLOCATE(TERMINI_RES) 
 58:      ALLOCATE(TERMINI_RES(NRESIDUES)) 
 59:      TERMINI_RES(:) = 0 
 60:      !read next line, this contains the terminal residues 
 61:      READ(MIUNIT,*) NTERMINI 
 62:      READ(MIUNIT,'(A)',END=101) ENTRY_               !read line 
 63:      ALLOCATE(ENTRIES(NTERMINI)) 
 64:      ENTRIES(:)='' 
 65:      CALL READ_LINE(ENTRY_,NTERMINI,ENTRIES) 
 66:      !entries now contains the information about the termini, we need to differentiate between C and N termini 
 67:      !the first entry ought to be the N terminus and then we switch between then, this might cause problems for ACE, NME, NHE!!! 
 68:      NTERT = .TRUE. 
 69:      DO J1=1,NRESIDUES 
 70:         DO J2=1,NTERMINI 
 71:            READ(ENTRIES(J2),'(I8)') TESTINT 
 72:            IF (TESTINT.EQ.J1) THEN 
 73:               IF (NTERT) THEN 
 74:                  TERMINI_RES(J1)=1 
 75:                  NTERT = .FALSE. 
 76:               ELSE 
 77:                  TERMINI_RES(J1)=2 
 78:                  NTERT = .TRUE. 
 79:               ENDIF 
 80:            ENDIF 
 81:         ENDDO 
 82:      ENDDO 
 83:      !now we get to actual mutation information 
 84:      !line 1: RESNUM NENTRIES CURRENT_RES 
 85:      !line 2: RESNAME1 RESNAME2 RESNAME3 ... 
 86:      !line 3: PROB1 PROB2 PROB3 ... 
 87:      ! we can give the probabilities as any series of numbers, they are normalised later, as we need to discount the residue that we currently have 
 88:      !i.e. if we try to mutate we will mutate, and then check after some more group rotation steps in mc.F whether the energy is lower or not  
 89:      DO J1=1,NRESMUT 
 90:         READ(MIUNIT,'(A)',END=101) ENTRY_               !read line 
 91:         !reallocate the length of the entries list 
 92:         DEALLOCATE(ENTRIES) 
 93:         ALLOCATE(ENTRIES(3)) 
 94:         ENTRIES(:)='' 
 95:         CALL READ_LINE(ENTRY_,3,ENTRIES) 
 96:         READ(ENTRIES(1),'(I8)') MUTATION_INFO(J1)%RESNUM 
 97:         READ(ENTRIES(2),'(I8)') MUTATION_INFO(J1)%NENTRIES 
 98:         READ(ENTRIES(3),'(A)') MUTATION_INFO(J1)%CURRENT_RES 
 99:         MUTATION_INFO(J1)%NMUTATIONS = 0 
100:         NENTRIES=MUTATION_INFO(J1)%NENTRIES 
101:         ALLOCATE(MUTATION_INFO(J1)%RESCHOICE(NENTRIES)) 
102:         ALLOCATE(MUTATION_INFO(J1)%PROBABILITIES(NENTRIES)) 
103:         ALLOCATE(PREVIOUS_MUTATION(J1)%RESCHOICE(NENTRIES)) 
104:         ALLOCATE(PREVIOUS_MUTATION(J1)%PROBABILITIES(NENTRIES)) 
105:         !reallocate the length of the entries list 
106:         READ(MIUNIT,'(A)',END=101) ENTRY_ 
107:         DEALLOCATE(ENTRIES) 
108:         ALLOCATE(ENTRIES(MUTATION_INFO(J1)%NENTRIES)) 
109:         ENTRIES(:)='' 
110:         CALL READ_LINE(ENTRY_,MUTATION_INFO(J1)%NENTRIES,ENTRIES) 
111:         DO J2=1,MUTATION_INFO(J1)%NENTRIES 
112:            MUTATION_INFO(J1)%RESCHOICE(J2)=ENTRIES(J2) 
113:         ENDDO 
114:         READ(MIUNIT,'(A)',END=101) ENTRY_ 
115:         ENTRIES(:)='' 
116:         CALL READ_LINE(ENTRY_,MUTATION_INFO(J1)%NENTRIES,ENTRIES) 
117:         DO J2=1,MUTATION_INFO(J1)%NENTRIES 
118:            READ(ENTRIES(J2),*) MUTATION_INFO(J1)%PROBABILITIES(J2) 
119:         ENDDO 
120:      ENDDO 
121: 101  CONTINUE 
122:      CLOSE(MIUNIT) 
123:      !call the grouprotation set up here (not in keywords) 
124:      CALL MUT_SETUP_GROUPROTATION(1,.FALSE.,.FALSE.,0)          
125:      RETURN 
126:   END SUBROUTINE AMBERMUTATION_SETUP 
127:    
128:   !mutate protein 
129:   SUBROUTINE AMBERMUT_STEP(COORDINATES , RESNUMBER) 
130:      INTEGER , INTENT(OUT) :: RESNUMBER 
131:      CHARACTER(LEN=4) :: OLDRES , OLDRES1 , NEWRES , NEWRES1 
132:      CHARACTER(LEN=6) :: NMUT_STRING , STARTINDEX_STRING 
133:      CHARACTER(LEN=25) :: OPTION_STRING 
134:      DOUBLE PRECISION :: COORDINATES(3*NATOMS) 
135:   
136:      !let's store all information first in case we have to go back! 
137:      PREVIOUS_MUTATION = MUTATION_INFO 
138:      !we have a new mutation 
139:      NMUTATION = NMUTATION + 1 
140:      WRITE(NMUT_STRING,'(I6)') NMUTATION - 1  
141:      !before we do anything, we save the old lowest minima 
142:      CALL AMBERMUT_CURR_LOWEST() 
143:      !select a residue to mutate 
144:      CALL SELECT_MUTATION(RESNUMBER , OLDRES1 , NEWRES1) 
145:      !if it is a terminal residue, we need to go for a different set of atoms and coordinates in the coordinate creation script 
146:      IF (TERMINI_RES(RESNUMBER).EQ.1) THEN 
147:         OLDRES = "C" // OLDRES1 
148:         NEWRES = "C" // NEWRES1 
149:      ELSE IF (TERMINI_RES(RESNUMBER).EQ.2) THEN 
150:         OLDRES = "N" // OLDRES1 
151:         NEWRES = "N" // NEWRES1 
152:      ELSE 
153:         OLDRES = OLDRES1 
154:         NEWRES = NEWRES1 
155:      ENDIF                 
156:      WRITE(MUTUNIT,'(A,I6,4A)') 'Mutate residue ' , RESNUMBER , ' from ' , OLDRES , ' to ' , NEWRES 
157:      WRITE(STARTINDEX_STRING,'(I6)') AMBER12_RESSTART(RESNUMBER) 
158:  
159:      !dump the coordinates for the old residue, and move things to safety 
160:      CALL DUMP_RESIDUE_COORDS(RESNUMBER , COORDINATES) 
161:      CALL SYSTEM('mv coords.prmtop coords.prmtop.'//TRIM(ADJUSTL(NMUT_STRING))) 
162:      CALL SYSTEM('mv coords.inpcrd coords.inpcrd.'//TRIM(ADJUSTL(NMUT_STRING))) 
163:      CALL SYSTEM('mv start start.'//TRIM(ADJUSTL(NMUT_STRING))) 
164:      CALL SYSTEM('mv atomgroups atomgroups.'//TRIM(ADJUSTL(NMUT_STRING))) 
165:      !create mutated coordinates and a new perm.allow file 
166:      OPTION_STRING=OLDRES//' '//NEWRES//' '//STARTINDEX_STRING 
167: #ifdef _SVN_ROOT_ 
168:      CALL SYSTEM('python '//_SVN_ROOT_//'/SCRIPTS/AMBER/BHmutation_steps/mutate_aa.py '//OLDRES//' '//NEWRES) 
169:      CALL SYSTEM('python '//_SVN_ROOT_//'/SCRIPTS/AMBER/BHmutation_steps/perm_allow.py '//OPTION_STRING) 
170: #else 
171:      CALL SYSTEM('python ' // mutation_script // OLDRES // ' ' // NEWRES ) 
172:      CALL SYSTEM('python ' // perm_allow_script //OPTION_STRING) 
173: #endif 
174:      CALL SYSTEM('mv perm.allow perm.allow.'//TRIM(ADJUSTL(NMUT_STRING))) 
175:      CALL SYSTEM('mv perm.allow.new perm.allow') 
176:      !create a new topology, update the residue information and adjust coordinates for unchanged residues 
177:      CALL CREATE_NEW_TOPOLOGY(RESNUMBER ,  NEWRES , COORDS) 
178:      !create new atom groups 
179: #ifdef _SVN_ROOT_ 
180:      CALL SYSTEM('python ' // _SVN_ROOT_ // '/SCRIPTS/AMBER/BHmutation_steps/grouprotations.py tmp.pdb') 
181: #else 
182:      CALL SYSTEM('python ' // grouprotation_script // ' tmp.pdb') 
183: #endif 
184:      CALL SYSTEM('rm tmp.pdb') 
185:      !finally reinitialise AMBER with new groups, coordinates and topology 
186:      CALL REINITIALISE_AMBER() 
187:      !now remove old chiral states used for checking (the rest is done when we initialise the chirality in mc.F) 
188:      CALL DEALLOC_STATES_MUTATION() 
189:      RETURN 
190:   END SUBROUTINE AMBERMUT_STEP 
191:  
192:   SUBROUTINE SELECT_MUTATION(RESNUMBER , OLDRES , NEWRES) 
193:      INTEGER , INTENT(OUT) :: RESNUMBER 
194:      CHARACTER(LEN=4) , INTENT(OUT) :: OLDRES , NEWRES  
195:      CHARACTER(LEN=4) :: SELECTED_MUT 
196:      INTEGER :: ENTRIES , NCURR , J1 , SELECTED_ID , SELECTED_RES 
197:      DOUBLE PRECISION :: PROB_RES_SELECT(NRESMUT,2) , NMUTATED , PROB , PROBTOT , RANDOM, DPRAND 
198:      DOUBLE PRECISION , ALLOCATABLE :: PROB_MUT_SELECT(:,:) 
199:      !create probability array to select residue id 
200:      NMUTATED = 0.0 
201:      DO J1 = 1,NRESMUT 
202:         !We take the number of previous mutations plus 1 (otherwise we are at zeros to start with ...) 
203:         NMUTATED = NMUTATED + 1.0/((MUTATION_INFO(J1)%NMUTATIONS) + 1) 
204:      ENDDO 
205:      DO J1 = 1,NRESMUT 
206:         PROB = 1.0/(NMUTATED * ((MUTATION_INFO(J1)%NMUTATIONS) + 1)) 
207:         IF (J1.EQ.1) THEN 
208:            !for the first choice we go from zero to prob 
209:            PROB_RES_SELECT(J1,1) = 0.0 
210:            PROB_RES_SELECT(J1,2) = PROB 
211:         ELSE IF (J1.LT.NRESMUT) THEN 
212:            !then we go in intervalls 
213:            PROB_RES_SELECT(J1,1) = PROB_RES_SELECT((J1-1),2) 
214:            PROB_RES_SELECT(J1,2) = PROB_RES_SELECT(J1,1) + PROB 
215:         ELSE 
216:            !finally making sure the array stretches to 1.0 
217:            PROB_RES_SELECT(J1,1) = PROB_RES_SELECT((J1-1),2) 
218:            PROB_RES_SELECT(J1,2) = 1.0 
219:         ENDIF 
220:      ENDDO 
221:      !select residue 
222:      RANDOM=DPRAND() 
223:      DO J1 = 1,NRESMUT 
224:         IF ((PROB_RES_SELECT(J1,1).LT.RANDOM).AND.(RANDOM.LE.PROB_RES_SELECT(J1,2))) THEN 
225:            SELECTED_RES = MUTATION_INFO(J1) % RESNUM 
226:            SELECTED_ID = J1 
227:            WRITE(MYUNIT,'(A,I6)') ' ambermut> Selected residue for mutation: ' , SELECTED_RES 
228:            GOTO 20 
229:         ENDIF 
230:      ENDDO 
231:      !independent of whether we accept or reject the mutation attempt later, we store that it has occured 
232: 20   CONTINUE 
233:      MUTATION_INFO(J1)%NMUTATIONS = (MUTATION_INFO(J1)%NMUTATIONS)+1 
234:      PREVIOUS_MUTATION(J1)%NMUTATIONS = (PREVIOUS_MUTATION(J1)%NMUTATIONS)+1  
235:  
236:      !create normalisation for probabilities, same procedure as for the residue 
237:      ENTRIES = MUTATION_INFO(SELECTED_ID)%NENTRIES 
238:      IF (ALLOCATED(PROB_MUT_SELECT)) DEALLOCATE(PROB_MUT_SELECT) 
239:      ALLOCATE(PROB_MUT_SELECT(ENTRIES,2)) 
240:      PROB_MUT_SELECT(:,:) = 0.0D0 
241:      PROBTOT = 0.0 
242:      DO J1 = 1,ENTRIES 
243:         IF (.NOT.((MUTATION_INFO(SELECTED_ID)%CURRENT_RES).EQ.(MUTATION_INFO(SELECTED_ID)%RESCHOICE(J1)))) THEN 
244:            PROBTOT = PROBTOT + MUTATION_INFO(SELECTED_ID)%PROBABILITIES(J1) 
245:         ELSE 
246:            NCURR = J1 
247:         ENDIF 
248:      ENDDO 
249:      !create probabilities (making sure we actually mutate) 
250:      DO J1 = 1,ENTRIES 
251:         PROB = (MUTATION_INFO(SELECTED_ID)%PROBABILITIES(J1))/PROBTOT 
252:         IF (J1.EQ.1) THEN 
253:            PROB_MUT_SELECT(J1,1) = 0.0 
254:            IF (J1.EQ.NCURR) THEN 
255:               PROB_MUT_SELECT(J1,2) = 0.0 
256:            ELSE 
257:               PROB_MUT_SELECT(J1,2) = PROB 
258:            ENDIF 
259:         ELSE IF (J1.LT.ENTRIES) THEN 
260:            PROB_MUT_SELECT(J1,1) = PROB_MUT_SELECT((J1-1),2) 
261:            IF (J1.EQ.NCURR) THEN 
262:               PROB_MUT_SELECT(J1,2) = PROB_MUT_SELECT(J1,1) 
263:            ELSE 
264:               PROB_MUT_SELECT(J1,2) = PROB_MUT_SELECT(J1,1) + PROB 
265:            ENDIF 
266:         ELSE 
267:            IF (J1.EQ.NCURR) THEN 
268:               PROB_MUT_SELECT(J1,1) = 1.0 
269:               PROB_MUT_SELECT(J1-1,2) = 1.0 
270:            ELSE 
271:               PROB_MUT_SELECT(J1,1) = PROB_MUT_SELECT(J1-1,2) 
272:            ENDIF 
273:            PROB_MUT_SELECT(J1,2) = 1.0 
274:         ENDIF 
275:      ENDDO 
276:      PROB_MUT_SELECT(NCURR,1) = -1.0 
277:      PROB_MUT_SELECT(NCURR,2) = -1.0 
278:      !select mutation 
279:      RANDOM=DPRAND() 
280:      DO J1 = 1,ENTRIES 
281:      IF ((PROB_MUT_SELECT(J1,1).LT.RANDOM).AND.(RANDOM.LE.PROB_MUT_SELECT(J1,2))) THEN 
282:            SELECTED_MUT = MUTATION_INFO(SELECTED_ID)%RESCHOICE(J1) 
283:            WRITE(MYUNIT,'(A,A)') ' ambermut> Mutate to: ' , SELECTED_MUT 
284:            GOTO 30 
285:         ENDIF 
286:      ENDDO        
287: 30   CONTINUE 
288:      !assign everything to our intent out variables 
289:      RESNUMBER = SELECTED_RES 
290:      OLDRES = MUTATION_INFO(SELECTED_ID)%CURRENT_RES 
291:      NEWRES = SELECTED_MUT   
292:      MUTATION_INFO(SELECTED_ID)%CURRENT_RES =  NEWRES 
293:   END SUBROUTINE SELECT_MUTATION 
294:  
295:   SUBROUTINE DUMP_RESIDUE_COORDS(RESNUMBER , COORD) 
296:      INTEGER , INTENT(IN) :: RESNUMBER 
297:      DOUBLE PRECISION , INTENT(IN) :: COORD(3*NATOMS) 
298:      INTEGER :: STARTATOM , NRESATOM , CUNIT , GETUNIT , J1 
299:       
300:      !simply dump the coordinates of the residue we want to mutate 
301:      STARTATOM = AMBER12_RESSTART(RESNUMBER) 
302:      NRESATOM = AMBER12_RESNATOM(RESNUMBER) 
303:      CUNIT = GETUNIT() 
304:      OPEN(UNIT=CUNIT , FILE='coords.oldres' , STATUS='NEW') 
305:      DO J1 = 1,NRESATOM 
306:         WRITE(CUNIT,'(3F20.10)') COORD(3*(STARTATOM+J1-1)-2),COORD(3*(STARTATOM+J1-1)-1),COORD(3*(STARTATOM+J1-1)) 
307:      ENDDO 
308:      CLOSE(CUNIT) 
309:   END SUBROUTINE DUMP_RESIDUE_COORDS 
310:  
311:   SUBROUTINE CREATE_NEW_TOPOLOGY(RESNUMBER , NEWRES , COORDS_OLD) 
312:      INTEGER , INTENT(IN) :: RESNUMBER 
313:      CHARACTER(LEN=4) , INTENT(IN) :: NEWRES 
314:      DOUBLE PRECISION , INTENT(IN) :: COORDS_OLD(3*NATOMS) 
315:      DOUBLE PRECISION , ALLOCATABLE :: COORDS_NEW(:) , COORDS_NEWRES(:,:) 
316:      DOUBLE PRECISION , ALLOCATABLE :: COORDS_RES(:) 
317:      INTEGER :: J1 , TUNIT , CUNIT , CUNIT2 , GETUNIT , STARTATOM , FINALATOM_OLD , FINALATOM_NEW , SHIFT  
318:      CHARACTER(LEN=4) :: RESNAMES(NRESIDUES) 
319:  
320:      TUNIT = GETUNIT() 
321:      DO J1=1,NRESIDUES 
322:         RESNAMES(J1) = AMBER12_RESNAME(J1) 
323:      ENDDO 
324:      !create a leap.in file 
325:      OPEN(TUNIT , FILE='leap.in' , STATUS='NEW') 
326:      !currently we either go for ff14SB or ff99SB 
327:      IF (AMBERMUTFF.EQ.14) THEN 
328:         WRITE(TUNIT,'(A)') 'source leaprc.ff14SB' 
329:      ELSE IF (AMBERMUTFF.EQ.99) THEN 
330:         WRITE(TUNIT,'(A)') 'source oldff/leaprc.ff99SB' 
331:      ENDIF 
332:      !make sure we use the correct adjustment of radii for the solvent model used 
333:      IF (AMBERMUTIGB.EQ.2) THEN 
334:         WRITE(TUNIT,'(A)') 'set default PBradii mbondi2' 
335:      ELSE IF (AMBERMUTIGB.EQ.8) THEN 
336:         WRITE(TUNIT,'(A)') 'set default PBradii mbondi3' 
337:      ENDIF 
338:      !write the sequence including the correct termini (all stored residues have len=3, but the newres is already adjusted to len=4!) 
339:      WRITE(TUNIT,'(A)',ADVANCE='NO') 'mol = sequence {' 
340:      DO J1=1,NRESIDUES 
341:         IF (J1.EQ.RESNUMBER) THEN 
342:            WRITE(TUNIT,'(A)',ADVANCE='NO') NEWRES // " " 
343:         ELSE IF (TERMINI_RES(J1).EQ.2) THEN 
344:            WRITE(TUNIT,'(A)',ADVANCE='NO') "C" // RESNAMES(J1) 
345:         ELSE IF (TERMINI_RES(J1).EQ.1) THEN 
346:            WRITE(TUNIT,'(A)',ADVANCE='NO') "N" // RESNAMES(J1) 
347:         ELSE 
348:            WRITE(TUNIT,'(A)',ADVANCE='NO') RESNAMES(J1) 
349:         ENDIF  
350:      ENDDO 
351:      WRITE(TUNIT,'(A)') '}' 
352:      WRITE(TUNIT,'(A)') 'saveamberparm mol coords.prmtop tmp.inpcrd' 
353:      WRITE(TUNIT,'(A)') 'savepdb mol tmp.pdb' 
354:      WRITE(TUNIT,'(A)') 'quit' 
355:      CLOSE(TUNIT) 
356:      !finished creating leap input, now run leap and get the right coordinates      
357:      CALL SYSTEM('tleap -f leap.in >> output') 
358:      !save the old information 
359:      STARTATOM = AMBER12_RESSTART(RESNUMBER) 
360:      FINALATOM_OLD = AMBER12_RESEND(RESNUMBER) 
361:      CALL TOPOLOGY_READER() 
362:      !get the changed number of atoms 
363:      FINALATOM_NEW = AMBER12_RESEND(RESNUMBER) 
364:      SHIFT = FINALATOM_NEW - FINALATOM_OLD 
365:      !correct wrong information (we havent reinitialised yet, so NATOMS is still wrong) 
366:      AMBER12_RESEND(NRESIDUES) = AMBER12_RESEND(NRESIDUES) + SHIFT 
367:      AMBER12_RESNATOM(NRESIDUES) = AMBER12_RESNATOM(NRESIDUES) + SHIFT 
368:      !create final input files needed 
369:      IF (ALLOCATED(COORDS_NEW)) DEALLOCATE(COORDS_NEW) 
370:      ALLOCATE(COORDS_NEW(3*(NATOMS+SHIFT))) 
371:      IF (ALLOCATED(COORDS_NEWRES)) DEALLOCATE(COORDS_NEWRES) 
372:      ALLOCATE(COORDS_NEWRES(AMBER12_RESNATOM(RESNUMBER),3)) 
373:      IF (ALLOCATED(COORDS_RES)) DEALLOCATE(COORDS_RES) 
374:      ALLOCATE(COORDS_RES(3*AMBER12_RESNATOM(RESNUMBER))) 
375:      !fill the new coordinates array  
376:      COORDS_NEW(:) = 0.0D0 
377:      DO J1 = 1,3*(STARTATOM-1) 
378:         COORDS_NEW(J1) = COORDS_OLD(J1) 
379:      ENDDO 
380:  
381:      CUNIT = GETUNIT() 
382:      OPEN(CUNIT , FILE='coords.newres' , STATUS='OLD') 
383:      READ(CUNIT,*) COORDS_NEWRES 
384:      COORDS_RES(:) = RESHAPE(COORDS_NEWRES,(/3*AMBER12_RESNATOM(RESNUMBER)/)) 
385:      DO J1 = 1,AMBER12_RESNATOM(RESNUMBER) 
386:         COORDS_NEW(3*(STARTATOM+(J1-1))-2) = COORDS_RES(3*J1-2) 
387:         COORDS_NEW(3*(STARTATOM+(J1-1))-1) = COORDS_RES(3*J1-1) 
388:         COORDS_NEW(3*(STARTATOM+(J1-1))) = COORDS_RES(3*J1) 
389:      ENDDO 
390: 40   CLOSE(CUNIT) 
391:     
392:      DO J1 = 1,(3*(NATOMS-FINALATOM_OLD)) 
393:         COORDS_NEW(3*FINALATOM_NEW + J1) = COORDS_OLD(3*FINALATOM_OLD + J1) 
394:      ENDDO 
395:      !we can't write to coords.inpcrd (as this is protected by the interface) 
396:      !hence we trick the program by writing it to a different name and using a system call to move it 
397:      CALL AMBER12_WRITE_RESTART_MUT(COORDS_NEW, AMBER12_RESEND(NRESIDUES),& 
398:                   &'coords.inpcrd.xxx',LEN('coords.inpcrd.xxx')) 
399:      CALL SYSTEM('mv coords.inpcrd.xxx coords.inpcrd') 
400:      CUNIT2 = GETUNIT() 
401:      !create a start file (format specifications are less strict here) 
402:      OPEN(CUNIT2 , FILE='start' , STATUS='NEW') 
403:      DO J1 = 1,NATOMS+SHIFT 
404:         WRITE(CUNIT2 , '(3f12.7)') COORDS_NEW(3*J1-2) , COORDS_NEW(3*J1-1) , COORDS_NEW(3*J1) 
405:      ENDDO 
406:      CLOSE(CUNIT2) 
407:      !finally remove the files we dont need, except if we are in DEBUG mode 
408:      IF (.NOT.DEBUG) CALL SYSTEM('rm coords.newres coords.oldres leap.in leap.log tmp.inpcrd') 
409:   END SUBROUTINE CREATE_NEW_TOPOLOGY 
410:  
411:   SUBROUTINE REINITIALISE_AMBER() 
412:         INTEGER :: NUMBER_OF_ATOMS , J1 
413:         CHARACTER(LEN=20) OSTRING 
414:         DOUBLE PRECISION , ALLOCATABLE :: COORDS1(:) 
415:  
416:         !first of all we close all open AMBER files, deallocate all internal arrays, and remove traces from the previous initialisation 
417:         CALL AMBER12_MUT_FINISH() 
418:         !new number of atoms and amber setup 
419:         NUMBER_OF_ATOMS=AMBER12_RESEND(NRESIDUES) 
420:         WRITE(OSTRING,'(A)') 'coords.inpcrd' 
421:         !reinitialise AMBER with the new information 
422:         CALL AMBER12_SETUP(NUMBER_OF_ATOMS, OSTRING, LEN(OSTRING)) 
423:         NATOMS = NUMBER_OF_ATOMS 
424:         NATOMSALLOC = NUMBER_OF_ATOMS 
425:         WRITE(MYUNIT,'(A,I8)') ' ambermut> new number of atoms: ',NATOMS 
426:         !new coordinates 
427:         IF(ALLOCATED(COORDS1)) DEALLOCATE(COORDS1) 
428:         ALLOCATE(COORDS1(3*NATOMS)) 
429:         IF(ALLOCATED(COORDS)) DEALLOCATE(COORDS) 
430:         ! Read the coords from AMBER12 into COORDS1(:) 
431:         CALL AMBER12_GET_COORDS(NATOMS, COORDS1(:)) 
432:         ALLOCATE(COORDS(3*NATOMS,NPAR)) 
433:         DO J1=1,NPAR 
434:            COORDS(:,J1) = COORDS1(:) 
435:         END DO 
436:         !setup the new group rotation information 
437:         CALL MUT_SETUP_GROUPROTATION(1,.FALSE.,.FALSE.,0) 
438:         !deallocate, reallocate and initialise a bunch of globals that we need to reset 
439:         DEALLOCATE(QMINP) 
440:         ALLOCATE(QMINP(NSAVE,3*NATOMS)) 
441:         DEALLOCATE(QMINT) 
442:         ALLOCATE(QMINT(NSAVE,NATOMS)) 
443:         DEALLOCATE(COORDSO) 
444:         ALLOCATE(COORDSO(3*NATOMS,NPAR)) 
445:         DEALLOCATE(VT) 
446:         ALLOCATE(VT(NATOMS)) 
447:         DEALLOCATE(VAT) 
448:         ALLOCATE(VAT(NATOMS,NPAR)) 
449:         DEALLOCATE(VATO) 
450:         ALLOCATE(VATO(NATOMS,NPAR)) 
451:         DEALLOCATE(LABELS) 
452:         ALLOCATE(LABELS(NATOMS,NPAR)) 
453:         DEALLOCATE(LABELSO) 
454:         ALLOCATE(LABELSO(NATOMS,NPAR)) 
455:         QMINP(1:NSAVE,1:3*NATOMS)=0.0D0 ! to prevent reading from uninitialised memory 
456:         QMINT(1:NSAVE,1:NATOMS)=1 ! to prevent reading from uninitialised memory 
457:         QMINNATOMS(1:NSAVE)=NATOMS ! to prevent reading from uninitialised memory 
458:         COORDSO(1:3*NATOMS,1:NPAR)=0.0D0 
459:         VT(1:NATOMS)=0.0D0 
460:         VAT(1:NATOMS,1:NPAR)=0.0D0 
461:         DO J1=1,NSAVE 
462:            QMIN(J1)=1.0D10 
463:            NPCALL_QMIN(J1)=0 
464:         ENDDO 
465:   END SUBROUTINE REINITIALISE_AMBER 
466:  
467:   SUBROUTINE REVERSE_MUTATION(RESNUMBER) 
468:      CHARACTER(LEN=6) :: NMUT_STRING 
469:      INTEGER :: STARTATOM, FINALATOM_OLD,FINALATOM_NEW,SHIFT 
470:      INTEGER , INTENT(IN) :: RESNUMBER     
471:       
472:      !reload the correct information into MUTATION_INFO 
473:      MUTATION_INFO = PREVIOUS_MUTATION  
474:      WRITE(NMUT_STRING,'(I6)') NMUTATION - 1 
475:      STARTATOM = AMBER12_RESSTART(RESNUMBER) 
476:      FINALATOM_OLD = AMBER12_RESEND(RESNUMBER) 
477:      !move all the files we need back into place (we use the lowest previous minimum to restart) 
478:      CALL SYSTEM('cp coords.prmtop.'//TRIM(ADJUSTL(NMUT_STRING))//' coords.prmtop') 
479:      CALL TOPOLOGY_READER() 
480:      !get the changed number of atoms 
481:      FINALATOM_NEW = AMBER12_RESEND(RESNUMBER) 
482:      SHIFT = FINALATOM_NEW - FINALATOM_OLD 
483:      !correct wrong information (we havent reinitialised yet, so NATOMS is still wrong) 
484:      AMBER12_RESEND(NRESIDUES) = AMBER12_RESEND(NRESIDUES) + SHIFT 
485:      AMBER12_RESNATOM(NRESIDUES) = AMBER12_RESNATOM(NRESIDUES) + SHIFT 
486:      !create final input files needed 
487:      CALL SYSTEM('cp coords.'//TRIM(ADJUSTL(NMUT_STRING))//'.1.rst coords.inpcrd') 
488:      CALL SYSTEM('cp start.'//TRIM(ADJUSTL(NMUT_STRING))//' start')  !this one is the wrong file? 
489:      CALL SYSTEM('cp atomgroups.'//TRIM(ADJUSTL(NMUT_STRING))//' atomgroups') 
490:      CALL SYSTEM('cp perm.allow.'//TRIM(ADJUSTL(NMUT_STRING))//' perm.allow') 
491:      !now reinitialise once more 
492:      CALL REINITIALISE_AMBER() 
493:   END SUBROUTINE REVERSE_MUTATION 
494:  
495:   !scoring function to judge how good mutation is 
496:   SUBROUTINE MUTATION_E(SCORE,COORDS,MODE,TERMID) 
497:      DOUBLE PRECISION, INTENT(OUT) :: SCORE 
498:      DOUBLE PRECISION, INTENT(IN) :: COORDS(3*NATOMS) 
499:      INTEGER, INTENT(IN) :: MODE, TERMID 
500:      DOUBLE PRECISION :: DPRAND, EREAL, GRADATOMS(3*NATOMS) 
501:      INTEGER :: ATOMID, PARMEDUNIT, GETUNIT, J1 
502:      TYPE(POT_ENE_REC_C) :: DECOMPOSED_E 
503:      CHARACTER(200) ENTRY_ 
504:      INTEGER , PARAMETER :: NWORDS=20 
505:      CHARACTER(25) :: ENTRIES(NWORDS)='' 
506:      CHARACTER(LEN=6) :: J1_STRING 
507:     
508:      IF (MODE.EQ.1) THEN 
509:         SCORE=DPRAND() 
510:      ELSE IF (MODE.EQ.2) THEN 
511:         CALL AMBER12_ENERGY_AND_GRADIENT(NATOMS, COORDS, EREAL, GRADATOMS, DECOMPOSED_E) 
512:         WRITE(MUTUNIT,'(A)') 'Energy decomposition' 
513:         WRITE(MUTUNIT,'(A,F20.10)') 'Total energy:        ', DECOMPOSED_E % TOTAL 
514:         WRITE(MUTUNIT,'(A,F20.10)') 'Total van der Waals: ', DECOMPOSED_E % VDW_TOT 
515:         WRITE(MUTUNIT,'(A,F20.10)') 'Total electronic:    ', DECOMPOSED_E % ELEC_TOT 
516:         WRITE(MUTUNIT,'(A,F20.10)') 'Generalised Born:    ', DECOMPOSED_E % GB 
517:         WRITE(MUTUNIT,'(A,F20.10)') 'Surface energy:      ', DECOMPOSED_E % SURF 
518:         WRITE(MUTUNIT,'(A,F20.10)') 'Bond energy:         ', DECOMPOSED_E % BOND 
519:         WRITE(MUTUNIT,'(A,F20.10)') 'Angular term:        ', DECOMPOSED_E % ANGLE 
520:         WRITE(MUTUNIT,'(A,F20.10)') 'Dihedral term:       ', DECOMPOSED_E % DIHEDRAL 
521:         WRITE(MUTUNIT,'(A,F20.10)') 'vdW 1-4 term:        ', DECOMPOSED_E % VDW_14 
522:         WRITE(MUTUNIT,'(A,F20.10)') 'Electronic 1-4:      ', DECOMPOSED_E % ELEC_14 
523:         WRITE(MUTUNIT,'(A,F20.10)') 'Restraints:          ', DECOMPOSED_E % RESTRAINT 
524:         WRITE(MUTUNIT,'(A,F20.10)') 'Urey Bradley angle:  ', DECOMPOSED_E % ANGLE_UB 
525:         WRITE(MUTUNIT,'(A,F20.10)') 'Improper energy:     ', DECOMPOSED_E % IMP 
526:         WRITE(MUTUNIT,'(A,F20.10)') 'CMAP:                ', DECOMPOSED_E % CMAP 
527:         IF (TERMID.EQ.0) THEN 
528:            SCORE = DECOMPOSED_E % TOTAL 
529:         ELSE IF (TERMID.EQ.1) THEN 
530:            SCORE = DECOMPOSED_E % VDW_TOT 
531:         ELSE IF (TERMID.EQ.2) THEN 
532:            SCORE = DECOMPOSED_E % ELEC_TOT 
533:         ELSE IF (TERMID.EQ.3) THEN 
534:            SCORE = DECOMPOSED_E % GB 
535:         ELSE IF (TERMID.EQ.4) THEN 
536:            SCORE = DECOMPOSED_E % SURF 
537:         ELSE IF (TERMID.EQ.5) THEN 
538:            SCORE = DECOMPOSED_E % BOND 
539:         ELSE IF (TERMID.EQ.6) THEN 
540:            SCORE = DECOMPOSED_E % ANGLE 
541:         ELSE IF (TERMID.EQ.7) THEN 
542:            SCORE = DECOMPOSED_E % DIHEDRAL 
543:         ELSE IF (TERMID.EQ.8) THEN 
544:            SCORE = DECOMPOSED_E % VDW_14 
545:         ELSE IF (TERMID.EQ.9) THEN 
546:            SCORE = DECOMPOSED_E % ELEC_14 
547:         ELSE IF (TERMID.EQ.10) THEN 
548:            SCORE = DECOMPOSED_E % RESTRAINT 
549:         ELSE IF (TERMID.EQ.11) THEN 
550:            SCORE = DECOMPOSED_E % ANGLE_UB 
551:         ELSE IF (TERMID.EQ.12) THEN 
552:            SCORE = DECOMPOSED_E % IMP 
553:         ELSE IF (TERMID.EQ.13) THEN 
554:            SCORE = DECOMPOSED_E % CMAP 
555:         ENDIF 
556:      ELSE IF (MODE.EQ.3) THEN 
557:         ATOMID = AMBER12_RESEND(TERMID) !get last atom in first group 
558:         !open new file to write parmed input 
559:         PARMEDUNIT = GETUNIT() 
560:         OPEN(PARMEDUNIT,FILE='parmed_in',STATUS='NEW') 
561:         WRITE(PARMEDUNIT,'(A)',ADVANCE='NO') 'addExclusions @1'         
562:         DO J1=2,ATOMID 
563:            WRITE(J1_STRING,'(I6)') J1 
564:            WRITE(PARMEDUNIT,'(A)',ADVANCE='NO') ','//TRIM(ADJUSTL(J1_STRING)) 
565:         ENDDO 
566:         WRITE(PARMEDUNIT,'(A)',ADVANCE='NO') ' @1'        
567:         DO J1=2,ATOMID-1 
568:            WRITE(J1_STRING,'(I6)') J1 
569:            WRITE(PARMEDUNIT,'(A)',ADVANCE='NO') ','//TRIM(ADJUSTL(J1_STRING)) 
570:         ENDDO 
571:         WRITE(J1_STRING,'(I6)') ATOMID 
572:         WRITE(PARMEDUNIT,'(A)') ','//TRIM(ADJUSTL(J1_STRING)) 
573:         WRITE(J1_STRING,'(I6)') ATOMID+1 
574:         WRITE(PARMEDUNIT,'(A)',ADVANCE='NO') 'addExclusions @'//TRIM(ADJUSTL(J1_STRING))         
575:         DO J1=ATOMID+2,NATOMS 
576:            WRITE(J1_STRING,'(I6)') J1 
577:            WRITE(PARMEDUNIT,'(A)',ADVANCE='NO') ','//TRIM(ADJUSTL(J1_STRING)) 
578:         ENDDO 
579:         WRITE(J1_STRING,'(I6)') ATOMID+1 
580:         WRITE(PARMEDUNIT,'(A)',ADVANCE='NO') ' @'//TRIM(ADJUSTL(J1_STRING))        
581:         DO J1=ATOMID+2,NATOMS-1 
582:            WRITE(J1_STRING,'(I6)') J1 
583:            WRITE(PARMEDUNIT,'(A)',ADVANCE='NO') ','//TRIM(ADJUSTL(J1_STRING)) 
584:         ENDDO 
585:         WRITE(J1_STRING,'(I6)') NATOMS-1 
586:         WRITE(PARMEDUNIT,'(A)') ','//TRIM(ADJUSTL(J1_STRING)) 
587:         WRITE(PARMEDUNIT,'(A)') 'loadRestrt current.inpcrd' 
588:         WRITE(J1_STRING,'(I6)') AMBERMUTIGB 
589:         WRITE(PARMEDUNIT,'(A)') 'energy cutoff 15.0 igb '//TRIM(ADJUSTL(J1_STRING))//' saltcon 0.1' 
590:         WRITE(PARMEDUNIT,'(A)') 'quit' 
591:         CLOSE(PARMEDUNIT) 
592:         CALL AMBER12_WRITE_RESTART(COORDS, 'current.inpcrd',LEN('current.inpcrd')) 
593:         !create new topology without interactions and calculate energy 
594:         CALL SYSTEM('parmed.py -n coords.prmtop parmed_in > parmed_out') 
595:         OPEN(PARMEDUNIT,FILE='parmed_out',STATUS='OLD') 
596:         DO 
597:           ENTRIES(:)='' 
598:           READ(PARMEDUNIT,'(A)',END=588) ENTRY_ 
599:           CALL READ_LINE(ENTRY_,NWORDS,ENTRIES) 
600:           IF (ENTRIES(1).EQ.'TOTAL') THEN 
601:              READ(ENTRIES(3),'(F20.10)') SCORE 
602:              GOTO 588 
603:           ENDIF 
604:         ENDDO 
605: 588     CONTINUE 
606:         CALL SYSTEM('rm current.inpcrd parmed_in parmed_out')       
607:      ENDIF 
608:   END SUBROUTINE MUTATION_E 
609:  
610:   SUBROUTINE AMBERMUT_CURR_LOWEST() 
611:      CHARACTER(LEN=6) :: J1_STRING, NMUT_STRING 
612:      INTEGER :: J1     
613:   
614:      !to save the previous best strutures  
615:      DO J1=1,NSAVE 
616:         WRITE(J1_STRING,'(I6)') J1 
617:         WRITE(NMUT_STRING,'(I6)') NMUTATION - 1 
618:         CALL AMBER12_WRITE_RESTART(QMINP(J1,:), 'coords.'//TRIM(ADJUSTL(NMUT_STRING))//'.'//& 
619:                    &TRIM(ADJUSTL(J1_STRING))//'.rst', & 
620:                    & LEN('coords.'//TRIM(ADJUSTL(NMUT_STRING))//'.'//TRIM(ADJUSTL(J1_STRING))//'.rst')) 
621:         CALL AMBER12_WRITE_PDB(QMINP(J1,:), 'coords.'//TRIM(ADJUSTL(NMUT_STRING))//'.'//& 
622:                    &TRIM(ADJUSTL(J1_STRING))//'.pdb', & 
623:                    & LEN('coords.'//TRIM(ADJUSTL(NMUT_STRING))//'.'//TRIM(ADJUSTL(J1_STRING))//'.pdb')) 
624:      ENDDO 
625:   END SUBROUTINE AMBERMUT_CURR_LOWEST 
626:    
627:   !tidy up after run is complete 
628:   SUBROUTINE FINISH_AMBERMUT() 
629:      CHARACTER(LEN=6) :: J1_STRING, NMUT_STRING 
630:      INTEGER :: J1     
631:   
632:      !to save the previous best strutures  
633:      DO J1=1,NSAVE 
634:         WRITE(J1_STRING,'(I6)') J1 
635:         WRITE(NMUT_STRING,'(I6)') NMUTATION 
636:         CALL AMBER12_WRITE_RESTART(QMINP(J1,:), 'coords.'//TRIM(ADJUSTL(NMUT_STRING))//'.'//& 
637:                    &TRIM(ADJUSTL(J1_STRING))//'.rst', & 
638:                    & LEN('coords.'//TRIM(ADJUSTL(NMUT_STRING))//'.'//TRIM(ADJUSTL(J1_STRING))//'.rst')) 
639:         CALL AMBER12_WRITE_PDB(QMINP(J1,:), 'coords.'//TRIM(ADJUSTL(NMUT_STRING))//'.'//& 
640:                    &TRIM(ADJUSTL(J1_STRING))//'.pdb', & 
641:                    & LEN('coords.'//TRIM(ADJUSTL(NMUT_STRING))//'.'//TRIM(ADJUSTL(J1_STRING))//'.pdb')) 
642:      ENDDO 
643:  
644:      IF (ALLOCATED(AMBER12_RESNAME)) DEALLOCATE(AMBER12_RESNAME) 
645:      IF (ALLOCATED(AMBER12_RESSTART)) DEALLOCATE(AMBER12_RESSTART) 
646:      IF (ALLOCATED(AMBER12_RESEND)) DEALLOCATE(AMBER12_RESEND) 
647:      IF (ALLOCATED(AMBER12_RESNATOM)) DEALLOCATE(AMBER12_RESNATOM) 
648:      IF (ALLOCATED(TERMINI_RES)) DEALLOCATE(TERMINI_RES) 
649:      IF (ALLOCATED(MUTATION_INFO)) DEALLOCATE(MUTATION_INFO) 
650:      IF (ALLOCATED(PREVIOUS_MUTATION)) DEALLOCATE(PREVIOUS_MUTATION) 
651:      CLOSE(MUTUNIT) 
652:   END SUBROUTINE FINISH_AMBERMUT 
653:  
654:  
655:   SUBROUTINE MUT_SETUP_GROUPROTATION(GROUPROTFREQ,GR_SCALEROT,GR_SCALEPROB,GROUPOFFSET) 
656:      INTEGER, INTENT(IN) :: GROUPROTFREQ , GROUPOFFSET 
657:      LOGICAL, INTENT(IN) :: GR_SCALEROT , GR_SCALEPROB 
658:      INTEGER ::  GROUPSIZE , GROUPATOM , AXIS1 , AXIS2 , IOSTATUS, J1,J2 
659:      CHARACTER(LEN=10) :: CHECK1 
660:      LOGICAL :: YESNO 
661:  
662:      !check we actually have a grouprotation file! 
663:      YESNO=.FALSE. 
664:      INQUIRE(FILE='atomgroups',EXIST=YESNO) 
665:      IF (YESNO) THEN 
666:         GROUPROTT=.TRUE. 
667:         WRITE(MYUNIT,'(A)') ' ambermut> AMBER group rotation moves enabled for new sequence' 
668:      ELSE 
669:         WRITE(MYUNIT,'(A)') ' keyword> ERROR: atom groups must be defined in atomgroups file' 
670:         STOP 
671:      ENDIF 
672:      !check the grouprotation frequency 
673:      IF(GROUPROTFREQ.EQ.0) THEN 
674:         GROUPROTT=.FALSE. 
675:         WRITE(MYUNIT,'(A)') ' keyword> WARNING: frequency of GROUPROTATION moves set to 0 - moves DISABLED!' 
676:      ENDIF 
677:      !kr366> copy ffrom keywords.f 
678:      !csw34> Figure out how many atom groups have been defined 
679:      NGROUPS=0 
680:      OPEN(UNIT=222,FILE='atomgroups',status='old') 
681:      DO 
682:         READ(222,*,IOSTAT=iostatus) CHECK1 
683:         IF (iostatus<0) THEN 
684:            CLOSE(222) 
685:            EXIT 
686:         ELSE IF (TRIM(ADJUSTL(check1)).EQ.'GROUP') then 
687:            NGROUPS=NGROUPS+1 
688:         ENDIF 
689:      END DO 
690:      CLOSE(222) 
691:      !DEALLOCATE old arrays first 
692:      DEALLOCATE(ATOMGROUPNAMES) 
693:      DEALLOCATE(ATOMGROUPAXIS) 
694:      DEALLOCATE(ATOMGROUPPSELECT) 
695:      DEALLOCATE(ATOMGROUPSCALING) 
696:      DEALLOCATE(ATOMGROUPS) 
697:      !Allocate atom group info arrays appropriately 
698:      ALLOCATE(ATOMGROUPNAMES(NGROUPS)) 
699:      ALLOCATE(ATOMGROUPAXIS(NGROUPS,2)) 
700:      ALLOCATE(ATOMGROUPPSELECT(NGROUPS)) 
701:      ALLOCATE(ATOMGROUPSCALING(NGROUPS)) 
702:      ALLOCATE(ATOMGROUPS(NGROUPS,NATOMSALLOC)) 
703:      !Set safe defaults 
704:      ATOMGROUPS(:,:)=.FALSE. 
705:      ATOMGROUPNAMES(:)='EMPTY' 
706:      ATOMGROUPAXIS(:,:)=0 
707:      ATOMGROUPSCALING(:)=1.0D0 
708:      ATOMGROUPPSELECT(:)=1.0D0 
709:      ! Read in group info 
710:      ! Here is an example entry: 
711:      ! GROUP OME 6 5 4 1.0 
712:      ! 1 
713:      ! 2 
714:      ! 3 
715:      ! 4 
716:      ! This says that group OME is to be rotated about the bond from atom 6->5. 
717:      ! There are 4 atoms in the OME group. Rotations of -pi->+pi are to be scaled by 1.0. 
718:      ! Finally, the group members are specified one per line 
719:      OPEN(UNIT=222,FILE='atomgroups',status='unknown') 
720:      WRITE(MYUNIT,*) 'keyword> Reading in atom groups for GROUPROTATION' 
721:      IF(GROUPOFFSET.NE.0) WRITE(MYUNIT,*) 'keyword> Group atom numbering offset by ',GROUPOFFSET 
722:      DO J1=1,NGROUPS 
723:         READ(222,*) CHECK1,ATOMGROUPNAMES(J1),AXIS1,AXIS2,GROUPSIZE,ATOMGROUPSCALING(J1),& 
724:      &                ATOMGROUPPSELECT(J1) 
725:         ATOMGROUPAXIS(J1,1)=AXIS1+GROUPOFFSET 
726:         ATOMGROUPAXIS(J1,2)=AXIS2+GROUPOFFSET 
727:         CALL FLUSH(MYUNIT) 
728:         IF (TRIM(ADJUSTL(CHECK1)).EQ.'GROUP') THEN 
729:            DO J2=1,GROUPSIZE 
730:               READ(222,*) GROUPATOM 
731:               IF(GROUPOFFSET.GT.0) GROUPATOM=GROUPATOM+GROUPOFFSET 
732:               !add bound checks 
733:               IF (GROUPATOM > NATOMSALLOC) THEN 
734:                 WRITE(MYUNIT,'(A)') 'ambermut> ERROR! GROUPATOM > NATOMSALLOC' 
735:               ENDIF 
736:               ATOMGROUPS(J1,GROUPATOM)=.TRUE. 
737:            END DO 
738:         ELSE 
739:            WRITE(MYUNIT,'(A)') ' keyword: ERROR! Group file not formatted correctly!' 
740:            STOP 
741:         ENDIF 
742:         WRITE(MYUNIT,'(3A)') '<GROUP ',TRIM(ADJUSTL(ATOMGROUPNAMES(J1))),'>' 
743:         WRITE(MYUNIT,'(A,I3)') 'Index: ',J1 
744:         WRITE(MYUNIT,'(A,I4)') 'Size: ',GROUPSIZE 
745:         WRITE(MYUNIT,'(A,2I6)') 'Atoms defining axis: ',ATOMGROUPAXIS(J1,1),ATOMGROUPAXIS(J1,2) 
746:         WRITE(MYUNIT,'(A,F5.2)') 'Rotation scaling: ',ATOMGROUPSCALING(J1) 
747:         WRITE(MYUNIT,'(A,F5.4)') 'Selection probablity: ',ATOMGROUPPSELECT(J1) 
748:         WRITE(MYUNIT,'(A)') 'Members:' 
749:         DO J2=1,NATOMSALLOC 
750:            IF(ATOMGROUPS(J1,J2)) WRITE(MYUNIT,*) J2 
751:         ENDDO 
752:      ENDDO 
753:      CLOSE(222) 
754:   END SUBROUTINE MUT_SETUP_GROUPROTATION  
755:  
756:   SUBROUTINE TOPOLOGY_READER() 
757:  
758:      IMPLICIT NONE 
759:      CHARACTER(200) ENTRY_ 
760:      INTEGER :: MYUNIT2,GETUNIT 
761:      INTEGER :: HENTRIES,J3,J4,NDUMMY 
762:      INTEGER , PARAMETER :: NWORDS=20 
763:      CHARACTER(25) :: ENTRIES(NWORDS)='' 
764:      CHARACTER(LEN=4) :: WORD 
765:  
766:      MYUNIT2=GETUNIT() 
767:      OPEN(MYUNIT2,FILE='coords.prmtop',STATUS='OLD') 
768:      reading:DO 
769: 98      ENTRIES(:)='' 
770:         READ(MYUNIT2,'(A)',END=99) ENTRY_ 
771:         CALL READ_LINE(ENTRY_,NWORDS,ENTRIES)      !get all words in line 
772:         IF (ENTRIES(2).EQ.'POINTERS') THEN        !get number of residues here 
773:            READ(MYUNIT2,*)                          !ignore format identifier after flag 
774:            READ(MYUNIT2,*)                          !ignore first line, no information we need in here 
775:            READ(MYUNIT2,'(A)',END=99) ENTRY_ 
776:            ENTRIES(:)='' 
777:            CALL READ_LINE(ENTRY_,NWORDS,ENTRIES) 
778:            READ(ENTRIES(2),'(I8)') NRESIDUES 
779:            WRITE(MYUNIT,'(A,I8)') 'ambermut> reading topology - Number of residues:' , NRESIDUES 
780:            IF (ALLOCATED(AMBER12_RESNAME)) DEALLOCATE(AMBER12_RESNAME) 
781:            ALLOCATE(AMBER12_RESNAME(NRESIDUES)) 
782:            AMBER12_RESNAME(:) = "    " 
783:            IF (ALLOCATED(AMBER12_RESSTART)) DEALLOCATE(AMBER12_RESSTART) 
784:            ALLOCATE(AMBER12_RESSTART(NRESIDUES)) 
785:            AMBER12_RESSTART(:) = 0 
786:            IF (ALLOCATED(AMBER12_RESEND)) DEALLOCATE(AMBER12_RESEND) 
787:            ALLOCATE(AMBER12_RESEND(NRESIDUES)) 
788:            AMBER12_RESEND(:) = 0 
789:            IF (ALLOCATED(AMBER12_RESNATOM)) DEALLOCATE(AMBER12_RESNATOM) 
790:            ALLOCATE(AMBER12_RESNATOM(NRESIDUES)) 
791:            AMBER12_RESNATOM(:) = 0 
792:         ENDIF 
793:         IF (ENTRIES(2).EQ. 'RESIDUE_LABEL') THEN 
794:            READ(MYUNIT2,*)                        !ignore format identifier after flag 
795:            IF (MOD(NRESIDUES,20).EQ.0) THEN       !get the number of lines (20 entries per line!) 
796:               HENTRIES=NRESIDUES/20 
797:            ELSE 
798:               HENTRIES=NRESIDUES/20 + 1 
799:            ENDIF 
800:            !We leave th complication of terminal residues out here and take care of it in the atom mapping when taking a step  
801:            NDUMMY=1 
802:            DO J3=1,HENTRIES                             !go through all lines 
803:               READ(MYUNIT2,'(A)',END=99) ENTRY_               !read line 
804:               ENTRIES(:)='' 
805:               CALL READ_LINE(ENTRY_,NWORDS,ENTRIES) 
806:               J4=1 
807:               DO WHILE(J4.LE.20) 
808:                  IF (NDUMMY.LE.NRESIDUES) THEN 
809:                     WORD = ENTRIES(J4)(1:3) 
810:                     AMBER12_RESNAME(NDUMMY) = WORD 
811:                     NDUMMY = NDUMMY + 1 
812:                  ELSE 
813:                     GOTO 98 
814:                  ENDIF 
815:                  J4=J4+1 
816:               ENDDO 
817:            ENDDO 
818:         ENDIF 
819:         IF (ENTRIES(2).EQ. 'RESIDUE_POINTER') THEN 
820:            READ(MYUNIT2,*)                             !ignore format identifier after flag 
821:            IF (MOD(NRESIDUES,10).EQ.0) THEN       !get the number of lines (10 entries per line!) 
822:               HENTRIES=NRESIDUES/10 
823:            ELSE 
824:               HENTRIES=NRESIDUES/10 + 1 
825:            ENDIF 
826:            NDUMMY=1 
827:            DO J3=1,HENTRIES                             !go through all lines 
828:               READ(MYUNIT2,'(A)',END=99) ENTRY_               !read line 
829:               CALL READ_LINE(ENTRY_,NWORDS,ENTRIES) 
830:               J4=1 
831:               DO WHILE(J4.LE.10) 
832:                  IF (NDUMMY.LE.NRESIDUES) THEN 
833:                     READ(ENTRIES(J4),'(I8)') AMBER12_RESSTART(NDUMMY) 
834:                     NDUMMY = NDUMMY + 1 
835:                  ELSE 
836:                     GOTO 98 
837:                  ENDIF 
838:                  J4=J4+1 
839:               ENDDO 
840:            ENDDO 
841:         ENDIF 
842:      ENDDO reading 
843: 99   CLOSE(MYUNIT2) 
844:      DO J4=1,NRESIDUES-1 
845:         AMBER12_RESEND(J4) = AMBER12_RESSTART(J4+1) - 1 
846:         AMBER12_RESNATOM(J4) = AMBER12_RESEND(J4) - AMBER12_RESSTART(J4) + 1 
847:      ENDDO 
848:      AMBER12_RESEND(NRESIDUES) = NATOMS 
849:      AMBER12_RESNATOM(NRESIDUES) = AMBER12_RESEND(NRESIDUES) - AMBER12_RESSTART(NRESIDUES) + 1 
850:      IF (DEBUG) THEN 
851:         WRITE(MUTUNIT,'(A)') 'Residue names, start index, end index and number of atoms' 
852:         WRITE(MUTUNIT,*) AMBER12_RESNAME 
853:         WRITE(MUTUNIT,*) AMBER12_RESSTART 
854:         WRITE(MUTUNIT,*) AMBER12_RESEND 
855:         WRITE(MUTUNIT,*) AMBER12_RESNATOM 
856:     ENDIF 
857:   END SUBROUTINE TOPOLOGY_READER 
858:    
859:   SUBROUTINE READ_LINE(LINE,NWORDS,WORDSOUT) 
860:       CHARACTER(*), INTENT(IN) :: LINE 
861:       INTEGER, INTENT(IN) :: NWORDS 
862:       CHARACTER(*), DIMENSION(NWORDS), INTENT(OUT) :: WORDSOUT 
863:       INTEGER:: J1,START_IND,END_IND,J2 
864:       CHARACTER(25) :: WORD 
865:       START_IND=0 
866:       END_IND=0 
867:       J1=1 
868:       J2=0 
869:       DO WHILE(J1.LE.LEN(LINE)) 
870:           IF ((START_IND.EQ.0).AND.(LINE(J1:J1).NE.' ')) THEN 
871:              START_IND=J1 
872:           ENDIF 
873:           IF (START_IND.GT.0) THEN 
874:              IF (LINE(J1:J1).EQ.' ') END_IND=J1-1 
875:              IF (J1.EQ.LEN(LINE)) END_IND=J1 
876:              IF (END_IND.GT.0) THEN 
877:                 J2=J2+1 
878:                 WORD=LINE(START_IND:END_IND) 
879:                 WORDSOUT(J2)=TRIM(WORD) 
880:                 START_IND=0 
881:                 END_IND=0 
882:              ENDIF 
883:           ENDIF 
884:           J1=J1+1 
885:       ENDDO 
886:   END SUBROUTINE READ_LINE 
887:  
888: END MODULE AMBER12_MUTATIONS 


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


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


r33135/chirality.F90 2017-08-07 17:30:34.489104170 +0100 r33134/chirality.F90 2017-08-07 17:30:45.309247880 +0100
195:    integer                                      :: file_length195:    integer                                      :: file_length
196: 196: 
197: #ifdef _SVN_ROOT_197: #ifdef _SVN_ROOT_
198:    call system('python ' // _SVN_ROOT_ // '/SCRIPTS/AMBER/chirality/chirality.py' // ' coords.prmtop')198:    call system('python ' // _SVN_ROOT_ // '/SCRIPTS/AMBER/chirality/chirality.py' // ' coords.prmtop')
199: #else199: #else
200:    call system('python ' // chirality_script // ' coords.prmtop')200:    call system('python ' // chirality_script // ' coords.prmtop')
201: #endif201: #endif
202: 202: 
203: ! Work out the number of chiral centres by reading the .chirality_list file 203: ! Work out the number of chiral centres by reading the .chirality_list file 
204:    num_chiral_centres = file_length('.chirality_list')204:    num_chiral_centres = file_length('.chirality_list')
205:    if (allocated(sr_atoms)) deallocate(sr_atoms)205:    if (.not. allocated(sr_atoms)) allocate(sr_atoms(num_chiral_centres, 5))
206:    allocate(sr_atoms(num_chiral_centres, 5)) 
207: 206: 
208: ! Now read the chiral centres into sr_atoms207: ! Now read the chiral centres into sr_atoms
209:    call file_open('.chirality_list', file_unit, .false.)208:    call file_open('.chirality_list', file_unit, .false.)
210:    do i = 1, num_chiral_centres209:    do i = 1, num_chiral_centres
211:       read(file_unit, '(5i8)') sr_atoms(i, :)210:       read(file_unit, '(5i8)') sr_atoms(i, :)
212:    end do211:    end do
213:    close(file_unit)212:    close(file_unit)
214: 213: 
215: ! Print a test copy214: ! Print a test copy
216: !   call file_open('chirality_list_copy', file_unit, .false.)215: !   call file_open('chirality_list_copy', file_unit, .false.)
217: !   do i = 1, num_chiral_centres216: !   do i = 1, num_chiral_centres
218: !      write(file_unit, '(5i10)') sr_atoms(i, :)217: !      write(file_unit, '(5i10)') sr_atoms(i, :)
219: !   end do218: !   end do
220: !   close(file_unit)219: !   close(file_unit)
221: 220: 
222: ! Now calculate the chirality of the centres and save it in sr_states_initial221: ! Now calculate the chirality of the centres and save it in sr_states_initial
223:    if (allocated(sr_states_initial)) deallocate(sr_states_initial)222:    if (.not. allocated(sr_states_initial)) allocate(sr_states_initial(num_chiral_centres))
224:    allocate(sr_states_initial(num_chiral_centres)) 
225:    do i = 1, num_chiral_centres223:    do i = 1, num_chiral_centres
226:       atom_number = sr_atoms(i, 1)224:       atom_number = sr_atoms(i, 1)
227:       centre_coords(1) = coords(3 * atom_number - 2)225:       centre_coords(1) = coords(3 * atom_number - 2)
228:       centre_coords(2) = coords(3 * atom_number - 1)226:       centre_coords(2) = coords(3 * atom_number - 1)
229:       centre_coords(3) = coords(3 * atom_number    )227:       centre_coords(3) = coords(3 * atom_number    )
230:       do j = 1, 4228:       do j = 1, 4
231:          atom_number = sr_atoms(i, j + 1) 229:          atom_number = sr_atoms(i, j + 1) 
232:          neighbour_coords(3 * j - 2) = coords(3 * atom_number - 2)230:          neighbour_coords(3 * j - 2) = coords(3 * atom_number - 2)
233:          neighbour_coords(3 * j - 1) = coords(3 * atom_number - 1)231:          neighbour_coords(3 * j - 1) = coords(3 * atom_number - 1)
234:          neighbour_coords(3 * j    ) = coords(3 * atom_number    )232:          neighbour_coords(3 * j    ) = coords(3 * atom_number    )
271:    integer                                      :: file_length269:    integer                                      :: file_length
272: 270: 
273: #ifdef _SVN_ROOT_271: #ifdef _SVN_ROOT_
274:    call system('python ' // _SVN_ROOT_ // '/SCRIPTS/AMBER/chirality/cistrans.py' // ' coords.prmtop')272:    call system('python ' // _SVN_ROOT_ // '/SCRIPTS/AMBER/chirality/cistrans.py' // ' coords.prmtop')
275: #else273: #else
276:    call system('python ' // cis_trans_script // ' coords.prmtop')274:    call system('python ' // cis_trans_script // ' coords.prmtop')
277: #endif275: #endif
278: 276: 
279: ! Work out the number of peptide bonds by reading the .cis_trans_list file 277: ! Work out the number of peptide bonds by reading the .cis_trans_list file 
280:    num_peptide_bonds = file_length('.cis_trans_list')278:    num_peptide_bonds = file_length('.cis_trans_list')
281:    if (allocated(cis_trans_atoms)) deallocate(cis_trans_atoms)279:    if (.not. allocated(cis_trans_atoms)) allocate(cis_trans_atoms(num_peptide_bonds, 4))
282:    allocate(cis_trans_atoms(num_peptide_bonds, 4)) 
283: 280: 
284: ! Now read the chiral centres into cis_trans_atoms281: ! Now read the chiral centres into cis_trans_atoms
285:    call file_open('.cis_trans_list', file_unit, .false.)282:    call file_open('.cis_trans_list', file_unit, .false.)
286:    do i = 1, num_peptide_bonds283:    do i = 1, num_peptide_bonds
287:       read(file_unit, '(4i8)') cis_trans_atoms(i, :)284:       read(file_unit, '(4i8)') cis_trans_atoms(i, :)
288:    end do285:    end do
289:    close(file_unit)286:    close(file_unit)
290: 287: 
291: ! Print a test copy288: ! Print a test copy
292: !   call file_open('cis_trans_list_copy', file_unit, .false.)289: !   call file_open('cis_trans_list_copy', file_unit, .false.)
293: !   do i = 1, num_peptide_bonds290: !   do i = 1, num_peptide_bonds
294: !      write(file_unit, '(4i8)') cis_trans_atoms(i, :)291: !      write(file_unit, '(4i8)') cis_trans_atoms(i, :)
295: !   end do292: !   end do
296: !   close(file_unit)293: !   close(file_unit)
297: 294: 
298: ! Now calculate the isomerism of the peptide bonds and save it in cis_trans_states_initial295: ! Now calculate the isomerism of the peptide bonds and save it in cis_trans_states_initial
299:    if (allocated(cis_trans_states_initial)) deallocate(cis_trans_states_initial)296:    if (.not. allocated(cis_trans_states_initial)) allocate(cis_trans_states_initial(num_peptide_bonds))
300:    allocate(cis_trans_states_initial(num_peptide_bonds)) 
301:    do i = 1, num_peptide_bonds297:    do i = 1, num_peptide_bonds
302:       do j = 1, 4298:       do j = 1, 4
303:          atom_number = cis_trans_atoms(i, j) 299:          atom_number = cis_trans_atoms(i, j) 
304:          peptide_coords(3 * j - 2) = coords(3 * atom_number - 2)300:          peptide_coords(3 * j - 2) = coords(3 * atom_number - 2)
305:          peptide_coords(3 * j - 1) = coords(3 * atom_number - 1)301:          peptide_coords(3 * j - 1) = coords(3 * atom_number - 1)
306:          peptide_coords(3 * j    ) = coords(3 * atom_number    )302:          peptide_coords(3 * j    ) = coords(3 * atom_number    )
307:       end do303:       end do
308:       cis_trans_states_initial(i) = cis_trans(peptide_coords)304:       cis_trans_states_initial(i) = cis_trans(peptide_coords)
309:    end do 305:    end do 
310: 306: 
548: 544: 
549:    print *, "Angle:" , 180.0 * dihedral(plane_coords_1) / pi545:    print *, "Angle:" , 180.0 * dihedral(plane_coords_1) / pi
550:    print *, "Angle:" , 180.0 * dihedral(plane_coords_2) / pi546:    print *, "Angle:" , 180.0 * dihedral(plane_coords_2) / pi
551:    print *, "Angle:", 180.0 * dihedral(right_angle_coords_1) / pi547:    print *, "Angle:", 180.0 * dihedral(right_angle_coords_1) / pi
552:    print *, "Angle:", 180.0 * dihedral(right_angle_coords_2) / pi548:    print *, "Angle:", 180.0 * dihedral(right_angle_coords_2) / pi
553: 549: 
554:    print *, "Right angle cis/trans: ", cis_trans(right_angle_coords_1)550:    print *, "Right angle cis/trans: ", cis_trans(right_angle_coords_1)
555: 551: 
556: end subroutine test_chirality552: end subroutine test_chirality
557: 553: 
558: subroutine dealloc_states_mutation() 
559:    if (allocated(sr_states)) deallocate(sr_states) 
560: end subroutine dealloc_states_mutation 
561:  
562: end module chirality554: end module chirality


r33135/commons.f90 2017-08-07 17:30:34.709107094 +0100 r33134/commons.f90 2017-08-07 17:30:45.533250856 +0100
 34:      &        BINARY_EXAB_FRQ, NRESMIN, USERES, EXEQ, NONEDAPBC, STRUC, CHEMSHIFTITER, GRIDSIZE, MFETRUNS, BESTINVERT, GCNATOMS, & 34:      &        BINARY_EXAB_FRQ, NRESMIN, USERES, EXEQ, NONEDAPBC, STRUC, CHEMSHIFTITER, GRIDSIZE, MFETRUNS, BESTINVERT, GCNATOMS, &
 35:      &        GCINT, GCRELAX, MTARGETS, & 35:      &        GCINT, GCRELAX, MTARGETS, &
 36:      &        INTCONSEP, INTREPSEP, NCONSTRAINTON, CPREPSEP, CPCONSEP, NCONGEOM, & 36:      &        INTCONSEP, INTREPSEP, NCONSTRAINTON, CPREPSEP, CPCONSEP, NCONGEOM, &
 37:      &        NCPREPULSIVE, NCPCONSTRAINT, MAXCONUSE, INTCONSTEPS, INTRELSTEPS, INTSTEPS1, INTLJSTEPS, & 37:      &        NCPREPULSIVE, NCPCONSTRAINT, MAXCONUSE, INTCONSTEPS, INTRELSTEPS, INTSTEPS1, INTLJSTEPS, &
 38:      &        NTRAPPOW, MAXINTIMAGE, CHECKREPINTERVAL, INTFREEZEMIN, INTNTRIESMAX, INTIMAGEINCR, & 38:      &        NTRAPPOW, MAXINTIMAGE, CHECKREPINTERVAL, INTFREEZEMIN, INTNTRIESMAX, INTIMAGEINCR, &
 39:      &        NCONSTRAINTFIX, INTIMAGECHECK, NREPULSIVEFIX, INTIMAGE, NREPULSIVE, & 39:      &        NCONSTRAINTFIX, INTIMAGECHECK, NREPULSIVEFIX, INTIMAGE, NREPULSIVE, &
 40:      &        NNREPULSIVE, NCONSTRAINT, INTMUPDATE, DUMPINTEOSFREQ, DUMPINTXYZFREQ, & 40:      &        NNREPULSIVE, NCONSTRAINT, INTMUPDATE, DUMPINTEOSFREQ, DUMPINTXYZFREQ, &
 41:      &        LOCALPERMNEIGH, LOCALPERMMAXSEP, MAXNACTIVE, QCIPERMCHECKINT, & 41:      &        LOCALPERMNEIGH, LOCALPERMMAXSEP, MAXNACTIVE, QCIPERMCHECKINT, &
 42:      &        MLPIN, MLPSTART, MLPOUT, MLPHIDDEN, MLPDATA, NMLP, DJWRBID, NHEXAMERS, QCIADDREP, QCIBONDS, QCISECOND, MQUNIT, & 42:      &        MLPIN, MLPSTART, MLPOUT, MLPHIDDEN, MLPDATA, NMLP, DJWRBID, NHEXAMERS, QCIADDREP, QCIBONDS, QCISECOND, MQUNIT, &
 43:      &        MLQIN, MLQSTART, MLQOUT, MLQDATA, NMLQ, NADDTARGET, NUMNN, SQNM_HISTMAX, SQNM_DEBUGRUN, SQNM_DEBUGLEVEL, & 43:      &        MLQIN, MLQSTART, MLQOUT, MLQDATA, NMLQ, NADDTARGET, NUMNN, SQNM_HISTMAX, SQNM_DEBUGRUN, SQNM_DEBUGLEVEL, &
 44:      &        SQNM_WRITEMAX, NEWALDREAL(3), NEWALDRECIP(3), EWALDN, MLPNEIGH 44:      &        SQNM_WRITEMAX, NEWALDREAL(3), NEWALDRECIP(3), EWALDN, &
  45:      &        BOXSTEPFREQ
 45:       DOUBLE PRECISION RHO, GAMMA, SIG, SCEPS, SCC, TOLB, T12FAC, XMOVERENORM, RESIZE, QTSALLIS, & 46:       DOUBLE PRECISION RHO, GAMMA, SIG, SCEPS, SCC, TOLB, T12FAC, XMOVERENORM, RESIZE, QTSALLIS, &
 46:      &                 CQMAX, RADIUS, BQMAX,  MAXBFGS, DECAYPARAM, SYMTOL1, SYMTOL2, SYMTOL3, SYMTOL4, SYMTOL5, PGSYMTOLS(3),& 47:      &                 CQMAX, RADIUS, BQMAX,  MAXBFGS, DECAYPARAM, SYMTOL1, SYMTOL2, SYMTOL3, SYMTOL4, SYMTOL5, PGSYMTOLS(3),&
 47:      &                 ECONV, TOLD, TOLE, SYMREM(120,3,3), GMAX, CUTOFF, PCUT, EXPFAC, EXPD, CENTX, CENTY, CENTZ, & 48:      &                 ECONV, TOLD, TOLE, SYMREM(120,3,3), GMAX, CUTOFF, PCUT, EXPFAC, EXPD, CENTX, CENTY, CENTZ, &
 48:      &                 BOXLX, BOXLY, BOXLZ, BOX3D(3), PCUTOFF, SUPSTEP, SQUEEZER, SQUEEZED, COOPCUT, STOCKMU, STOCKLAMBDA, & 49:      &                 BOXLX, BOXLY, BOXLZ, BOX3D(3), PCUTOFF, SUPSTEP, SQUEEZER, SQUEEZED, COOPCUT, STOCKMU, STOCKLAMBDA, &
 49:      &                 TFAC(3), RMS, TEMPS, SACCRAT, CEIG, PNEWJUMP, EAMP, DISTFAC, ODDCHARGE, COULQ, COULSWAP, & 50:      &                 TFAC(3), RMS, TEMPS, SACCRAT, CEIG, PNEWJUMP, EAMP, DISTFAC, ODDCHARGE, COULQ, COULSWAP, &
 50:      &                 COULTEMP, APP, AMM, APM, XQP, XQM, ALPHAP, ALPHAM, ZSTAR, K_COMP, DGUESS, GUIDECUT, EFAC,& 51:      &                 COULTEMP, APP, AMM, APM, XQP, XQM, ALPHAP, ALPHAM, ZSTAR, K_COMP, DGUESS, GUIDECUT, EFAC,&
 51:      &                 TRENORM, HISTMIN, HISTMAX, HISTFAC, EPSSPHERE, FINALCUTOFF, SHELLPROB, RINGROTSCALE, & 52:      &                 TRENORM, HISTMIN, HISTMAX, HISTFAC, EPSSPHERE, FINALCUTOFF, SHELLPROB, RINGROTSCALE, &
 52:      &                 HISTFACMUL, HPERCENT, AVOIDDIST, MAXERISE, MAXEFALL, TSTART, MATDIFF, STICKYSIG, SDTOL, & 53:      &                 HISTFACMUL, HPERCENT, AVOIDDIST, MAXERISE, MAXEFALL, TSTART, MATDIFF, STICKYSIG, SDTOL, &
 53:      &                 MinimalTemperature, MaximalTemperature, SwapProb, hdistconstraint, COREFRAC, TSTAR, & 54:      &                 MinimalTemperature, MaximalTemperature, SwapProb, hdistconstraint, COREFRAC, TSTAR, &
 54:      &                 RK_R, RK_THETA,ARMA,ARMB, ExtrapolationPercent, lnHarmFreq, PTEMIN, PTEMAX, PTTMIN, PTTMAX, EXCHPROB, & 55:      &                 RK_R, RK_THETA,ARMA,ARMB, ExtrapolationPercent, lnHarmFreq, PTEMIN, PTEMAX, PTTMIN, PTTMAX, EXCHPROB, &
 79:      &                 MSTART,MFINISH,MBSTART1,MBFINISH1,MBSTART2,MBFINISH2,MBHEIGHT1,MBHEIGHT2,ME1,ME2,ME3, & 80:      &                 MSTART,MFINISH,MBSTART1,MBFINISH1,MBSTART2,MBFINISH2,MBHEIGHT1,MBHEIGHT2,ME1,ME2,ME3, &
 80:      &                 BSPTQMAX, BSPTQMIN, PFORCE, CSMNORM, CSMGUIDENORM, CSMEPS, PERCCUT, PERCGROUPCUT, & 81:      &                 BSPTQMAX, BSPTQMIN, PFORCE, CSMNORM, CSMGUIDENORM, CSMEPS, PERCCUT, PERCGROUPCUT, &
 81:      &                 LOWESTE, PERTSTEP, GCPLUS, & 82:      &                 LOWESTE, PERTSTEP, GCPLUS, &
 82:      &                 KINT, INTFREEZETOL, IMSEPMIN, IMSEPMAX, CONCUTABS, CONCUTFRAC, & 83:      &                 KINT, INTFREEZETOL, IMSEPMIN, IMSEPMAX, CONCUTABS, CONCUTFRAC, &
 83:      &                 LPDGEOMDIFFTOL, INTCONFRAC, MAXCONE, INTRMSTOL, BFGSTSTOL, ORBITTOL, & 84:      &                 LPDGEOMDIFFTOL, INTCONFRAC, MAXCONE, INTRMSTOL, BFGSTSTOL, ORBITTOL, &
 84:      &                 INTCONSTRAINTTOL, INTCONSTRAINTDEL, RBCUTOFF, INTCONSTRAINTREP, INTCONSTRAINREPCUT, & 85:      &                 INTCONSTRAINTTOL, INTCONSTRAINTDEL, RBCUTOFF, INTCONSTRAINTREP, INTCONSTRAINREPCUT, &
 85:      &                 INTLJTOL, INTLJDEL, INTLJEPS, REPCON, INTDGUESS, CHECKREPCUTOFF, INTMINFAC, FREEZETOL, & 86:      &                 INTLJTOL, INTLJDEL, INTLJEPS, REPCON, INTDGUESS, CHECKREPCUTOFF, INTMINFAC, FREEZETOL, &
 86:      &                 LOCALPERMCUT, LOCALPERMCUT2, INTCONCUT, QCIRADSHIFT, MLPLAMBDA, & 87:      &                 LOCALPERMCUT, LOCALPERMCUT2, INTCONCUT, QCIRADSHIFT, MLPLAMBDA, &
 87:      &                 CAPSIDRHO,CAPSIDEPS,SIGMAPENT,RADPENT,SIGMAHEX,RADHEX,SIGMAPH, KLIM, SCA, & 88:      &                 CAPSIDRHO,CAPSIDEPS,SIGMAPENT,RADPENT,SIGMAHEX,RADHEX,SIGMAPH, KLIM, SCA, &
 88:      &                 QCIADDREPCUT, QCIADDREPEPS, MLQLAMBDA, TANHFAC, LJADDCUTOFF,LJADDREFNORM, & 89:      &                 QCIADDREPCUT, QCIADDREPEPS, MLQLAMBDA, TANHFAC, LJADDCUTOFF,LJADDREFNORM, &
 89:      &                 ALPHAATT, NNCUTOFF 90: 
  91: ! dj337: parameters for box derivatives
  92:      &                 BOX_PARAMS(6), BOX_PARAMSGRAD(6), BOX_PARAMSO(6)
 90:  93: 
 91:       LOGICAL DEBUG, TARGET, MORSET, CUTT, SEEDT, CENT, TSALLIST, FREEZECORE, NEWJUMP, RENORM, CAPSID, FREEZE, & 94:       LOGICAL DEBUG, TARGET, MORSET, CUTT, SEEDT, CENT, TSALLIST, FREEZECORE, NEWJUMP, RENORM, CAPSID, FREEZE, &
 92:      &        OTPT, LJMFT, STRANDT, PAHT, SWT, MSTRANST, STOCKT, STICKYT, BLNT, MYSDT, FREEZERES, CENTXY, & 95:      &        OTPT, LJMFT, STRANDT, PAHT, SWT, MSTRANST, STOCKT, STICKYT, BLNT, MYSDT, FREEZERES, CENTXY, &
 93:      &        MSORIGT, SQUEEZET, PERIODIC, SCT, MSCT, MGUPTAT, RESIZET, TIP, RIGID, CALCQT, MPIT, GBHT, JMT, LJCOULT, LJ_GAUSST, OPPT, SETCENT, & 96:      &        MSORIGT, SQUEEZET, PERIODIC, SCT, MSCT, MGUPTAT, RESIZET, TIP, RIGID, CALCQT, MPIT, GBHT, JMT, LJCOULT, LJ_GAUSST, SETCENT, &
 94:      &        SORTT, HIT, SAVEQ, PARALLELT, FIXD, RKMIN, BSMIN, PERMDIST, PERMOPT, BSWL, BSPT, BSPTRESTART, & 97:      &        SORTT, HIT, SAVEQ, PARALLELT, FIXD, RKMIN, BSMIN, PERMDIST, PERMOPT, BSWL, BSPT, BSPTRESTART, &
 95:      &        SYMMETRIZE, SYMMETRIZECSM, PRINT_PTGRP, PRINT_MINDATA, DUMPT, NEON, ARGON, P46, NORESET, TABOOT, EVSTEPT, PACHECO, DL_POLY, QUCENTRE, & 98:      &        SYMMETRIZE, SYMMETRIZECSM, PRINT_PTGRP, PRINT_MINDATA, DUMPT, NEON, ARGON, P46, NORESET, TABOOT, EVSTEPT, PACHECO, DL_POLY, QUCENTRE, &
 96:      &        STAR, PLUS, TWOPLUS, GROUND, DIPOLE, DFTBT, DFTBCT, SW, SUPERSTEP, EAMLJT, PBGLUET, TRACKDATAT, & 99:      &        STAR, PLUS, TWOPLUS, GROUND, DIPOLE, DFTBT, DFTBCT, SW, SUPERSTEP, EAMLJT, PBGLUET, TRACKDATAT, &
 97:      &        EAMALT, ALGLUET, MGGLUET, GUPTAT, LJATT, FST, DECAY, COOP, FIXBIN, GAUSST, QUENCHDOS, FIXDIHEFLAG, &100:      &        EAMALT, ALGLUET, MGGLUET, GUPTAT, LJATT, FST, DECAY, COOP, FIXBIN, GAUSST, QUENCHDOS, FIXDIHEFLAG, &
 98:      &        FRAUSIT, ANGST, SELFT, STEPOUT, WENZEL, THRESHOLDT, THOMSONT, MULLERBROWNT, CHARMMENERGIES, &101:      &        FRAUSIT, ANGST, SELFT, STEPOUT, WENZEL, THRESHOLDT, THOMSONT, MULLERBROWNT, CHARMMENERGIES, &
 99:      &        PROJ, RGCL2, TOSI, WELCH, AXTELL, AMBER, FIXIMAGE, BINARY, SHIFTCUT, ARNO, TUNNELT, TWOD, &102:      &        PROJ, RGCL2, TOSI, WELCH, AXTELL, AMBER, FIXIMAGE, BINARY, SHIFTCUT, ARNO, TUNNELT, TWOD, &
100:      &        BLJCLUSTER, BLJCLUSTER_NOCUT, COMPRESST, FIX, FIXT, BFGS, LBFGST, DBRENTT, DZTEST, FNI, FAL, CPMD, TNT, ZETT1, &103:      &        BLJCLUSTER, BLJCLUSTER_NOCUT, COMPRESST, FIX, FIXT, BFGS, LBFGST, DBRENTT, DZTEST, FNI, FAL, CPMD, TNT, ZETT1, &
101:      &        ZETT2, GBH_RESTART, RESTART, CONJG, NEWRESTART, AVOID, NATBT, DIFFRACTT, CHRMMT, INTMINT, LB2T, &104:      &        ZETT2, GBH_RESTART, RESTART, CONJG, NEWRESTART, AVOID, NATBT, DIFFRACTT, CHRMMT, INTMINT, LB2T, &
102:      &        PTMC, BINSTRUCTURES, PROGRESS, MODEL1T, NEWRESTART_MD, CHANGE_TEMP, NOCISTRANS, CHECKCHIRALITY, &105:      &        PTMC, BINSTRUCTURES, PROGRESS, MODEL1T, NEWRESTART_MD, CHANGE_TEMP, NOCISTRANS, CHECKCHIRALITY, &
103:      &        GBT, GBDT, GBDPT, GEMT, LINRODT, RADIFT, CAPBINT, DBPT, DBPTDT, DMBLMT, DMBLPYT, EFIELDT, PAHAT, STOCKAAT, MORSEDPT, &106:      &        GBT, GBDT, GBDPT, GEMT, LINRODT, RADIFT, CAPBINT, DBPT, DBPTDT, DMBLMT, DMBLPYT, EFIELDT, PAHAT, STOCKAAT, MORSEDPT, &
110:      &        LJSITECOORDST, VGW, ACKLANDT, G46, DF1T, PULLT, LOCALSAMPLET, CSMT, A9INTET, INTERESTORE, COLDFUSION, &113:      &        LJSITECOORDST, VGW, ACKLANDT, G46, DF1T, PULLT, LOCALSAMPLET, CSMT, A9INTET, INTERESTORE, COLDFUSION, &
111:      &        CSMGUIDET, MULTISITEPYT, CHAPERONINT, AVOIDRESEEDT, OHCELLT, UNFREEZEFINALQ, PERCOLATET, PERCT, PERCACCEPTED, PERCCOMPMARKOV, PERCGROUPT, &114:      &        CSMGUIDET, MULTISITEPYT, CHAPERONINT, AVOIDRESEEDT, OHCELLT, UNFREEZEFINALQ, PERCOLATET, PERCT, PERCACCEPTED, PERCCOMPMARKOV, PERCGROUPT, &
112:      &        GENALT, MINDENSITYT, RESTRICTREGION, RESTRICTREGIONTEST, RESTRICTCYL, ACK1, ACK2, HARMONICF, PERCGROUPRESEEDT, &115:      &        GENALT, MINDENSITYT, RESTRICTREGION, RESTRICTREGIONTEST, RESTRICTCYL, ACK1, ACK2, HARMONICF, PERCGROUPRESEEDT, &
113:      &        HARMONICDONTMOVE, DUMPUNIQUE, FREEZESAVE, TBP, RBSYMT, PTMCDUMPSTRUCT, PTMCDUMPENERT, PYCOLDFUSION, MONITORT,&116:      &        HARMONICDONTMOVE, DUMPUNIQUE, FREEZESAVE, TBP, RBSYMT, PTMCDUMPSTRUCT, PTMCDUMPENERT, PYCOLDFUSION, MONITORT,&
114:      &        CHARMMDFTBT, PERMINVOPT, BLOCKMOVET, MAXERISE_SET, PYT, BINARY_EXAB, CHIROT, POLYT, SANDBOXT, &117:      &        CHARMMDFTBT, PERMINVOPT, BLOCKMOVET, MAXERISE_SET, PYT, BINARY_EXAB, CHIROT, POLYT, SANDBOXT, &
115:      &        RESERVOIRT, DISTOPT, ONEDAPBCT, ONEDPBCT, TWODAPBCT, TWODPBCT, THREEDAPBCT, THREEDPBCT, RATIOT, &118:      &        RESERVOIRT, DISTOPT, ONEDAPBCT, ONEDPBCT, TWODAPBCT, TWODPBCT, THREEDAPBCT, THREEDPBCT, RATIOT, &
116:      &        PTRANDOM, PTINTERVAL, PTSINGLE, PTSETS, CHEMSHIFT, CHEMSHIFT2, CSH, DEBUGss2029, UNIFORMMOVE, RANSEEDT, &119:      &        PTRANDOM, PTINTERVAL, PTSINGLE, PTSETS, CHEMSHIFT, CHEMSHIFT2, CSH, DEBUGss2029, UNIFORMMOVE, RANSEEDT, &
117:      &        TTM3T, NOINVERSION, RIGIDCONTOURT, UPDATERIGIDREFT, HYBRIDMINT, COMPRESSRIGIDT, MWFILMT, &120:      &        TTM3T, NOINVERSION, RIGIDCONTOURT, UPDATERIGIDREFT, HYBRIDMINT, COMPRESSRIGIDT, MWFILMT, &
118:      &        SUPPRESST, MFETT, POLIRT, QUIPT, SWPOTT, MWPOTT, REPMATCHT, GLJT, MLJT, READMASST, SPECMASST, NEWTSALLIST, &121:      &        SUPPRESST, MFETT, POLIRT, QUIPT, SWPOTT, MWPOTT, REPMATCHT, GLJT, MLJT, READMASST, SPECMASST, NEWTSALLIST, &
119:      &        PHI4MODELT, CUDAT, CUDATIMET, AMBER12T, ENERGY_DECOMPT, NEWMOVEST, DUMPMINT, MBPOLT, MOLECULART, GCBHT, SEMIGRAND_MUT, USEROT, &122:      &        PHI4MODELT, CUDAT, CUDATIMET, AMBER12T, ENERGY_DECOMPT, NEWMOVEST, DUMPMINT, MBPOLT, MOLECULART, GCBHT, SEMIGRAND_MUT, USEROT, &
120:      &        SAVEMULTIMINONLY, GRADPROBLEMT, INTLJT, CONDATT, QCIPERMCHECK, RIGIDMBPOLT, &123:      &        SAVEMULTIMINONLY, GRADPROBLEMT, INTLJT, CONDATT, QCIPERMCHECK, &
121:      &        INTCONSTRAINTT, INTFREEZET, CHECKCONINT, CONCUTABST, CONCUTFRACT, INTERPCOSTFUNCTION, &124:      &        INTCONSTRAINTT, INTFREEZET, CHECKCONINT, CONCUTABST, CONCUTFRACT, INTERPCOSTFUNCTION, &
122:      &        RBAAT, FREEZENODEST, DUMPINTEOS, DUMPINTXYZ, QCIPOTT, QCIPOT2T, INTSPRINGACTIVET, LPERMDIST, LOCALPERMDIST, QCIRADSHIFTT, &125:      &        RBAAT, FREEZENODEST, DUMPINTEOS, DUMPINTXYZ, QCIPOTT, QCIPOT2T, INTSPRINGACTIVET, LPERMDIST, LOCALPERMDIST, QCIRADSHIFTT, &
123:      &        MLP3T, MKTRAPT, MLPB3T, MLPB3NEWT, MULTIPOTT, QCIAMBERT, MLPNEWREG, DJWRBT, STEALTHYT, LJADDT, QCINOREPINT, RIGIDMDT, &126:      &        MLP3T, MKTRAPT, MLPB3T, MLPB3NEWT, MULTIPOTT, QCIAMBERT, MLPNEWREG, DJWRBT, STEALTHYT, LJADDT, QCINOREPINT, RIGIDMDT, &
124:      &        DUMPMQT, MLQT, MLQPROB, LJADD2T, MLPVB3T, NOREGBIAS, PYADDT, PYADD2T, LJADD3T, REORDERADDT,  LJADD4T, &127:      &        DUMPMQT, MLQT, MLQPROB, LJADD2T, MLPVB3T, NOREGBIAS, PYADDT, PYADD2T, LJADD3T, REORDERADDT,  LJADD4T, &
125:      &        SQNMT, SQNM_DEBUGT, SQNM_BIOT, BENZRIGIDEWALDT, ORTHO, EWALDT, WATERMETHANET, MLPVB3NNT, CLATHRATET, LJADD3GUIDET128:      &        SQNMT, SQNM_DEBUGT, SQNM_BIOT, BENZRIGIDEWALDT, ORTHO, EWALDT, BOXDERIVT
126: !129: !
127:       DOUBLE PRECISION, ALLOCATABLE :: SEMIGRAND_MU(:)130:       DOUBLE PRECISION, ALLOCATABLE :: SEMIGRAND_MU(:)
128:       DOUBLE PRECISION, ALLOCATABLE :: ATMASS(:)131:       DOUBLE PRECISION, ALLOCATABLE :: ATMASS(:)
129:       DOUBLE PRECISION, ALLOCATABLE :: SPECMASS(:)132:       DOUBLE PRECISION, ALLOCATABLE :: SPECMASS(:)
130: 133: 
131: ! dj337: Ewald summation variables134: ! dj337: Ewald summation variables
132:       DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: RERHOARRAY, IMRHOARRAY135:       DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:,:) :: RERHOARRAY, IMRHOARRAY
133: 136: 
134: ! csw34> FREEZEGROUP variables137: ! csw34> FREEZEGROUP variables
135: !138: !
136:       INTEGER :: GROUPCENTRE139:       INTEGER :: GROUPCENTRE
137:       DOUBLE PRECISION :: GROUPRADIUS140:       DOUBLE PRECISION :: GROUPRADIUS
138:       CHARACTER (LEN=2) :: FREEZEGROUPTYPE141:       CHARACTER (LEN=2) :: FREEZEGROUPTYPE
139:       LOGICAL :: FREEZEGROUPT142:       LOGICAL :: FREEZEGROUPT
140: ! END143: ! END
141: 144: 
142: !145: !
143: ! csw34> DONTMOVE variables146: ! csw34> DONTMOVE variables
144: 147: !
145:       INTEGER :: NDONTMOVE, DONTMOVECENTRE148:       INTEGER :: NDONTMOVE, DONTMOVECENTRE
146:       DOUBLE PRECISION :: DONTMOVERADIUS149:       DOUBLE PRECISION :: DONTMOVERADIUS
147:       CHARACTER (LEN=2) :: DONTMOVEGROUPTYPE150:       CHARACTER (LEN=2) :: DONTMOVEGROUPTYPE
148:       LOGICAL :: DONTMOVET, DONTMOVEGROUPT, DONTMOVEREST, DONTMOVEALL, DOMOVEREST151:       LOGICAL :: DONTMOVET, DONTMOVEGROUPT, DONTMOVEREST, DONTMOVEALL, DOMOVEREST
149:       LOGICAL, ALLOCATABLE :: DONTMOVE(:),DONTMOVERES(:)152:       LOGICAL, ALLOCATABLE :: DONTMOVE(:),DONTMOVERES(:)
150:       INTEGER, ALLOCATABLE :: DUMPXYZUNIT(:), DUMPVUNIT(:)153:       INTEGER, ALLOCATABLE :: DUMPXYZUNIT(:), DUMPVUNIT(:)
151: !154: !
152: ! csw34> PAIRDIST variables155: ! csw34> PAIRDIST variables
153: !156: !
154:       INTEGER :: NPAIRS157:       INTEGER :: NPAIRS
358: !ds656> Stress tensor361: !ds656> Stress tensor
359:       LOGICAL :: STRESST362:       LOGICAL :: STRESST
360:       INTEGER :: STRESS_MODE363:       INTEGER :: STRESS_MODE
361:       DOUBLE PRECISION, ALLOCATABLE :: STRESS(:,:,:)364:       DOUBLE PRECISION, ALLOCATABLE :: STRESS(:,:,:)
362: 365: 
363: !ds656> A saw-tooth temperature protocol366: !ds656> A saw-tooth temperature protocol
364:       LOGICAL :: SAWTOOTH367:       LOGICAL :: SAWTOOTH
365:       INTEGER :: SAWTOOTH_NREJMAX368:       INTEGER :: SAWTOOTH_NREJMAX
366:       DOUBLE PRECISION :: SAWTOOTH_TMAX, SAWTOOTH_TFAC, &369:       DOUBLE PRECISION :: SAWTOOTH_TMAX, SAWTOOTH_TFAC, &
367:            SAWTOOTH_SFAC, SAWTOOTH_SFAC2370:            SAWTOOTH_SFAC, SAWTOOTH_SFAC2
368: !cv320> Variable for clathrates371: 
369:       INTEGER :: NWATER 
370: !ds656> Dump current Markov state at regular intervals372: !ds656> Dump current Markov state at regular intervals
371:       LOGICAL :: DUMP_MARKOV373:       LOGICAL :: DUMP_MARKOV
372:       INTEGER :: DUMP_MARKOV_NWAIT, DUMP_MARKOV_NFREQ374:       INTEGER :: DUMP_MARKOV_NWAIT, DUMP_MARKOV_NFREQ
373: 375: 
374: !   allocatables376: !   allocatables
375: 377: 
376:       INTEGER,ALLOCATABLE,DIMENSION(:) :: MOVABLEATOMLIST         ! a list containing the movable atom indices378:       INTEGER,ALLOCATABLE,DIMENSION(:) :: MOVABLEATOMLIST         ! a list containing the movable atom indices
377:       LOGICAL,ALLOCATABLE,DIMENSION(:) :: MOVABLEATOMLISTLOGICAL  ! is atom i movable?379:       LOGICAL,ALLOCATABLE,DIMENSION(:) :: MOVABLEATOMLISTLOGICAL  ! is atom i movable?
378:       INTEGER,ALLOCATABLE,DIMENSION(:) :: ATOMSINBLOCK            ! for BLOCKMOVE, to split movableatoms into separate blocks380:       INTEGER,ALLOCATABLE,DIMENSION(:) :: ATOMSINBLOCK            ! for BLOCKMOVE, to split movableatoms into separate blocks
379:       INTEGER,ALLOCATABLE,DIMENSION(:) :: NSPECIES(:), NSPECIES_INI(:)             ! for multicomponent systems381:       INTEGER,ALLOCATABLE,DIMENSION(:) :: NSPECIES(:), NSPECIES_INI(:)             ! for multicomponent systems
652:       INTEGER, ALLOCATABLE ::  MLPOUTCOME(:)654:       INTEGER, ALLOCATABLE ::  MLPOUTCOME(:)
653:       DOUBLE PRECISION, ALLOCATABLE ::  MLQDAT(:,:)655:       DOUBLE PRECISION, ALLOCATABLE ::  MLQDAT(:,:)
654:       INTEGER, ALLOCATABLE ::  MLQOUTCOME(:)656:       INTEGER, ALLOCATABLE ::  MLQOUTCOME(:)
655:       INTEGER, ALLOCATABLE ::  LJADDNN(:,:)657:       INTEGER, ALLOCATABLE ::  LJADDNN(:,:)
656: 658: 
657:       INTEGER, DIMENSION(:,:), ALLOCATABLE :: BONDS !for QCIAMBER659:       INTEGER, DIMENSION(:,:), ALLOCATABLE :: BONDS !for QCIAMBER
658: 660: 
659: !OPEP interface661: !OPEP interface
660:       LOGICAL :: OPEPT, OPEP_RNAT662:       LOGICAL :: OPEPT, OPEP_RNAT
661: 663: 
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(:,:,:) 
670: END MODULE COMMONS664: END MODULE COMMONS


r33135/ewald.f90 2017-08-07 17:30:34.929110014 +0100 r33134/ewald.f90 2017-08-07 17:30:45.753253779 +0100
  1: module ewald  1: module ewald
  2: use commons  2: use commons, only: natoms, stchrg, ortho, boxderivt, box_params, box_paramsgrad, &
   3: &                  ewaldalpha, ewaldrealc, ewaldrecipc
   4: 
  3: implicit none  5: implicit none
  4:   6: 
  5: contains  7: contains
  6:   8: 
  7: ! ---------------------------------------  9: ! -----------------------------------------------------------------------------------
  8: ! HELPER FUNCTIONS 10: ! dj337
  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 
 30:  11: 
 31: ! --------------------------------------- 12: ! COMPUTES ENERGY AND GRADIENT OF POTENTIALS USING EWALD SUMMATION.
 32: ! dj337: Computes the energy and gradient of potentials using Ewald summation. 
 33: ! Usable for any potential that satifisfies the equation: 13: ! Usable for any potential that satifisfies the equation:
 34: ! U_n = (1/2)*sum_L(sum_i,j(B_ij/(rij+L)**n)) 14: ! U_n = (1/2)*sum_L(sum_i,j(B_ij/(rij+L)**n))
 35: ! where n is any integer and L are lattice vectors. 15: ! where n is any integer and L are lattice vectors.
 36: ! A separate subroutine is used to calculate the special case for the 16: ! A separate subroutine is used to calculate the special case for the
 37: ! Coulomb potential (when n=1). 17: ! Coulomb potential (when n=1).
 38: ! 18: 
 39: ! All equations for Coulomb summation follow from: 19: ! All equations for energy and gradient of Coulomb summation follow from:
 40: ! Karasawa, N. and Goddard III, W. A. J. Phys. Chem., 93, 7320-7327 (1989). 20: ! Karasawa, N. and Goddard III, W. A. J. Phys. Chem., 93, 7320-7327 (1989).
 41: !  21:  
 42: ! All input / output are in Cartesian coordinates 22: ! All input / output are in absolute Cartesian coordinates.
 43: ! 23: 
 44: ! Assuming all units for length, charge, and energy are in atomic units. 24: ! Assuming all units for length, charge, and energy are in atomic units.
 45: ! --------------------------------------- 25: 
  26: ! Works for either orthorhombic or triclinic unit cells. Computes energy gradient wrt
  27: ! cell parameters when BOXDERIVT keyword is true.
  28: 
  29: ! NOTE: ERFC is the built-in complementary error function. If it is giving you an error
  30: ! during compilation, try updating to a newer version of your compiler!
  31: ! -----------------------------------------------------------------------------------
 46:       subroutine ewaldsum(n, x, g, etot, gtest) 32:       subroutine ewaldsum(n, x, g, etot, gtest)
 47:  33: 
 48:       use commons 34:       use cartdist, only: get_reciplatvec, build_H
 49:       use genrigid 
 50:  35: 
 51:       implicit none 36:       implicit none
 52:  37: 
 53:       integer                       :: n 38:       integer, intent(in)           :: n
 54:       logical                       :: gtest 39:       integer                       :: newaldreal(3), newaldrecip(3)
  40:       logical, intent(in)           :: gtest
 55:       double precision, intent(in)  :: x(3*natoms) 41:       double precision, intent(in)  :: x(3*natoms)
 56:       double precision, intent(out) :: g(3*natoms) 42:       double precision, intent(out) :: etot, g(3*natoms)
 57:       double precision, intent(out) :: etot 43:       double precision              :: H(3,3), H_grad(3,3,6)
  44:       double precision              :: reciplatvec(3,3), reciplatvec_grad(3,3,6)
  45:       double precision, parameter   :: pi = 3.141592654d0
 58:  46: 
 59:       etot = 0.0d0 47:       etot = 0.0d0
 60:       g(:) = 0.0d0 48:       g(:) = 0.0d0
 61:  49: 
 62:       if (n > 1) then 50:       if (n > 1) then
 63:          ! TODO: implement general Ewald summation 51:          ! TODO: implement general Ewald summation
 64:          print *, 'Ewald summation not yet implemented for n > 1!' 52:          print *, 'Ewald summation not yet implemented for n > 1!'
 65:          return 53:          return
 66:       else 54:       else
  55:          ! orthorhombic unit cell
 67:          if (ortho) then 56:          if (ortho) then
 68:             call coulombreal(x, etot) 57:             ! determine number of lattice vectors to sum over
 69:             call coulombrecip(x, etot) 58:             newaldreal(:) = floor(ewaldrealc/box_params(1:3) + 0.5d0)
  59:             ! compute real-space contribution to energy
  60:             call coulombreal_ortho(x, newaldreal, etot)
  61: 
  62:             ! determine number of reciprocal lattice vectors to sum over
  63:             newaldrecip(:) = floor(ewaldrecipc*box_params(1:3)/(2.0d0*pi))
  64:             ! compute reciprocal-space contribution to energy
  65:             !call coulombrecip_ortho(x, newaldrecip, etot)
  66: 
 70:             if (gtest) then 67:             if (gtest) then
 71:                call coulombrealgrad(x, g) 68:                ! compute real-space contribution to gradient
 72:                call coulombrecipgrad(x, g) 69:                call coulombrealgrad_ortho(x, newaldreal, g)
  70: 
  71:                ! compute reciprocal-space contribution to gradient
  72:                !call coulombrecipgrad_ortho(x, newaldrecip, g)
 73:             endif 73:             endif
  74:          ! triclinic unit cell
 74:          else 75:          else
 75:             ! TODO: implement Coulomb for non-orthogonal lattice vectors 76:             ! get reciprocal lattice vectors
 76:             print *, 'Ewald sums for Coulomb not yet implemented for non-orthorhombic!' 77:             call get_reciplatvec(reciplatvec, reciplatvec_grad, .false.)
 77:             return 78:             ! determine number of lattice vectors to sum over
 78:          endif 79:             newaldreal(1) = floor(ewaldrealc*dsqrt(sum(reciplatvec(1,:)**2))/(2.0d0*pi) + 0.5d0)
 79:       endif 80:             newaldreal(2) = floor(ewaldrealc*dsqrt(sum(reciplatvec(2,:)**2))/(2.0d0*pi) + 0.5d0)
  81:             newaldreal(3) = floor(ewaldrealc*dsqrt(sum(reciplatvec(3,:)**2))/(2.0d0*pi) + 0.5d0)
  82:             ! compute real-space contribution to energy
  83:             call coulombreal_tri(x, newaldreal, etot)
  84: 
  85:             ! get lattice vectors
  86:             call build_H(H, H_grad, .false.)
  87:             ! determine number of reciprocal lattice vectors to sum over
  88:             newaldrecip(1) = floor(ewaldrecipc*dsqrt(sum(H(1,:)**2))/(2.0d0*pi))
  89:             newaldrecip(2) = floor(ewaldrecipc*dsqrt(sum(H(2,:)**2))/(2.0d0*pi))
  90:             newaldrecip(3) = floor(ewaldrecipc*dsqrt(sum(H(3,:)**2))/(2.0d0*pi))
  91:             ! compute reciprocal-space contribution to energy
  92:             call coulombrecip_tri(x, newaldrecip, etot)
  93: 
  94:             if (gtest) then
  95:                ! compute real-space contribution to gradient
  96:                call coulombrealgrad_tri(x, newaldreal, g)
  97: 
  98:                ! compute reciprocal-space contribution to gradient
  99:                call coulombrecipgrad_tri(x, newaldrecip, g)
 100:             endif
 101:          endif ! ortho or triclinic
 102:       endif ! n < 1
 80: 103: 
 81:       return104:       return
 82:       end subroutine105:       end subroutine ewaldsum
 83: 106: 
 84: ! ---------------------------------------107: ! -----------------------------------------------------------------------------------
 85: ! dj337: Calculates energy contributions to Coulomb sum due to real-space108: ! Calculates short-range contribution to Coulomb sum energy. Also includes the self-
 86: ! sum (i.e. point charges screened by oppositely charged Gaussian cloud) 109: ! correction term and subtracts within-rigidbody interactions, if needed.
 87: ! and self correction. 
 88: ! 
 89: ! Assumes orthogonal lattice vectors. 
 90: ! --------------------------------------- 
 91:       subroutine coulombreal(x, ereal) 
 92: 110: 
 93:       use commons111: ! Assumes orthorhombic unit cell.
 94:       use genrigid, only: nrigidbody, nsiteperbody112: ! -----------------------------------------------------------------------------------
 113:       subroutine coulombreal_ortho(x, newaldreal, ereal)
 114: 
 115:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody
 95: 116: 
 96:       implicit none117:       implicit none
 97: 118: 
 98:       integer                         :: j1, j3, j2, j4, l, m, n, i119:       integer                         :: j1, j3, j2, j4, l, m, n, i
 120:       integer, intent(in)             :: newaldreal(3)
 99:       double precision, intent(in)    :: x(3*natoms)121:       double precision, intent(in)    :: x(3*natoms)
100:       double precision                :: rmin(3), r(3)122:       double precision                :: rmin(3), r(3)
101:       double precision                :: q1, q2, sumq2, dist, dist2, ewaldrealc2123:       double precision                :: q1, q2, sumq2, dist, dist2, ewaldrealc2
102:       double precision                :: vshift, esum, eself, ewrb124:       double precision                :: vshift, esum, eself, ewrb
103:       double precision, intent(inout) :: ereal125:       double precision, intent(inout) :: ereal
104:       double precision, parameter     :: pi = 3.141592654D0126:       double precision, parameter     :: pi = 3.141592654D0
105: 127: 
106:       ! real-space cutoff128:       ! real-space cutoff
107:       ewaldrealc2 = ewaldrealc**2129:       ewaldrealc2 = ewaldrealc**2
108:       esum = 0.0d0130:       esum = 0.0d0
117:          ! iterate over atoms i > j139:          ! iterate over atoms i > j
118:          do j2 = j1+1, natoms140:          do j2 = j1+1, natoms
119:             j4 = 3*j2141:             j4 = 3*j2
120:             q2 = stchrg(j2)142:             q2 = stchrg(j2)
121: 143: 
122:             ! get distance between atoms144:             ! get distance between atoms
123:             rmin(1) = x(j3-2)-x(j4-2)145:             rmin(1) = x(j3-2)-x(j4-2)
124:             rmin(2) = x(j3-1)-x(j4-1)146:             rmin(2) = x(j3-1)-x(j4-1)
125:             rmin(3) = x(j3)-x(j4)147:             rmin(3) = x(j3)-x(j4)
126:             ! minimum image convention148:             ! minimum image convention
127:             rmin(1) = rmin(1)-boxlx*anint(rmin(1)/boxlx)149:             rmin(1) = rmin(1)-box_params(1)*anint(rmin(1)/box_params(1))
128:             rmin(2) = rmin(2)-boxly*anint(rmin(2)/boxly)150:             rmin(2) = rmin(2)-box_params(2)*anint(rmin(2)/box_params(2))
129:             rmin(3) = rmin(3)-boxlz*anint(rmin(3)/boxlz)151:             rmin(3) = rmin(3)-box_params(3)*anint(rmin(3)/box_params(3))
130: 152: 
131:             ! calculate vertical shift153:             ! calculate vertical shift
132:             vshift = q1*q2*erfc(ewaldalpha*ewaldrealc)/ewaldrealc154:             vshift = q1*q2*erfc(ewaldalpha*ewaldrealc)/ewaldrealc
133: 155: 
134:             ! iterate over boxes156:             ! iterate over boxes
135:             do l = -newaldreal(1),newaldreal(1)157:             do l = -newaldreal(1), newaldreal(1)
136:                r(1) = rmin(1)+boxlx*l158:                r(1) = rmin(1)+box_params(1)*l
137:                do m = -newaldreal(2),newaldreal(2)159:                do m = -newaldreal(2), newaldreal(2)
138:                   r(2) = rmin(2)+boxly*m160:                   r(2) = rmin(2)+box_params(2)*m
139:                   do n = -newaldreal(3),newaldreal(3)161:                   do n = -newaldreal(3), newaldreal(3)
140:                      r(3) = rmin(3)+boxlz*n162:                      r(3) = rmin(3)+box_params(3)*n
141:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2163:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2
142:                      if (dist2 < ewaldrealc2) then164:                      if (dist2 < ewaldrealc2) then
143:                         dist = dsqrt(dist2)165:                         dist = dsqrt(dist2)
144:                         ! calculate short-range contribution166:                         ! calculate short-range contribution
145:                         ! note: don't need factor of 1/2 bc summing over j,i>j167:                         ! note: don't need factor of 1/2 bc summing over j,i>j
146:                         esum = esum + q1*q2*erfc(ewaldalpha*dist)/dist - vshift168:                         esum = esum + q1*q2*erfc(ewaldalpha*dist)/dist - vshift
147:                      endif169:                      endif ! within cutoff
148:                   enddo170:                   enddo ! n
149:                enddo171:                enddo ! m
150:             enddo172:             enddo ! l
151:          enddo173:          enddo ! atoms j
152:       enddo174:       enddo ! atoms i
153: 175: 
154:       ! include contribution due to interaction of j1 with periodic images of itself176:       ! include contribution due to interaction of j1 with periodic images of itself
155:       ! (separated due to efficiency)177:       ! (separated due to efficiency)
156:       ! U_periodic-self = 0.5*sum_L(erfc(alpha*rL)/rL)*sum_i(Qi**2)178:       ! U_periodic-self = 0.5*sum_L(erfc(alpha*rL)/rL)*sum_i(Qi**2)
157:       sumq2 = 0.0d0179:       sumq2 = 0.0d0
158:       do j1 = 1, natoms180:       do j1 = 1, natoms
159:         q1 = stchrg(j1)181:         q1 = stchrg(j1)
160:         sumq2 = sumq2 + q1*q1182:         sumq2 = sumq2 + q1*q1
161:       enddo183:       enddo
162: 184: 
163:       ! calculate vertical shift185:       ! calculate vertical shift
164:       vshift = erfc(ewaldalpha*ewaldrealc)/(2*ewaldrealc)186:       vshift = erfc(ewaldalpha*ewaldrealc)/(2*ewaldrealc)
165: 187: 
166:       eself = 0.0d0188:       eself = 0.0d0
167:       ! iterate over boxes189:       ! iterate over boxes
168:       do l = -newaldreal(1),newaldreal(1)190:       do l = -newaldreal(1), newaldreal(1)
169:          r(1) = boxlx*l191:          r(1) = box_params(1)*l
170:          do m = -newaldreal(2),newaldreal(2)192:          do m = -newaldreal(2), newaldreal(2)
171:             r(2) = boxly*m193:             r(2) = box_params(2)*m
172:             do n = -newaldreal(3),newaldreal(3)194:             do n = -newaldreal(3), newaldreal(3)
173:                r(3) = boxlz*n195:                r(3) = box_params(3)*n
174:                ! check not in central box196:                ! check not in central box
175:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then197:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
176:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2198:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2
177:                   if (dist2 < ewaldrealc2) then199:                   if (dist2 < ewaldrealc2) then
178:                      dist = dsqrt(dist2)200:                      dist = dsqrt(dist2)
179:                      ! calculate short-range contribution201:                      ! calculate short-range contribution
180:                      ! note: need factor of 1/2 to prevent double-counting202:                      ! note: need factor of 1/2 to prevent double-counting
181:                      eself = eself + erfc(ewaldalpha*dist)/(2.0d0*dist) - vshift203:                      eself = eself + erfc(ewaldalpha*dist)/(2.0d0*dist) - vshift
182:                   endif204:                   endif ! within cutoff
183:                endif205:                endif ! not in central box
184:             enddo206:             enddo ! n
185:          enddo207:          enddo ! m
186:       enddo208:       enddo ! l
187: 209: 
188:       esum = esum + sumq2*eself210:       esum = esum + sumq2*eself
189: 211: 
190:       ! compensate for within-rigidbody interactions212:       ! compensate for within-rigidbody interactions
191:       ! calculate within-rigidbody energy using exact Coulomb sum213:       ! calculate within-rigidbody energy using exact Coulomb sum
192:       ! U_wrb = sum_J(sum_i>j(Qij/rij))214:       ! U_wrb = sum_J(sum_i>j(Qij/rij))
193:       ! note: don't need factor of 1/2 because summing over i > j215:       ! note: don't need factor of 1/2 because summing over i > j
194:       ewrb = 0.0d0216:       if (rigidinit) then
195:       ! iterate over rigidbodies217:          ewrb = 0.0d0
196:       do i = 1, nrigidbody218:          ! iterate over rigidbodies
197: 219:          do i = 1, nrigidbody
198:          ! iterate over atoms i220:    
199:          do j1 = 1, nsiteperbody(i)221:             ! iterate over atoms i
200:             j3 = 3*j1222:             do j1 = 1, nsiteperbody(i)
201:             q1 = stchrg(j1)223:                j3 = 3*j1
202: 224:                q1 = stchrg(j1)
203:             ! iterate over atoms i > j225:    
204:             do j2 = j1+1, nsiteperbody(i)226:                ! iterate over atoms i > j
205:                j4 = 3*j2227:                do j2 = j1+1, nsiteperbody(i)
206:                q2 = stchrg(j2)228:                   j4 = 3*j2
207: 229:                   q2 = stchrg(j2)
208:                ! calculate rij230:    
209:                r(1) = x(j3-2)-x(j4-2)231:                   ! calculate rij
210:                r(2) = x(j3-1)-x(j4-1)232:                   r(1) = x(j3-2)-x(j4-2)
211:                r(3) = x(j3)-x(j4)233:                   r(2) = x(j3-1)-x(j4-1)
212:                dist2 = r(1)**2 + r(2)**2 + r(3)**2234:                   r(3) = x(j3)-x(j4)
213:                dist = dsqrt(dist2)235:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2
 236:                   dist = dsqrt(dist2)
 237:    
 238:                   ! calculate within-rigidbody contribution
 239:                   ewrb = ewrb + q1*q2/dist
 240:                enddo ! sites j
 241:             enddo ! sites i
 242:          enddo ! rigid bodies
 243:    
 244:          ! subtract U_wrb
 245:          esum = esum - ewrb
 246:       endif ! rigidinit
214: 247: 
215:                ! calculate within-rigidbody contribution248:       ! compensate for contribution due to self-interaction
216:                ewrb = ewrb + q1*q2/dist249:       ! U_self-interaction = -alpha*sum_i(Qi**2)/sqrt(pi)
217:             enddo250:       esum = esum - sumq2*ewaldalpha/dsqrt(pi)
218:          enddo251: 
 252:       ereal = ereal + esum
 253: 
 254:       return
 255:       end subroutine coulombreal_ortho
 256: 
 257: ! -----------------------------------------------------------------------------------
 258: ! Calculates short-range contribution to Coulomb sum energy. Also includes the self-
 259: ! correction term and subtracts within-rigidbody interactions, if needed.
 260: 
 261: ! Assumes triclinic unit cell.
 262: ! -----------------------------------------------------------------------------------
 263:       subroutine coulombreal_tri(x, newaldreal, ereal)
 264: 
 265:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, inversematrix
 266:       use cartdist, only: build_H
 267: 
 268:       implicit none
 269: 
 270:       integer                         :: j1, j3, j2, j4, l, m, n, i
 271:       integer, intent(in)             :: newaldreal(3)
 272:       double precision, intent(in)    :: x(3*natoms)
 273:       double precision                :: rr(3), rrfracmin(3), rfrac(3), r(3)
 274:       double precision                :: q1, q2, sumq2, dist, dist2, ewaldrealc2
 275:       double precision                :: vshift, esum, eself, ewrb
 276:       double precision                :: H(3,3), H_grad(3,3,6), H_inverse(3,3)
 277:       double precision, intent(inout) :: ereal
 278:       double precision, parameter     :: pi = 3.141592654D0
 279: 
 280:       ! real-space cutoff
 281:       ewaldrealc2 = ewaldrealc**2
 282:       esum = 0.0d0
 283: 
 284:       ! get H matrix and inverse
 285:       call build_H(H, H_grad, .false.)
 286:       call inversematrix(H, H_inverse)
 287: 
 288:       ! compute real-space sum
 289:       ! U_real-space = sum_L,i>j(Qij*erfc(alpha*rij)/rij)
 290:       ! iterate over atoms j
 291:       do j1 = 1, natoms
 292:          j3 = 3*j1
 293:          q1 = stchrg(j1)
 294: 
 295:          ! iterate over atoms i > j
 296:          do j2 = j1+1, natoms
 297:             j4 = 3*j2
 298:             q2 = stchrg(j2)
 299: 
 300:             ! get distance between atoms
 301:             rr(:) = x(j3-2:j3) - x(j4-2:j4)
 302:             ! convert to fractional coordinates
 303:             rrfracmin(:) = matmul(H_inverse, rr(:))
 304:             ! minimum image convention
 305:             rrfracmin(1) = rrfracmin(1) - anint(rrfracmin(1))
 306:             rrfracmin(2) = rrfracmin(2) - anint(rrfracmin(2))
 307:             rrfracmin(3) = rrfracmin(3) - anint(rrfracmin(3))
 308: 
 309:             ! calculate vertical shift
 310:             vshift = q1*q2*erfc(ewaldalpha*ewaldrealc)/ewaldrealc
 311: 
 312:             ! iterate over boxes
 313:             do l = -newaldreal(1), newaldreal(1)
 314:                rfrac(1) = rrfracmin(1) + l
 315:                do m = -newaldreal(2), newaldreal(2)
 316:                   rfrac(2) = rrfracmin(2) + m
 317:                   do n = -newaldreal(3), newaldreal(3)
 318:                      rfrac(3) = rrfracmin(3) + n
 319: 
 320:                      ! convert to absolute coordinates
 321:                      r(:) = matmul(H, rfrac(:))
 322: 
 323:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2
 324:                      if (dist2 < ewaldrealc2) then
 325:                         dist = dsqrt(dist2)
 326:                         ! calculate short-range contribution
 327:                         ! note: don't need factor of 1/2 bc summing over j,i>j
 328:                         esum = esum + q1*q2*erfc(ewaldalpha*dist)/dist - vshift
 329:                      endif ! within cutoff
 330:                   enddo ! n
 331:                enddo ! m
 332:             enddo ! l
 333:          enddo ! atoms j
 334:       enddo ! atoms i
 335: 
 336:       ! include contribution due to interaction of j1 with periodic images of itself
 337:       ! (separated due to efficiency)
 338:       ! U_periodic-self = 0.5*sum_L(erfc(alpha*rL)/rL)*sum_i(Qi**2)
 339:       sumq2 = 0.0d0
 340:       do j1 = 1, natoms
 341:         q1 = stchrg(j1)
 342:         sumq2 = sumq2 + q1*q1
219:       enddo343:       enddo
220: 344: 
221:       ! subtract U_wrb345:       ! calculate vertical shift
222:       esum = esum - ewrb346:       vshift = erfc(ewaldalpha*ewaldrealc)/(2*ewaldrealc)
 347: 
 348:       eself = 0.0d0
 349:       ! iterate over boxes
 350:       do l = -newaldreal(1), newaldreal(1)
 351:          rfrac(1) = l
 352:          do m = -newaldreal(2), newaldreal(2)
 353:             rfrac(2) = m
 354:             do n = -newaldreal(3), newaldreal(3)
 355:                rfrac(3) = n
 356: 
 357:                ! check not in central box
 358:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
 359:                   ! convert from fractional to absolute
 360:                   r(:) = matmul(H, rfrac(:))
 361: 
 362:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2
 363:                   if (dist2 < ewaldrealc2) then
 364:                      dist = dsqrt(dist2)
 365:                      ! calculate short-range contribution
 366:                      ! note: need factor of 1/2 to prevent double-counting
 367:                      eself = eself + erfc(ewaldalpha*dist)/(2.0d0*dist) - vshift
 368:                   endif ! within cutoff
 369:                endif ! not in central box
 370:             enddo ! n
 371:          enddo ! m
 372:       enddo ! l
 373: 
 374:       esum = esum + sumq2*eself
 375: 
 376:       ! compensate for within-rigidbody interactions
 377:       ! calculate within-rigidbody energy using exact Coulomb sum
 378:       ! U_wrb = sum_J(sum_i>j(Qij/rij))
 379:       ! note: don't need factor of 1/2 because summing over i > j
 380:       if (rigidinit) then
 381:          ewrb = 0.0d0
 382:          ! iterate over rigidbodies
 383:          do i = 1, nrigidbody
 384:    
 385:             ! iterate over atoms i
 386:             do j1 = 1, nsiteperbody(i)
 387:                j3 = 3*j1
 388:                q1 = stchrg(j1)
 389:    
 390:                ! iterate over atoms i > j
 391:                do j2 = j1+1, nsiteperbody(i)
 392:                   j4 = 3*j2
 393:                   q2 = stchrg(j2)
 394:    
 395:                   ! calculate rij
 396:                   r(1) = x(j3-2)-x(j4-2)
 397:                   r(2) = x(j3-1)-x(j4-1)
 398:                   r(3) = x(j3)-x(j4)
 399:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2
 400:                   dist = dsqrt(dist2)
 401:    
 402:                   ! calculate within-rigidbody contribution
 403:                   ewrb = ewrb + q1*q2/dist
 404:                enddo ! sites j
 405:             enddo ! sites i
 406:          enddo ! rigidbodies
 407:    
 408:          ! subtract U_wrb
 409:          esum = esum - ewrb
 410:       endif ! rigidinit
223: 411: 
224:       ! compensate for contribution due to self-interaction412:       ! compensate for contribution due to self-interaction
225:       ! U_self-interaction = -alpha*sum_i(Qi**2)/sqrt(pi)413:       ! U_self-interaction = -alpha*sum_i(Qi**2)/sqrt(pi)
226:       esum = esum - sumq2*ewaldalpha/dsqrt(pi)414:       esum = esum - sumq2*ewaldalpha/dsqrt(pi)
227: 415: 
228:       ereal = ereal + esum416:       ereal = ereal + esum
229: 417: 
230:       return418:       return
231:       end subroutine419:       end subroutine coulombreal_tri
232: 420: 
233: ! ---------------------------------------421: ! -----------------------------------------------------------------------------------
234: ! dj337: Calculates and stores terms that are needed to calculate structure422: ! Calculates and stores terms that are needed to calculate structure factors,
235: ! factors, S(k)S(-k). Because the coefficient of the Coulomb term satisfies 423: ! S(k) and S(-k), to facilitate the computation of the reciprocal-space part of the 
236: ! the geometric combination rule (i.e. Qij = sqrt(Qii*Qjj)), structure 424: ! Ewald sum.
237: ! factors can be used to greatly simplify the computation of the 425: 
238: ! reciprocal-space contributions to the energy and gradient.426: ! Because the coefficient of the Coulomb term satisfies the geometric combination rule,
239: !427: ! Q_ij = sqrt(Q_ii*Q_jj), a summation over two indices can be converted to two
240: ! Assumes orthogonal lattice vectors.428: ! summations over one index.
241: ! ---------------------------------------429: 
242:       subroutine ftdensity(x)430: ! Assumes orthorhombic unit cell.
 431: ! -----------------------------------------------------------------------------------
 432:       subroutine ftdensity_ortho(x, newaldrecip)
243: 433: 
244:       use commons 434:       use commons, only: rerhoarray, imrhoarray 
245: 435: 
246:       implicit none436:       implicit none
247: 437: 
248:       integer                      :: j1, j3, l, m, n438:       integer                      :: j1, j3, l, m, n, dims(3)
 439:       integer, intent(in)          :: newaldrecip(3)
249:       double precision, intent(in) :: x(3*natoms)440:       double precision, intent(in) :: x(3*natoms)
250:       double precision             :: k(3), r(3)441:       double precision             :: k(3), r(3)
251:       double precision             :: q1, k2, kdotr, rerho, imrho, ewaldrecipc2442:       double precision             :: q1, k2, kdotr, rerho, imrho, ewaldrecipc2
252:       double precision, parameter  :: pi = 3.141592654D0443:       double precision, parameter  :: pi = 3.141592654D0
253: 444: 
254:       ! reciprocal-space cutoff445:       ! reciprocal-space cutoff
255:       ewaldrecipc2 = ewaldrecipc**2446:       ewaldrecipc2 = ewaldrecipc**2
256: 447: 
 448:       ! make sure allocated arrays for structure factors are the correct size
 449:       dims(:) = 2*newaldrecip(1:3)+1 
 450:       if (.not.allocated(rerhoarray)) allocate(rerhoarray(dims(1), dims(2), dims(3)))
 451:       if (.not.allocated(imrhoarray)) allocate(imrhoarray(dims(1), dims(2), dims(3)))
 452: 
 453:       if (.not.(size(rerhoarray,1).eq.dims(1).and.size(rerhoarray,2).eq.dims(2).and.size(rerhoarray,3).eq.dims(3))) then
 454:          deallocate(rerhoarray) 
 455:          deallocate(imrhoarray)
 456:          allocate(rerhoarray(dims(1), dims(2), dims(3)))
 457:          allocate(imrhoarray(dims(1), dims(2), dims(3)))
 458:       endif
 459: 
257:       ! iterate over boxes and calculate reciprocal lattice vectors460:       ! iterate over boxes and calculate reciprocal lattice vectors
258:       ! note: because of anti/symmetry in sine and cosine functions,461:       ! note: because of anti/symmetry in sine and cosine functions,
259:       ! only need to calculate terms for half of the k-values462:       ! only need to calculate terms for half of the k-values
260:       do l = 0,newaldrecip(1)463:       do l = 0,newaldrecip(1)
261:          k(1) = 2*pi*l/boxlx464:          k(1) = 2*pi*l/box_params(1)
262:          do m = -newaldrecip(2),newaldrecip(2)465:          do m = -newaldrecip(2), newaldrecip(2)
263:             k(2) = 2*pi*m/boxly466:             k(2) = 2*pi*m/box_params(2)
264:             do n = -newaldrecip(3),newaldrecip(3)467:             do n = -newaldrecip(3), newaldrecip(3)
265:                k(3) = 2*pi*n/boxlz468:                k(3) = 2*pi*n/box_params(3)
266:                ! check not in central box469:                ! check not in central box
267:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then470:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
268:                   k2 = k(1)**2 + k(2)**2 + k(3)**2471:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
 472:                   rerho=0.0d0
 473:                   imrho=0.0d0
269:                   if (k2 < ewaldrecipc2) then474:                   if (k2 < ewaldrecipc2) then
270:                      rerho=0.0d0 
271:                      imrho=0.0d0 
272:                      ! iterate over atoms475:                      ! iterate over atoms
273:                      do j1 = 1, natoms476:                      do j1 = 1, natoms
274:                         j3 = 3*j1477:                         j3 = 3*j1
275:                         q1 = stchrg(j1)478:                         q1 = stchrg(j1)
276:                         r(1) = x(j3-2)479:                         r(:) = x(j3-2:j3)
277:                         r(2) = x(j3-1) 
278:                         r(3) = x(j3) 
279:                         ! dot product of k and ri480:                         ! dot product of k and ri
280:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3)481:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3)
281:                         ! rerho = sum_i(Qi*cos(k*ri))482:                         ! rerho = sum_i(Qi*cos(k*ri))
282:                         rerho = rerho + q1*dcos(kdotr)483:                         rerho = rerho + q1*dcos(kdotr)
283:                         ! imrho = sum_i(Qi*sin(k*ri))484:                         ! imrho = sum_i(Qi*sin(k*ri))
284:                         imrho = imrho + q1*dsin(kdotr)485:                         imrho = imrho + q1*dsin(kdotr)
285:                      enddo486:                      enddo ! atoms
286:                   endif487:                   endif ! within cutoff
287:                   ! store rerho and imrho values488:                   ! store rerho and imrho values
288:                   rerhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = rerho489:                   rerhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = rerho
289:                   rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = rerho490:                   rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = rerho
290:                   imrhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = -imrho491:                   imrhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = -imrho
291:                   imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = imrho492:                   imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = imrho
292:                endif493:                endif ! not in central box
293:             enddo494:             enddo ! n
294:          enddo495:          enddo ! m
295:       enddo496:       enddo ! l
 497: 
 498:       return
 499:       end subroutine ftdensity_ortho
 500: 
 501: ! -----------------------------------------------------------------------------------
 502: ! Calculates and stores terms that are needed to calculate structure factors,
 503: ! S(k) and S(-k) to facilitate the computation of the reciprocal-space part of the 
 504: ! Ewald sum.
 505: 
 506: ! Because the coefficient of the Coulomb term satisfies the geometric combination rule,
 507: ! Q_ij = sqrt(Q_ii*Q_jj), a summation over two indices can be converted to two
 508: ! summations over one index.
 509: 
 510: ! Assumes triclinic unit cell.
 511: ! -----------------------------------------------------------------------------------
 512:       subroutine ftdensity_tri(x, newaldrecip)
 513: 
 514:       use commons, only: rerhoarray, imrhoarray 
 515:       use cartdist, only: get_reciplatvec
 516: 
 517:       implicit none
 518: 
 519:       integer                      :: j1, j3, l, m, n, dims(3)
 520:       integer, intent(in)          :: newaldrecip(3)
 521:       double precision, intent(in) :: x(3*natoms)
 522:       double precision             :: k(3), r(3), reciplatvec(3,3), reciplatvec_grad(3,3,6)
 523:       double precision             :: q1, k2, kdotr, rerho, imrho, ewaldrecipc2
 524: 
 525:       ! reciprocal-space cutoff
 526:       ewaldrecipc2 = ewaldrecipc**2
 527: 
 528:       ! make sure allocated arrays for structure factors are the correct size
 529:       dims(:) = 2*newaldrecip(1:3)+1 
 530:       if (.not.allocated(rerhoarray)) allocate(rerhoarray(dims(1), dims(2), dims(3)))
 531:       if (.not.allocated(imrhoarray)) allocate(imrhoarray(dims(1), dims(2), dims(3)))
 532: 
 533:       if (.not.(size(rerhoarray,1).eq.dims(1).and.size(rerhoarray,2).eq.dims(2).and.size(rerhoarray,3).eq.dims(3))) then
 534:          deallocate(rerhoarray) 
 535:          deallocate(imrhoarray)
 536:          allocate(rerhoarray(dims(1), dims(2), dims(3)))
 537:          allocate(imrhoarray(dims(1), dims(2), dims(3)))
 538:       endif
 539: 
 540:       ! get reciprocal lattice vectors
 541:       call get_reciplatvec(reciplatvec, reciplatvec_grad, .false.)
 542: 
 543:       ! iterate over boxes and calculate reciprocal lattice vectors
 544:       ! note: because of anti/symmetry in sine and cosine functions,
 545:       ! only need to calculate terms for half of the k-values
 546:       do l = 0,newaldrecip(1)
 547:          do m = -newaldrecip(2), newaldrecip(2)
 548:             do n = -newaldrecip(3), newaldrecip(3)
 549:                ! check not in central box
 550:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
 551:                   k = l*reciplatvec(:,1) + m*reciplatvec(:,2) + n*reciplatvec(:,3)
 552:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
 553:                   rerho=0.0d0
 554:                   imrho=0.0d0
 555:                   if (k2 < ewaldrecipc2) then
 556:                      ! iterate over atoms
 557:                      do j1 = 1, natoms
 558:                         j3 = 3*j1
 559:                         q1 = stchrg(j1)
 560:                         r(:) = x(j3-2:j3)
 561:                         ! dot product of k and ri
 562:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3)
 563:                         ! rerho = sum_i(Qi*cos(k*ri))
 564:                         rerho = rerho + q1*dcos(kdotr)
 565:                         ! imrho = sum_i(Qi*sin(k*ri))
 566:                         imrho = imrho + q1*dsin(kdotr)
 567:                      enddo ! atoms
 568:                   endif ! within cutoff
 569:                   ! store rerho and imrho values
 570:                   rerhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = rerho
 571:                   rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = rerho
 572:                   imrhoarray(-l+newaldrecip(1)+1, -m+newaldrecip(2)+1, -n+newaldrecip(3)+1) = -imrho
 573:                   imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1) = imrho
 574:                endif ! not in central box
 575:             enddo ! n
 576:          enddo ! m
 577:       enddo ! l
296: 578: 
297:       return579:       return
298:       endsubroutine580:       end subroutine ftdensity_tri
 581: 
 582: ! -----------------------------------------------------------------------------------
 583: ! Calculates long-range contribution to Coulomb energy. Uses terms calculated by
 584: ! ftdensity_ortho subroutine (structure factors) to simplify computation.
 585: 
 586: ! Assumes orthorhombic unit cell.
 587: ! -----------------------------------------------------------------------------------
 588:       subroutine coulombrecip_ortho(x, newaldrecip, erecip)
299: 589: 
300: ! ---------------------------------------590:       use commons, only: rerhoarray, imrhoarray
301: ! dj337: Calculates energy contributions to Coulomb sum due to591:       use cartdist, only: get_volume
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) 
308: 592: 
309:       implicit none593:       implicit none
310: 594: 
311:       integer                         :: l, m, n595:       integer                         :: l, m, n
 596:       integer, intent(in)             :: newaldrecip(3)
312:       double precision, intent(in)    :: x(3*natoms)597:       double precision, intent(in)    :: x(3*natoms)
313:       double precision                :: k(3)598:       double precision                :: vol, ewaldrecipc2, k(3)
314:       double precision                :: vol, ewaldrecipc2 
315:       double precision                :: k2, rerho, imrho, esum599:       double precision                :: k2, rerho, imrho, esum
316:       double precision, intent(inout) :: erecip600:       double precision, intent(inout) :: erecip
317:       double precision, parameter     :: pi = 3.141592654D0601:       double precision, parameter     :: pi = 3.141592654D0
318: 602: 
319:       ! cell volume603:       ! cell volume
320:       call volume(vol)604:       call get_volume(vol)
321:       ! reciprocal-space cutoff605:       ! reciprocal-space cutoff
322:       ewaldrecipc2 = ewaldrecipc**2606:       ewaldrecipc2 = ewaldrecipc**2
323:       call ftdensity(x)607:       ! compute / store structure factors
 608:       call ftdensity_ortho(x, newaldrecip)
324:       esum = 0.0d0609:       esum = 0.0d0
325: 610: 
326:       ! compute reciprocal-space sum611:       ! compute reciprocal-space sum
327:       ! U_f = (2*pi/V)*(sum_k(exp(-k**2/4*alpha**2)*S(k)S(-k)/k**2)612:       ! U_f = (2*pi/V)*(sum_k(exp(-k**2/4*alpha**2)*S(k)S(-k)/k**2)
328:       ! iterate over boxes and calculate reciprocal lattice vectors613:       ! iterate over boxes and calculate reciprocal lattice vectors
329:       do l = -newaldrecip(1), newaldrecip(1)614:       do l = -newaldrecip(1), newaldrecip(1)
330:          k(1) = 2*pi*l/boxlx615:          k(1) = 2*pi*l/box_params(1)
331:          do m = -newaldrecip(2), newaldrecip(2)616:          do m = -newaldrecip(2), newaldrecip(2)
332:             k(2) = 2*pi*m/boxly617:             k(2) = 2*pi*m/box_params(2)
333:             do n = -newaldrecip(3), newaldrecip(3)618:             do n = -newaldrecip(3), newaldrecip(3)
334:                k(3) = 2*pi*n/boxlz619:                k(3) = 2*pi*n/box_params(3)
335:                ! check not in central box620:                ! check not in central box
336:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then621:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
337:                   k2 = k(1)**2 + k(2)**2 + k(3)**2622:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
338:                   if (k2 < ewaldrecipc2) then623:                   if (k2 < ewaldrecipc2) then
 624:                      ! get structure factors
339:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)625:                      rerho = rerhoarray(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)626:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)
341:                      ! calculate long-range contribution627:                      ! calculate long-range contribution
342:                      esum = esum + dexp(-k2/(4.0d0*ewaldalpha**2))*(rerho**2+imrho**2)/k2628:                      esum = esum + dexp(-k2/(4.0d0*ewaldalpha**2))*(rerho**2+imrho**2)/k2
343:                   endif629:                   endif ! within cutoff
344:                endif630:                endif ! not in central box
345:             enddo631:             enddo ! n
346:          enddo632:          enddo ! m
347:       enddo633:       enddo ! l
 634: 
 635:       ! multiply sum by factor of 2*pi/vol
 636:       erecip = erecip + 2.0d0*pi*esum/vol
 637: 
 638:       return
 639:       end subroutine coulombrecip_ortho
 640: 
 641: ! -----------------------------------------------------------------------------------
 642: ! Calculates long-range contribution to Coulomb energy. Uses terms calculated by
 643: ! ftdensity_ortho subroutine (structure factors) to simplify computation.
 644: 
 645: ! Assumes triclinic unit cell.
 646: ! -----------------------------------------------------------------------------------
 647:       subroutine coulombrecip_tri(x, newaldrecip, erecip)
 648: 
 649:       use commons, only: rerhoarray, imrhoarray
 650:       use cartdist, only: get_volume, get_reciplatvec
 651: 
 652:       implicit none
 653: 
 654:       integer                         :: l, m, n
 655:       integer, intent(in)             :: newaldrecip(3)
 656:       double precision, intent(in)    :: x(3*natoms)
 657:       double precision                :: reciplatvec(3,3), reciplatvec_grad(3,3,6), k(3)
 658:       double precision                :: vol, ewaldrecipc2, k2, rerho, imrho, esum
 659:       double precision, intent(inout) :: erecip
 660:       double precision, parameter     :: pi = 3.141592654D0
 661: 
 662:       ! cell volume
 663:       call get_volume(vol)
 664:       ! reciprocal lattice vectors
 665:       call get_reciplatvec(reciplatvec, reciplatvec_grad, .false.)
 666:       ! reciprocal-space cutoff
 667:       ewaldrecipc2 = ewaldrecipc**2
 668:       ! compute / store structure factors
 669:       call ftdensity_tri(x, newaldrecip)
 670:       esum = 0.0d0
 671: 
 672:       ! compute reciprocal-space sum
 673:       ! U_f = (2*pi/V)*(sum_k(exp(-k**2/4*alpha**2)*S(k)S(-k)/k**2)
 674:       ! iterate over boxes and calculate reciprocal lattice vectors
 675:       do l = -newaldrecip(1), newaldrecip(1)
 676:          do m = -newaldrecip(2), newaldrecip(2)
 677:             do n = -newaldrecip(3), newaldrecip(3)
 678:                ! check not in central box
 679:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
 680:                   k = l*reciplatvec(:,1) + m*reciplatvec(:,2) + n*reciplatvec(:,3)
 681:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
 682:                   if (k2 < ewaldrecipc2) then
 683:                      ! get structure factors
 684:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)
 685:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)
 686:                      ! calculate long-range contribution
 687:                      esum = esum + dexp(-k2/(4.0d0*ewaldalpha**2))*(rerho**2+imrho**2)/k2
 688:                   endif ! within cutoff
 689:                endif ! not in central box
 690:             enddo ! n
 691:          enddo ! m
 692:       enddo ! l
348: 693: 
349:       ! multiply sum by factor of 2*pi/vol694:       ! multiply sum by factor of 2*pi/vol
350:       erecip = erecip + 2.0d0*pi*esum/vol695:       erecip = erecip + 2.0d0*pi*esum/vol
351: 696: 
352:       return697:       return
353:       end subroutine698:       end subroutine coulombrecip_tri
354: 699: 
355: ! ---------------------------------------700: ! -----------------------------------------------------------------------------------
356: ! dj337: Calculates the real-space contribution to the gradient701: ! Calculates the real-space contribution to the gradient with respects to atomic
357: ! of the Coulomb sum. 702: ! positions. Also calculates real-space contribution to the gradient wrt lattice
358: !703: ! vectors, if BOXDERIVT is true.
359: ! Assumes orthogonal lattice vectors.704: 
360: ! ---------------------------------------705: ! Assumes orthorhombic unit cell.
361:       subroutine coulombrealgrad(x, g)706: ! -----------------------------------------------------------------------------------
 707:       subroutine coulombrealgrad_ortho(x, newaldreal, g)
362: 708: 
363:       use commons709:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, gr_weights
364: 710: 
365:       implicit none711:       implicit none
366: 712: 
367:       integer                         :: j1, j3, j2, j4, l, m, n713:       integer                         :: j1, j3, j2, j4, l, m, n
 714:       integer, intent(in)             :: newaldreal(3)
368:       double precision, intent(in)    :: x(3*natoms)715:       double precision, intent(in)    :: x(3*natoms)
369:       double precision, intent(inout) :: g(3*natoms)716:       double precision, intent(inout) :: g(3*natoms)
370:       double precision                :: r(3), rmin(3), f(3)717:       double precision                :: com(3), mass, comcoords(3*natoms)
371:       double precision                :: ewaldrealc2718:       double precision                :: rss(3), rmin(3), r(3), rcommin(3), rcom(3), f(3)
372:       double precision                :: q1, q2, mul, dist, dist2719:       double precision                :: ewaldrealc2, q1, q2, mul, dist, dist2
373:       double precision, parameter     :: pi = 3.141592654d0720:       double precision, parameter     :: pi = 3.141592654d0
374: 721: 
 722:       ! if rigid bodies, calculate COM coordinates
 723:       ! to compute box derivatives
 724:       if (rigidinit.and.boxderivt) then
 725:          do j1 = 1, nrigidbody
 726:             ! calculate COM
 727:             com(:) = 0.0d0
 728:             mass = 0.0d0
 729:             do j2 = 1, nsiteperbody(j1)
 730:                j3 = rigidgroups(j2, j1)
 731:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3)
 732:                mass = mass + gr_weights(j3)
 733:             enddo
 734:             com(1:3) = com(1:3) / mass
 735:             ! store COM coords
 736:             do j2 = 1, nsiteperbody(j1)
 737:                j3 = rigidgroups(j2, j1)
 738:                comcoords(3*j3-2:3*j3) = com(1:3)
 739:             enddo
 740:          enddo
 741:       endif
 742: 
375:       ! real-space cutoff743:       ! real-space cutoff
376:       ewaldrealc2 = ewaldrealc**2744:       ewaldrealc2 = ewaldrealc**2
377: 745: 
378:       ! compute real-space contribution to gradient746:       ! compute real-space contribution to gradient
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))747:       ! G_r = sum_L,i>j(-Qij*r*((erfc(alpha*rij)/(alpha*dist)**3) + 2*alpha*exp(-(alpha*rij)**2)/(sqrt(pi)*rij**2))
380:       ! iterate over atoms i748:       ! iterate over atoms i
381:       do j1 = 1, natoms749:       do j1 = 1, natoms
382:          j3 = 3*j1750:          j3 = 3*j1
383:          q1 = stchrg(j1)751:          q1 = stchrg(j1)
384: 752: 
385:          ! iterate over atoms i > j753:          ! iterate over atoms i > j
386:          do j2 = j1+1, natoms754:          do j2 = j1+1, natoms
387:             j4 = 3*j2755:             j4 = 3*j2
388:             q2 = stchrg(j2)756:             q2 = stchrg(j2)
389: 757: 
390:             ! get distance between atoms758:             ! get distance between atoms
391:             rmin(1) = x(j3-2)-x(j4-2)759:             rss(1) = x(j3-2)-x(j4-2)
392:             rmin(2) = x(j3-1)-x(j4-1)760:             rss(2) = x(j3-1)-x(j4-1)
393:             rmin(3) = x(j3)-x(j4)761:             rss(3) = x(j3)-x(j4) 
394:             ! minimum image convention762:             ! minimum image convention
395:             rmin(1) = rmin(1)-boxlx*anint(rmin(1)/boxlx)763:             rmin(1) = rss(1) - box_params(1)*anint(rss(1)/box_params(1))
396:             rmin(2) = rmin(2)-boxly*anint(rmin(2)/boxly)764:             rmin(2) = rss(2) - box_params(2)*anint(rss(2)/box_params(2))
397:             rmin(3) = rmin(3)-boxlz*anint(rmin(3)/boxlz)765:             rmin(3) = rss(3) - box_params(3)*anint(rss(3)/box_params(3))
 766: 
 767:             ! get minimum distance between COM
 768:             ! NOTE: use rss for minimum image convention to ensure COM corresponds to right atoms
 769:             if (rigidinit.and.boxderivt) then
 770:                rcommin(1) = comcoords(j3-2)-comcoords(j4-2) - box_params(1)*anint(rss(1)/box_params(1))
 771:                rcommin(2) = comcoords(j3-1)-comcoords(j4-1) - box_params(2)*anint(rss(2)/box_params(2))
 772:                rcommin(3) = comcoords(j3)-comcoords(j4) - box_params(3)*anint(rss(3)/box_params(3))
 773:             endif
398: 774: 
399:             ! get gradient contribution per box775:             ! get gradient contribution per box
400:             f(:) = 0.0d0776:             f(:) = 0.0d0
401: 777: 
402:             ! iterate over boxes778:             ! iterate over boxes
403:             do l = -newaldreal(1),newaldreal(1)779:             do l = -newaldreal(1), newaldreal(1)
404:                r(1) = rmin(1)+boxlx*l780:                r(1) = rmin(1)+box_params(1)*l
405:                do m = -newaldreal(2),newaldreal(2)781:                do m = -newaldreal(2), newaldreal(2)
406:                   r(2) = rmin(2)+boxly*m782:                   r(2) = rmin(2)+box_params(2)*m
407:                   do n = -newaldreal(3),newaldreal(3)783:                   do n = -newaldreal(3), newaldreal(3)
408:                      r(3) = rmin(3)+boxlz*n784:                      r(3) = rmin(3)+box_params(3)*n
 785: 
 786:                      if (rigidinit.and.boxderivt) then
 787:                         rcom(1) = rcommin(1)+box_params(1)*l
 788:                         rcom(2) = rcommin(2)+box_params(2)*m
 789:                         rcom(3) = rcommin(3)+box_params(3)*n
 790:                      endif
 791: 
409:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2792:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2
410:                      if (dist2 < ewaldrealc2) then793:                      if (dist2 < ewaldrealc2) then
411:                         dist = dsqrt(dist2)794:                         dist = dsqrt(dist2)
412:                         ! calculate short-range gradient contribution per box795:                         ! calculate short-range gradient contribution per box
413:                         mul = q1*q2*(erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist**2))796:                         mul = q1*q2*(erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2))
414:                         f(1) = f(1) + mul*r(1)797:                         f(1) = f(1) + mul*r(1)
415:                         f(2) = f(2) + mul*r(2)798:                         f(2) = f(2) + mul*r(2)
416:                         f(3) = f(3) + mul*r(3)799:                         f(3) = f(3) + mul*r(3)
417:                      endif800: 
418:                   enddo801:                         ! compute contribution to box derivatives
419:                enddo802:                         if (boxderivt) then
420:             enddo803:                            if (rigidinit) then
 804:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) - mul*r(1:3)*rcom(1:3)/box_params(1:3)
 805:                            else ! not rigid bodies
 806:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) - mul*r(1:3)*r(1:3)/box_params(1:3)
 807:                            endif 
 808:                         endif 
 809: 
 810:                      endif ! within cutoff
 811:                   enddo ! n
 812:                enddo ! m
 813:             enddo ! l
421: 814: 
422:             ! add gradient contribution815:             ! add gradient contribution
423:             g(j3-2) = g(j3-2)-f(1)816:             g(j3-2) = g(j3-2)-f(1)
424:             g(j3-1) = g(j3-1)-f(2)817:             g(j3-1) = g(j3-1)-f(2)
425:             g(j3)   = g(j3)-f(3)818:             g(j3)   = g(j3)-f(3)
426:             g(j4-2) = g(j4-2)+f(1)819:             g(j4-2) = g(j4-2)+f(1)
427:             g(j4-1) = g(j4-1)+f(2)820:             g(j4-1) = g(j4-1)+f(2)
428:             g(j4)   = g(j4)+f(3)821:             g(j4)   = g(j4)+f(3)
429:          enddo822:          enddo ! atoms j
430:       enddo823:       enddo ! atoms i
431: 824: 
432:       ! include contribution due to interaction of j1 with periodic images of itself825:       ! include contribution due to interaction of j1 with periodic images of itself
433:       ! (separated due to efficiency)826:       ! (separated due to efficiency)
434:       ! G_periodic-self = sum_L(Qi**2*rL*(erfc(alpha*rL)/rL**3 + 2*alpha*exp(-(alpha*rL)**2)/(sqrt(pi)*rL**2)))827:       ! G_periodic-self = sum_L(Qi**2*rL*(erfc(alpha*rL)/rL**3 + 2*alpha*exp(-(alpha*rL)**2)/(sqrt(pi)*rL**2)))
435:       ! iterate over boxes828:       ! iterate over boxes
436:       do l = -newaldreal(1),newaldreal(1)829:       do l = -newaldreal(1), newaldreal(1)
437:          rmin(1) = boxlx*l830:          rmin(1) = box_params(1)*l
438:          do m = -newaldreal(2),newaldreal(2)831:          do m = -newaldreal(2), newaldreal(2)
439:             rmin(2) = boxly*m832:             rmin(2) = box_params(2)*m
440:             do n = -newaldreal(3),newaldreal(3)833:             do n = -newaldreal(3), newaldreal(3)
441:                rmin(3) = boxlz*n834:                rmin(3) = box_params(3)*n
442:                ! check not in central box835:                ! check not in central box
443:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then836:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
444:                   dist2 = rmin(1)**2 + rmin(2)**2 + rmin(3)**2837:                   dist2 = rmin(1)**2 + rmin(2)**2 + rmin(3)**2
445:                   if (dist2 < ewaldrealc2) then838:                   if (dist2 < ewaldrealc2) then
446:                      dist = dsqrt(dist2)839:                      dist = dsqrt(dist2)
447:                      mul = erfc(ewaldalpha*dist)/dist**2 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist**2)840: 
 841:                      if (rigidinit.and.boxderivt) then
 842:                         rcom(1) = box_params(1)*l
 843:                         rcom(2) = box_params(2)*m
 844:                         rcom(3) = box_params(3)*n
 845:                      endif
 846: 
 847:                      mul = erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2)
448:                      ! iterate over atoms and calculate gradient terms848:                      ! iterate over atoms and calculate gradient terms
449:                      do j1 = 1, natoms849:                      do j1 = 1, natoms
450:                         j3 = 3*j1850:                         j3 = 3*j1
451:                         q1 = stchrg(j1)851:                         q1 = stchrg(j1)
452:                         g(j3-2) = g(j3-2) - q1*q1*mul*rmin(1)852:                         g(j3-2) = g(j3-2) - q1*q1*mul*rmin(1)
453:                         g(j3-1) = g(j3-1) - q1*q1*mul*rmin(2)853:                         g(j3-1) = g(j3-1) - q1*q1*mul*rmin(2)
454:                         g(j3)   = g(j3)   - q1*q1*mul*rmin(3)854:                         g(j3)   = g(j3)   - q1*q1*mul*rmin(3)
455:                      enddo855: 
456:                   endif856:                         ! compute contribution to box derivatives
457:                endif857:                         if (boxderivt) then
 858:                            if (rigidinit) then
 859:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) - q1*q1*mul*rmin(1:3)*rcom(1:3)/box_params(1:3)
 860:                            else ! not rigid bodies
 861:                               box_paramsgrad(1:3) = box_paramsgrad(1:3) - q1*q1*mul*rmin(1:3)*rmin(1:3)/box_params(1:3)
 862:                            endif
 863:                         endif 
 864: 
 865:                      enddo ! atoms
 866:                   endif ! within cutoff
 867:                endif ! not in central box
 868:             enddo ! n
 869:          enddo ! m
 870:       enddo ! l
 871: 
 872:       return
 873:       end subroutine coulombrealgrad_ortho
 874: 
 875: ! -----------------------------------------------------------------------------------
 876: ! Calculates the real-space contribution to the gradient with respects to atomic
 877: ! positions. Also calculates real-space contribution to the gradient wrt lattice
 878: ! vectors, if BOXDERIVT is true.
 879: 
 880: ! Assumes triclinic unit cell.
 881: ! -----------------------------------------------------------------------------------
 882:       subroutine coulombrealgrad_tri(x, newaldreal, g)
 883: 
 884:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, &
 885:       &                   gr_weights, inversematrix
 886:       use cartdist, only: build_H
 887: 
 888:       implicit none
 889: 
 890:       integer                         :: j1, j3, j2, j4, l, m, n, idx
 891:       integer, intent(in)             :: newaldreal(3)
 892:       double precision, intent(in)    :: x(3*natoms)
 893:       double precision, intent(inout) :: g(3*natoms)
 894:       double precision                :: com(3), mass, comcoords(3*natoms)
 895:       double precision                :: rr(3), rrfrac(3), rrfracmin(3), r(3), f(3)
 896:       double precision                :: rcom(3), rcomfracmin(3), rcomfrac(3)
 897:       double precision                :: H(3,3), H_grad(3,3,6), H_inverse(3,3)
 898:       double precision                :: ewaldrealc2, q1, q2, mul, dist, dist2
 899:       double precision, parameter     :: pi = 3.141592654d0
 900: 
 901:       ! if rigid bodies, calculate COM coordinates
 902:       ! to compute box derivatives
 903:       if (rigidinit.and.boxderivt) then
 904:          do j1 = 1, nrigidbody
 905:             ! calculate COM
 906:             com(:) = 0.0d0
 907:             mass = 0.0d0
 908:             do j2 = 1, nsiteperbody(j1)
 909:                j3 = rigidgroups(j2, j1)
 910:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3)
 911:                mass = mass + gr_weights(j3)
 912:             enddo
 913:             com(1:3) = com(1:3) / mass
 914:             ! store COM coords
 915:             do j2 = 1, nsiteperbody(j1)
 916:                j3 = rigidgroups(j2, j1)
 917:                comcoords(3*j3-2:3*j3) = com(1:3)
458:             enddo918:             enddo
459:          enddo919:          enddo
460:       enddo920:       endif
461: 921: 
462:       return922:       ! real-space cutoff
463:       endsubroutine923:       ewaldrealc2 = ewaldrealc**2
 924: 
 925:       ! get H matrix and inverse
 926:       call build_H(H, H_grad, boxderivt)
 927:       call inversematrix(H, H_inverse)
 928: 
 929:       ! compute real-space contribution to gradient
 930:       ! G_r = sum_L,i>j(-Qij*r*((erfc(alpha*rij)/(alpha*dist)**3) + 2*alpha*exp(-(alpha*rij)**2)/(sqrt(pi)*rij**2))
 931:       ! iterate over atoms i
 932:       do j1 = 1, natoms
 933:          j3 = 3*j1
 934:          q1 = stchrg(j1)
464: 935: 
465: ! ---------------------------------------936:          ! iterate over atoms i > j
466: ! dj337: Calculates the reipcrocal-space contribution to the gradient937:          do j2 = j1+1, natoms
467: ! of the Coulomb sum. Uses terms calculated by ftdensity subroutine938:             j4 = 3*j2
468: ! to use structure factors to simplify computation.939:             q2 = stchrg(j2)
469: !940: 
470: ! Assumes orthogonal lattice vectors.941:             ! get distance between atoms
471: ! ---------------------------------------942:             rr(:) = x(j3-2:j3) - x(j4-2:j4)
472:       subroutine coulombrecipgrad(x, g)943:             ! convert to fractional coordinates
 944:             rrfrac(:) = matmul(H_inverse, rr(:))
 945:             ! minimum image convention
 946:             rrfracmin(1) = rrfrac(1) - anint(rrfrac(1))
 947:             rrfracmin(2) = rrfrac(2) - anint(rrfrac(2))
 948:             rrfracmin(3) = rrfrac(3) - anint(rrfrac(3))
 949: 
 950:             ! get minimum distance between COM
 951:             if (rigidinit.and.boxderivt) then
 952:                rcom(:) = comcoords(j3-2:j3) - comcoords(j4-2:j4)
 953:                ! convert to fractional coords
 954:                rcomfracmin(:) = matmul(H_inverse, rcom(:))
 955:                ! minimum image convention
 956:                ! NOTE: use rrfrac for minimum image convention to ensure COM corresponds to right atoms
 957:                rcomfracmin(1) = rcomfracmin(1) - anint(rrfrac(1))
 958:                rcomfracmin(2) = rcomfracmin(2) - anint(rrfrac(2))
 959:                rcomfracmin(3) = rcomfracmin(3) - anint(rrfrac(3))
 960:             endif
 961: 
 962:             ! get gradient contribution per box
 963:             f(:) = 0.0d0
 964: 
 965:             ! iterate over boxes
 966:             do l = -newaldreal(1), newaldreal(1)
 967:                rrfrac(1) = rrfracmin(1) + l
 968:                do m = -newaldreal(2), newaldreal(2)
 969:                   rrfrac(2) = rrfracmin(2) + m
 970:                   do n = -newaldreal(3), newaldreal(3)
 971:                      rrfrac(3) = rrfracmin(3) + n
 972: 
 973:                      ! convert to absolute coordinates
 974:                      r(:) = matmul(H, rrfrac(:))
 975: 
 976:                      if (rigidinit.and.boxderivt) then
 977:                         rcomfrac(1) = rcomfracmin(1) + l
 978:                         rcomfrac(2) = rcomfracmin(2) + m
 979:                         rcomfrac(3) = rcomfracmin(3) + n
 980:                      endif
 981: 
 982:                      dist2 = r(1)**2 + r(2)**2 + r(3)**2
 983:                      if (dist2 < ewaldrealc2) then
 984:                         dist = dsqrt(dist2)
 985:                         ! calculate short-range gradient contribution per box
 986:                         mul = q1*q2*(erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2))
 987:                         f(1) = f(1) + mul*r(1)
 988:                         f(2) = f(2) + mul*r(2)
 989:                         f(3) = f(3) + mul*r(3)
473: 990: 
474:       use commons991:                         ! compute contribution to box derivatives
 992:                         if (boxderivt) then
 993:                            if (rigidinit) then
 994:                               ! iterate over cell parameters
 995:                               do idx = 1,6
 996:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx),rcomfrac))
 997:                               enddo
 998:                            else ! not rigid bodies
 999:                               ! iterate over cell parameters
 1000:                               do idx = 1, 6
 1001:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx), rrfrac))
 1002:                               enddo
 1003:                            endif 
 1004:                         endif 
 1005: 
 1006:                      endif ! within cutoff
 1007:                   enddo ! n
 1008:                enddo ! m
 1009:             enddo ! l
 1010: 
 1011:             ! add gradient contribution
 1012:             g(j3-2) = g(j3-2)-f(1)
 1013:             g(j3-1) = g(j3-1)-f(2)
 1014:             g(j3)   = g(j3)-f(3)
 1015:             g(j4-2) = g(j4-2)+f(1)
 1016:             g(j4-1) = g(j4-1)+f(2)
 1017:             g(j4)   = g(j4)+f(3)
 1018:          enddo ! atoms j
 1019:       enddo ! atoms i
 1020: 
 1021:       ! include contribution due to interaction of j1 with periodic images of itself
 1022:       ! (separated due to efficiency)
 1023:       ! G_periodic-self = sum_L(Qi**2*rL*(erfc(alpha*rL)/rL**3 + 2*alpha*exp(-(alpha*rL)**2)/(sqrt(pi)*rL**2)))
 1024:       ! iterate over boxes
 1025:       do l = -newaldreal(1), newaldreal(1)
 1026:          rrfrac(1) = l
 1027:          do m = -newaldreal(2), newaldreal(2)
 1028:             rrfrac(2) = m
 1029:             do n = -newaldreal(3), newaldreal(3)
 1030:                rrfrac(3) = n
 1031:                ! check not in central box
 1032:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
 1033:                   ! convert from fractional to absolute
 1034:                   r(:) = matmul(H, rrfrac(:))
 1035: 
 1036:                   dist2 = r(1)**2 + r(2)**2 + r(3)**2
 1037:                   if (dist2 < ewaldrealc2) then
 1038:                      dist = dsqrt(dist2)
 1039: 
 1040:                      if (rigidinit.and.boxderivt) then
 1041:                         rcomfrac(1) = l
 1042:                         rcomfrac(2) = m
 1043:                         rcomfrac(3) = n
 1044:                      endif
 1045: 
 1046:                      mul = erfc(ewaldalpha*dist)/dist**3 + 2.0d0*ewaldalpha*dexp(-(ewaldalpha*dist)**2)/(dsqrt(pi)*dist2)
 1047:                      ! iterate over atoms and calculate gradient terms
 1048:                      do j1 = 1, natoms
 1049:                         j3 = 3*j1
 1050:                         q1 = stchrg(j1)
 1051:                         g(j3-2) = g(j3-2) - q1*q1*mul*r(1)
 1052:                         g(j3-1) = g(j3-1) - q1*q1*mul*r(2)
 1053:                         g(j3)   = g(j3)   - q1*q1*mul*r(3)
 1054: 
 1055:                         ! compute contribution to box derivatives
 1056:                         if (boxderivt) then
 1057:                            if (rigidinit) then
 1058:                               ! iterate over cell parameters
 1059:                               do idx = 1,6
 1060:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx),rcomfrac))
 1061:                               enddo
 1062:                            else ! not rigid bodies
 1063:                               ! iterate over cell parameters
 1064:                               do idx = 1, 6
 1065:                                  box_paramsgrad(idx) = box_paramsgrad(idx) - mul*dot_product(r(:), matmul(H_grad(:,:,idx), rrfrac))
 1066:                               enddo
 1067:                            endif
 1068:                         endif
 1069: 
 1070:                      enddo ! atoms
 1071:                   endif ! within cutoff
 1072:                endif ! not in central box
 1073:             enddo ! n
 1074:          enddo ! m
 1075:       enddo ! l
 1076: 
 1077:       return
 1078:       end subroutine coulombrealgrad_tri
 1079: 
 1080: ! -----------------------------------------------------------------------------------
 1081: ! Calculates the reciprocal-space contribution to the gradient with respects to atomic
 1082: ! positions. Also calculates reciprocal-space contribution to the gradient wrt lattice
 1083: ! vectors, if BOXDERIVT is true. Uses structure factors to simplify computation.
 1084: 
 1085: ! Assumes orthorhombic unit cell.
 1086: ! -----------------------------------------------------------------------------------
 1087:       subroutine coulombrecipgrad_ortho(x, newaldrecip, g)
 1088: 
 1089:       use commons, only: rerhoarray, imrhoarray
 1090:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, gr_weights
 1091:       use cartdist, only: get_volume
475: 1092: 
476:       implicit none1093:       implicit none
477: 1094: 
478:       integer                         :: l, m, n, j1, j31095:       integer                         :: l, m, n, j1, j2, j3
 1096:       integer, intent(in)             :: newaldrecip(3)
479:       double precision, intent(in)    :: x(3*natoms)1097:       double precision, intent(in)    :: x(3*natoms)
480:       double precision, intent(inout) :: g(3*natoms)1098:       double precision, intent(inout) :: g(3*natoms)
481:       double precision                :: k(3), r(3)1099:       double precision                :: vol, ewaldrecipc2, k(3), r(3)
482:       double precision                :: vol, ewaldrecipc2 
483:       double precision                :: k2, kdotr, rerho, imrho, q1, mul, mul21100:       double precision                :: k2, kdotr, rerho, imrho, q1, mul, mul2
 1101:       double precision                :: com(3), mass, comcoords(3*natoms)
484:       double precision, parameter     :: pi = 3.141592654D01102:       double precision, parameter     :: pi = 3.141592654D0
485: 1103: 
486:       ! cell volume1104:       ! cell volume
487:       call volume (vol)1105:       call get_volume(vol)
488:       ! reciprocal-space cutoff1106:       ! reciprocal-space cutoff
489:       ewaldrecipc2 = ewaldrecipc**21107:       ewaldrecipc2 = ewaldrecipc**2
490: 1108: 
 1109:       ! if rigid bodies, compute COM coords
 1110:       ! to compute box derivatives
 1111:       if (rigidinit.and.boxderivt) then
 1112:          do j1 = 1, nrigidbody
 1113:             com(:) = 0.0d0
 1114:             mass = 0.0d0
 1115:             ! compute COM
 1116:             do j2 = 1, nsiteperbody(j1)
 1117:                j3 = rigidgroups(j2, j1)
 1118:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3)
 1119:                mass = mass + gr_weights(j3)
 1120:             enddo
 1121:             com(1:3) = com(1:3) / mass
 1122:             ! store COM coords
 1123:             do j2 = 1, nsiteperbody(j1)
 1124:                j3 = rigidgroups(j2, j1)
 1125:                comcoords(3*j3-2:3*j3) = com(1:3)
 1126:             enddo
 1127:          enddo
 1128:       endif
 1129: 
491:       ! compute reciprocal-space gradient1130:       ! compute reciprocal-space gradient
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))))1131:       ! 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))))
493:       ! iterate over boxes and calculate repciprocal lattice vectors1132:       ! iterate over boxes and calculate repciprocal lattice vectors
494:       do l = -newaldrecip(1), newaldrecip(1)1133:       do l = -newaldrecip(1), newaldrecip(1)
495:          k(1) = 2*pi*l/boxlx1134:          k(1) = 2*pi*l/box_params(1)
496:          do m = -newaldrecip(2), newaldrecip(2)1135:          do m = -newaldrecip(2), newaldrecip(2)
497:             k(2) = 2*pi*m/boxly1136:             k(2) = 2*pi*m/box_params(2)
498:             do n = -newaldrecip(3), newaldrecip(3)1137:             do n = -newaldrecip(3), newaldrecip(3)
499:                k(3) = 2*pi*n/boxlz1138:                k(3) = 2*pi*n/box_params(3)
500:                ! check not in central box1139:                ! check not in central box
501:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then1140:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
502:                   k2 = k(1)**2 + k(2)**2 + k(3)**21141:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
503:                   if (k2 < ewaldrecipc2) then1142:                   if (k2 < ewaldrecipc2) then
504:                      ! calculate multiplicative factor1143:                      ! calculate multiplicative factor
505:                      mul = -4*pi*dexp(-k2/(4.0d0*ewaldalpha**2))/(vol*k2)1144:                      mul = -4.0d0*pi*dexp(-k2/(4.0d0*ewaldalpha**2))/(vol*k2)
 1145:                      ! get structure factors
506:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)1146:                      rerho = rerhoarray(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)1147:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)
 1148: 
 1149:                      ! add contribution to box derivatives
 1150:                      if (boxderivt) then
 1151:                         box_paramsgrad(1:3) = box_paramsgrad(1:3) + mul*(rerho**2+imrho**2)* &
 1152:                                               (1.0d0 - (k2 + 4.0d0*ewaldalpha**2)*k(1:3)*k(1:3)/ &
 1153:                                               (2.0d0*ewaldalpha**2*k2))/(2.0d0*box_params(1:3))
 1154:                      endif
 1155: 
508:                      ! iterate over atoms and calculate long-range gradient terms1156:                      ! iterate over atoms and calculate long-range gradient terms
509:                      do j1 = 1,natoms1157:                      do j1 = 1, natoms
510:                         j3 = 3*j11158:                         j3 = 3*j1
511:                         r(1) = x(j3-2)1159:                         r(:) = x(j3-2:j3)
512:                         r(2) = x(j3-1) 
513:                         r(3) = x(j3) 
514:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3)1160:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3)
515:                         q1 = stchrg(j1)1161:                         q1 = stchrg(j1)
516:                         mul2 = mul*q1*(dsin(kdotr)*rerho - dcos(kdotr)*imrho)1162:                         mul2 = mul*q1*(dsin(kdotr)*rerho - dcos(kdotr)*imrho)
 1163:                         
 1164:                         ! add contribution to gradient 
517:                         g(j3-2) = g(j3-2) + mul2*k(1)1165:                         g(j3-2) = g(j3-2) + mul2*k(1)
518:                         g(j3-1) = g(j3-1) + mul2*k(2)1166:                         g(j3-1) = g(j3-1) + mul2*k(2)
519:                         g(j3)   = g(j3)   + mul2*k(3)1167:                         g(j3)   = g(j3)   + mul2*k(3)
520:                      enddo1168: 
521:                   endif1169:                         ! add contribution to box derivatives from rigid bodies
522:                endif1170:                         ! NOTE: no contribition if not using rigid bodies
 1171:                         if (rigidinit.and.boxderivt) then
 1172:                            box_paramsgrad(1:3) = box_paramsgrad(1:3) - mul2*k(1:3)*(x(j3-2:j3)-comcoords(j3-2:j3))/box_params(1:3)
 1173:                         endif
 1174: 
 1175:                      enddo ! atoms
 1176: 
 1177:                   endif ! within cutoff
 1178:                endif ! not in central box
 1179:             enddo ! n
 1180:          enddo ! m
 1181:       enddo ! l
 1182: 
 1183:       return
 1184:       end subroutine coulombrecipgrad_ortho
 1185: 
 1186: ! -----------------------------------------------------------------------------------
 1187: ! Calculates the reciprocal-space contribution to the gradient with respects to atomic
 1188: ! positions. Also calculates reciprocal-space contribution to the gradient wrt lattice
 1189: ! vectors, if BOXDERIVT is true. Uses structure factors to simplify computation.
 1190: 
 1191: ! Assumes triclinic unit cell.
 1192: ! -----------------------------------------------------------------------------------
 1193:       subroutine coulombrecipgrad_tri(x, newaldrecip, g)
 1194: 
 1195:       use commons, only: rerhoarray, imrhoarray
 1196:       use genrigid, only: rigidinit, nrigidbody, nsiteperbody, rigidgroups, gr_weights, inversematrix
 1197:       use cartdist, only: get_volume, get_reciplatvec, build_H, cart2frac_tri
 1198: 
 1199:       implicit none
 1200: 
 1201:       integer                         :: l, m, n, j1, j2, j3, idx
 1202:       integer, intent(in)             :: newaldrecip(3)
 1203:       double precision, intent(in)    :: x(3*natoms)
 1204:       double precision, intent(inout) :: g(3*natoms)
 1205:       double precision                :: vol, ewaldrecipc2, c(3), s(3), abc, vfact, dvol(6), r(3)
 1206:       double precision                :: reciplatvec(3,3), reciplatvec_grad(3,3,6), xfrac(3*natoms)
 1207:       double precision                :: H(3,3), H_grad(3,3,6), H_inverse(3,3), k(3), k_grad(3,6)
 1208:       double precision                :: k2, kdotr, rerho, imrho, q1, mul, mul2
 1209:       double precision                :: com(3), mass, comcoords(3*natoms), comcoordsfrac(3*natoms)
 1210:       double precision, parameter     :: pi = 3.141592654D0
 1211: 
 1212:       ! cell volume
 1213:       call get_volume(vol)
 1214:       ! gradient of volume wrt cell parameters
 1215:       if (boxderivt) then
 1216:          c(:) = dcos(box_params(4:6))
 1217:          s(:) = dsin(box_params(4:6))
 1218:          abc = box_params(1)*box_params(2)*box_params(3)
 1219:          vfact = vol/abc
 1220:          dvol(1) = vol/box_params(1)
 1221:          dvol(2) = vol/box_params(2)
 1222:          dvol(3) = vol/box_params(3)
 1223:          dvol(4) = s(1)*(c(1)-c(2)*c(3))
 1224:          dvol(5) = s(2)*(c(2)-c(1)*c(3))
 1225:          dvol(6) = s(3)*(c(3)-c(1)*c(2))
 1226:          dvol(4:6) = abc*dvol(4:6)/vfact
 1227:       endif
 1228: 
 1229:       ! reciprocal lattice vectors
 1230:       call get_reciplatvec(reciplatvec, reciplatvec_grad, boxderivt)
 1231:       ! get H matrix and inverse
 1232:       call build_H(H, H_grad, boxderivt)
 1233:       call inversematrix(H, H_inverse)
 1234:       ! get fractional coordinates
 1235:       if (boxderivt) call cart2frac_tri(x, xfrac, H_inverse)
 1236:       ! reciprocal-space cutoff
 1237:       ewaldrecipc2 = ewaldrecipc**2
 1238: 
 1239:       ! if rigid bodies, compute COM coords
 1240:       ! to compute box derivatives
 1241:       if (rigidinit.and.boxderivt) then
 1242:          do j1 = 1, nrigidbody
 1243:             com(:) = 0.0d0
 1244:             mass = 0.0d0
 1245:             ! compute COM
 1246:             do j2 = 1, nsiteperbody(j1)
 1247:                j3 = rigidgroups(j2, j1)
 1248:                com(1:3) = com(1:3) + x(3*j3-2:3*j3)*gr_weights(j3)
 1249:                mass = mass + gr_weights(j3)
 1250:             enddo
 1251:             com(1:3) = com(1:3) / mass
 1252:             ! store COM coords
 1253:             do j2 = 1, nsiteperbody(j1)
 1254:                j3 = rigidgroups(j2, j1)
 1255:                comcoords(3*j3-2:3*j3) = com(1:3)
523:             enddo1256:             enddo
524:          enddo1257:          enddo
525:       enddo1258:          ! convert to fractional
 1259:          call cart2frac_tri(comcoords, comcoordsfrac, H_inverse)
 1260:       endif
 1261: 
 1262:       ! compute reciprocal-space gradient
 1263:       ! 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))))
 1264:       ! iterate over boxes and calculate repciprocal lattice vectors
 1265:       do l = -newaldrecip(1), newaldrecip(1)
 1266:          do m = -newaldrecip(2), newaldrecip(2)
 1267:             do n = -newaldrecip(3), newaldrecip(3)
 1268:                ! check not in central box
 1269:                if (.not.(l.eq.0.and.m.eq.0.and.n.eq.0)) then
 1270:                   k = l*reciplatvec(:,1) + m*reciplatvec(:,2) + n*reciplatvec(:,3)
 1271:                   k2 = k(1)**2 + k(2)**2 + k(3)**2
 1272:                   if (k2 < ewaldrecipc2) then
 1273: 
 1274:                      ! get gradient of reciprocal lattice vector wrt cell parameters
 1275:                      if (boxderivt) then
 1276:                         do idx = 1,6
 1277:                            k_grad(:,idx) = l*reciplatvec_grad(:,1,idx) + m*reciplatvec_grad(:,2,idx) + n*reciplatvec_grad(:,3,idx)
 1278:                         enddo
 1279:                      endif
 1280:                      
 1281:                      ! calculate multiplicative factor
 1282:                      mul = -4.0d0*pi*dexp(-k2/(4.0d0*ewaldalpha**2))/(vol*k2)
 1283:                      ! get structure factors
 1284:                      rerho = rerhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)
 1285:                      imrho = imrhoarray(l+newaldrecip(1)+1, m+newaldrecip(2)+1, n+newaldrecip(3)+1)
 1286: 
 1287:                      ! add contribution to box derivatives
 1288:                      if (boxderivt) then
 1289:                         ! iterate over cell parameters
 1290:                         do idx = 1, 6
 1291:                             box_paramsgrad(idx) = box_paramsgrad(idx) + &
 1292:                                                   mul*(rerho**2+imrho**2)*(dvol(idx)/(2.0d0*vol) + &
 1293:                                                   (k2 + 4.0d0*ewaldalpha**2)*dot_product(k, k_grad(:,idx))/ &
 1294:                                                   (4.0d0*ewaldalpha**2*k2))
 1295:                         enddo
 1296:                      endif
 1297: 
 1298:                      ! iterate over atoms and calculate long-range gradient terms
 1299:                      do j1 = 1, natoms
 1300:                         j3 = 3*j1
 1301:                         r(:) = x(j3-2:j3)
 1302:                         kdotr = k(1)*r(1) + k(2)*r(2) + k(3)*r(3)
 1303:                         q1 = stchrg(j1)
 1304:                         mul2 = mul*q1*(dsin(kdotr)*rerho - dcos(kdotr)*imrho)
 1305:                         
 1306:                         ! add contribution to gradient 
 1307:                         g(j3-2) = g(j3-2) + mul2*k(1)
 1308:                         g(j3-1) = g(j3-1) + mul2*k(2)
 1309:                         g(j3)   = g(j3)   + mul2*k(3)
 1310: 
 1311:                         ! add contribution to box derivatives
 1312:                         if (boxderivt) then
 1313:                            if (rigidinit) then
 1314:                               ! iterate over cell parameters
 1315:                               do idx = 1,6
 1316:                                  box_paramsgrad(idx) = box_paramsgrad(idx) + &
 1317:                                                        mul2*(dot_product(k_grad(:,idx), r) + &
 1318:                                                        dot_product(k, matmul(H_grad(:,:,idx), comcoordsfrac(j3-2:j3))))
 1319:                               enddo
 1320:                            else ! not rigid bodies
 1321:                               ! iterate over cell parameters
 1322:                               do idx = 1,6
 1323:                                  box_paramsgrad(idx) = box_paramsgrad(idx) + &
 1324:                                                        mul2*(dot_product(k_grad(:,idx), r) + &
 1325:                                                        dot_product(k, matmul(H_grad(:,:,idx), xfrac(j3-2:j3))))
 1326:                               enddo
 1327:                            endif
 1328:                         endif
 1329: 
 1330:                      enddo ! atoms
 1331: 
 1332:                   endif ! within cutoff
 1333:                endif ! not in central box
 1334:             enddo ! n
 1335:          enddo ! m
 1336:       enddo ! l
526: 1337: 
527:       return1338:       return
528:       end subroutine1339:       end subroutine coulombrecipgrad_tri
529: 1340: 
530: end module1341: end module


r33135/finalio.f90 2017-08-07 17:30:35.153112990 +0100 r33134/finalio.f90 2017-08-07 17:30:45.973256699 +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 
 27:   USE OPEP_INTERFACE_MOD, ONLY: OPEP_FINISH, OPEP_WRITE_PDB 26:   USE OPEP_INTERFACE_MOD, ONLY: OPEP_FINISH, OPEP_WRITE_PDB
 28:   USE QMODULE 27:   USE QMODULE
 29:   USE MODCHARMM 28:   USE MODCHARMM
 30:   USE AMHGLOBALS, ONLY:NMRES,IRES 29:   USE AMHGLOBALS, ONLY:NMRES,IRES
 31:   USE BGUPMOD 30:   USE BGUPMOD
 32:   USE PERMU 31:   USE PERMU
 33:   USE MODHESS, ONLY : HESS, MASSWT 32:   USE MODHESS, ONLY : HESS, MASSWT
 34:   USE CONVEX_POLYHEDRA_MODULE, ONLY: VIEW_POLYHEDRA 33:   USE CONVEX_POLYHEDRA_MODULE, ONLY: VIEW_POLYHEDRA
 35:   USE LJ_GAUSS_MOD, ONLY: VIEW_LJ_GAUSS 34:   USE LJ_GAUSS_MOD, ONLY: VIEW_LJ_GAUSS
 36:   USE OPP_MOD, ONLY: VIEW_OPP 
 37:   USE ORBITALS_MOD, ONLY: ORBITALS_FINISH 
 38:  35: 
 39:   IMPLICIT NONE 36:   IMPLICIT NONE
 40:  37: 
 41:   !   MCP 38:   !   MCP
 42:   INTEGER III, I3,  GLY_COUNT, ID, NUMCRD, NUMPRO, NCPHST, GETUNIT, AMHUNIT1, LUNIT, NSYMOPS, NCLOSE 39:   INTEGER III, I3,  GLY_COUNT, ID, NUMCRD, NUMPRO, NCPHST, GETUNIT, AMHUNIT1, LUNIT, NSYMOPS, NCLOSE
 43:   INTEGER J1, J2, J3, J4, J5, MYUNIT2, I1, NDUMMY, MYUNIT3, NRBS1, NRBS2, LJGOUNIT, MJ2, REORDERUNIT 40:   INTEGER J1, J2, J3, J4, J5, MYUNIT2, I1, NDUMMY, MYUNIT3, NRBS1, NRBS2, LJGOUNIT, MJ2, REORDERUNIT
 44:   DOUBLE PRECISION RBCOORDS(NRBSITES*3), DCOORDS(3*NATOMS), EDUMMY, ITDET, DIST 41:   DOUBLE PRECISION RBCOORDS(NRBSITES*3), DCOORDS(3*NATOMS), EDUMMY, ITDET, DIST
 45:   ! 42:   !
 46:   !ds656> Symmetry detection for clusters on a substrate... 43:   !ds656> Symmetry detection for clusters on a substrate...
 47:   INTEGER :: ISITES(MIEF_NSITES), NSITES, COMBO_N 44:   INTEGER :: ISITES(MIEF_NSITES), NSITES, COMBO_N
396:            WRITE(MYUNIT2,*) NATOMS393:            WRITE(MYUNIT2,*) NATOMS
397:            WRITE(MYUNIT2, '(2F20.10,I6,1X,E15.8E2)') &394:            WRITE(MYUNIT2, '(2F20.10,I6,1X,E15.8E2)') &
398:                 EDUMMY, LOG_PROD, NSYMOPS, ITDET395:                 EDUMMY, LOG_PROD, NSYMOPS, ITDET
399:            !396:            !
400:         ENDIF397:         ENDIF
401:         !398:         !
402:      ELSE ! <ds656399:      ELSE ! <ds656
403:         WRITE(MYUNIT2,10) J1, QMIN(J1), FF(J1), NPCALL_QMIN(J1)400:         WRITE(MYUNIT2,10) J1, QMIN(J1), FF(J1), NPCALL_QMIN(J1)
404: 10      FORMAT('Energy of minimum ',I6,'=',G20.10, &401: 10      FORMAT('Energy of minimum ',I6,'=',G20.10, &
405:              ' first found at step ',I8,' after ',I20,' function calls')402:              ' first found at step ',I8,' after ',I20,' function calls')
 403:         ! dj337: write cell parameters
 404:         IF (BOXDERIVT) THEN
 405:            WRITE(MYUNIT2, *) 'Box lengths: ', boxq(j1,1:3)
 406:            IF (.NOT.ORTHO) WRITE(MYUNIT2, *) 'Box angles: ', boxq(j1,4:6)
 407:         ENDIF
406:      ENDIF408:      ENDIF
407:      !409:      !
408:      IF (MSORIGT.OR.FRAUSIT) THEN410:      IF (MSORIGT.OR.FRAUSIT) THEN
409:         WRITE(MYUNIT2,20) (QMINP(J1,J2),J2=1,3*(NATOMS-NS))411:         WRITE(MYUNIT2,20) (QMINP(J1,J2),J2=1,3*(NATOMS-NS))
410: 20      FORMAT('Si',3F20.10)412: 20      FORMAT('Si',3F20.10)
411:      ELSE IF (MSTRANST) THEN413:      ELSE IF (MSTRANST) THEN
412:         WRITE(MYUNIT2,20) (QMINP(J1,J2),J2=1,3*(NATOMS-NS))414:         WRITE(MYUNIT2,20) (QMINP(J1,J2),J2=1,3*(NATOMS-NS))
413:      ELSE IF (RGCL2) THEN415:      ELSE IF (RGCL2) THEN
414:         WRITE(MYUNIT2,'(A,F20.10)') 'Cl 0.0 0.0 ', 0.995D0416:         WRITE(MYUNIT2,'(A,F20.10)') 'Cl 0.0 0.0 ', 0.995D0
415:         WRITE(MYUNIT2,'(A,F20.10)') 'Cl 0.0 0.0 ',-0.995D0417:         WRITE(MYUNIT2,'(A,F20.10)') 'Cl 0.0 0.0 ',-0.995D0
770:         ENDDO772:         ENDDO
771: 773: 
772:      ELSE IF (GBT.OR.GBDT.OR.GBDPT.OR.MSGBT) THEN774:      ELSE IF (GBT.OR.GBDT.OR.GBDPT.OR.MSGBT) THEN
773:         DO J2 = 1, NATOMS/2775:         DO J2 = 1, NATOMS/2
774:            WRITE(MYUNIT2,'(3f20.10)') (QMINP(J1,3*(J2-1)+J3),J3=1,3)776:            WRITE(MYUNIT2,'(3f20.10)') (QMINP(J1,3*(J2-1)+J3),J3=1,3)
775:         ENDDO777:         ENDDO
776:         DO J2 = 1, NATOMS/2778:         DO J2 = 1, NATOMS/2
777:            WRITE(MYUNIT2,'(3f20.10)') (QMINP(J1,3*NATOMS/2+3*(J2-1)+J3),J3=1,3)779:            WRITE(MYUNIT2,'(3f20.10)') (QMINP(J1,3*NATOMS/2+3*(J2-1)+J3),J3=1,3)
778:         ENDDO780:         ENDDO
779: 781: 
780:      ELSE IF (MLP3T.OR.MLPB3T.OR.MLQT.OR.MLPVB3T.OR.ORBITALS) THEN782:      ELSE IF (MLP3T.OR.MLPB3T.OR.MLQT.OR.MLPVB3T) THEN
781:         DO J2 = 1, NATOMS783:         DO J2 = 1, NATOMS
782:            WRITE(MYUNIT2,'(3G20.10)') QMINP(J1,J2)784:            WRITE(MYUNIT2,'(3G20.10)') QMINP(J1,J2)
783:         ENDDO785:         ENDDO
784: 786: 
785:      ELSE IF (GEMT) THEN787:      ELSE IF (GEMT) THEN
786:         DO J2 = 1, NATOMS788:         DO J2 = 1, NATOMS
787:            WRITE(MYUNIT2,'(3f20.10)') (QMINP(J1,3*(J2-1)+J3),J3=1,3)789:            WRITE(MYUNIT2,'(3f20.10)') (QMINP(J1,3*(J2-1)+J3),J3=1,3)
788:         ENDDO790:         ENDDO
789: 791: 
790:      ELSE IF (BLNT.AND.(.NOT.P46).AND.(.NOT.G46)) THEN792:      ELSE IF (BLNT.AND.(.NOT.P46).AND.(.NOT.G46)) THEN
1613:   ELSE IF (POLYT) THEN1615:   ELSE IF (POLYT) THEN
1614: 1616: 
1615:      CALL VIEW_POLYHEDRA()1617:      CALL VIEW_POLYHEDRA()
1616:      RETURN1618:      RETURN
1617: 1619: 
1618:   ELSE IF (LJ_GAUSST) THEN1620:   ELSE IF (LJ_GAUSST) THEN
1619: 1621: 
1620:      CALL VIEW_LJ_GAUSS()1622:      CALL VIEW_LJ_GAUSS()
1621:      RETURN1623:      RETURN
1622: 1624: 
1623:   ELSE IF (OPPT) THEN 
1624:  
1625:      CALL VIEW_OPP() 
1626:      RETURN 
1627:  
1628:   ELSE IF (PTSTSTT) THEN1625:   ELSE IF (PTSTSTT) THEN
1629: 1626: 
1630:      CALL VIEWPTSTST()1627:      CALL VIEWPTSTST()
1631:      RETURN1628:      RETURN
1632: 1629: 
1633:      !|gd351>1630:      !|gd351>
1634: 1631: 
1635:   ELSE IF (PATCHY) THEN1632:   ELSE IF (PATCHY) THEN
1636: 1633: 
1637:      CALL VIEWPATCHY()1634:      CALL VIEWPATCHY()
1743:               WRITE(LUNIT,'(A4,3F20.10)') 'LA ',RBCOORDS(3*(J3-1)+1),RBCOORDS(3*(J3-1)+2),RBCOORDS(3*(J3-1)+3)1740:               WRITE(LUNIT,'(A4,3F20.10)') 'LA ',RBCOORDS(3*(J3-1)+1),RBCOORDS(3*(J3-1)+2),RBCOORDS(3*(J3-1)+3)
1744:            ENDDO1741:            ENDDO
1745:         ENDDO1742:         ENDDO
1746:      ENDDO1743:      ENDDO
1747:      CLOSE(LUNIT)1744:      CLOSE(LUNIT)
1748: 1745: 
1749:   ENDIF1746:   ENDIF
1750: 1747: 
1751:   IF(ALLOCATED(DBNAME)) DEALLOCATE(DBNAME)1748:   IF(ALLOCATED(DBNAME)) DEALLOCATE(DBNAME)
1752: 1749: 
1753:   IF (AMBER12T.AND.(.NOT.(AMBERMUTATIONT))) THEN1750:   IF (AMBER12T) THEN
1754:      CALL AMBER12_FINISH()1751:      CALL AMBER12_FINISH()
1755:   END IF1752:   END IF
1756: 1753: 
1757:   IF (OPEPT) CALL OPEP_FINISH()1754:   IF (OPEPT) CALL OPEP_FINISH()
1758: 1755: 
1759:   IF (ORBITALS) CALL ORBITALS_FINISH() 
1760:  
1761:   CALL CPU_TIME(TEND)1756:   CALL CPU_TIME(TEND)
1762:   WRITE(MYUNIT,"(A,F18.1,A)") "time elapsed ", TEND - TSTART, " seconds"1757:   WRITE(MYUNIT,"(A,F18.1,A)") "time elapsed ", TEND - TSTART, " seconds"
1763:   WRITE(MYUNIT,"(A,I18)") "Number of potential calls ", NPCALL1758:   WRITE(MYUNIT,"(A,I18)") "Number of potential calls ", NPCALL
1764:   RETURN1759:   RETURN
1765: 1760: 
1766: END SUBROUTINE FINALIO1761: END SUBROUTINE FINALIO
1767: 1762: 
1768: SUBROUTINE AMBERDUMP(J1,QMINP)1763: SUBROUTINE AMBERDUMP(J1,QMINP)
1769:     USE COMMONS1764:     USE COMMONS
1770:     USE MODAMBER1765:     USE MODAMBER


r33135/finalq.f 2017-08-07 17:30:35.373115911 +0100 r33134/finalq.f 2017-08-07 17:30:46.193259623 +0100
 67:  67: 
 68: ! csw34> Adding in clarification of what is being tightly quenched 68: ! csw34> Adding in clarification of what is being tightly quenched
 69:       WRITE(MYUNIT,'(A)') 'Tightly converging the SAVE lowest energy minima found' 69:       WRITE(MYUNIT,'(A)') 'Tightly converging the SAVE lowest energy minima found'
 70:       WRITE(MYUNIT,'(A)') 'NOTE: these may NOT match the other output files - see below for a sorted list of Lowest minima' 70:       WRITE(MYUNIT,'(A)') 'NOTE: these may NOT match the other output files - see below for a sorted list of Lowest minima'
 71:       DO J1=1,NSAVE 71:       DO J1=1,NSAVE
 72:          IF (QMIN(J1).LT.1.0D10) THEN 72:          IF (QMIN(J1).LT.1.0D10) THEN
 73:             NATOMS=QMINNATOMS(J1) 73:             NATOMS=QMINNATOMS(J1)
 74:             DO J2=1,3*NATOMS 74:             DO J2=1,3*NATOMS
 75:                COORDS(J2,NP)=QMINP(J1,J2) 75:                COORDS(J2,NP)=QMINP(J1,J2)
 76:             ENDDO 76:             ENDDO
  77:             ! dj337: update box parameters with saved ones
  78:             if (boxderivt) box_params(1:6) = boxq(j1, 1:6)
  79:       
 77:              80:             
 78:             !ds656> 81:             !ds656>
 79:             !write(MYUNIT,*) (QMINT(J1,J2),J2=1,NATOMS) 82:             !write(MYUNIT,*) (QMINT(J1,J2),J2=1,NATOMS)
 80:             IF(NSPECIES(0)>1) THEN 83:             IF(NSPECIES(0)>1) THEN
 81:                CALL SET_ATOMLISTS(QMINT(J1,1:NATOMS),1) 84:                CALL SET_ATOMLISTS(QMINT(J1,1:NATOMS),1)
 82:                CALL SET_LABELS(QMINT(J1,1:NATOMS),NP) 85:                CALL SET_LABELS(QMINT(J1,1:NATOMS),NP)
 83:             ENDIF 86:             ENDIF
 84:             !<ds656 87:             !<ds656
 85:              88:             
 86:             NQ(NP)=NQ(NP)+1 89:             NQ(NP)=NQ(NP)+1
132: !               QMIN(J1)=FULLENERGY135: !               QMIN(J1)=FULLENERGY
133: !            ELSE136: !            ELSE
134: !cl457137: !cl457
135:                QMIN(J1)=POTEL138:                QMIN(J1)=POTEL
136: !            ENDIF139: !            ENDIF
137: 140: 
138:             DO J2=1,3*NATOMS141:             DO J2=1,3*NATOMS
139:                QMINP(J1,J2)=COORDS(J2,NP)142:                QMINP(J1,J2)=COORDS(J2,NP)
140:             ENDDO143:             ENDDO
141: 144: 
 145:             ! dj337: save box parameters from end of quench
 146:             if (boxderivt) boxq(j1, 1:6) = box_params(1:6)
 147: 
142:             IF (CSMT) THEN148:             IF (CSMT) THEN
143:                CSMAV(1:3*NATOMS)=0.0D0149:                CSMAV(1:3*NATOMS)=0.0D0
144:                DO J2=1,CSMGPINDEX150:                DO J2=1,CSMGPINDEX
145: !151: !
146: ! rotate permuted image to best orientation with CSMPMAT152: ! rotate permuted image to best orientation with CSMPMAT
147: ! apply point group operation J2153: ! apply point group operation J2
148: ! 154: ! 
149:                   DO J3=1,NATOMS155:                   DO J3=1,NATOMS
150:                      XTEMP(3*(J3-1)+1)=CSMPMAT(1,1)*CSMIMAGES(3*NATOMS*(J2-1)+3*(J3-1)+1)156:                      XTEMP(3*(J3-1)+1)=CSMPMAT(1,1)*CSMIMAGES(3*NATOMS*(J2-1)+3*(J3-1)+1)
151:      &                                +CSMPMAT(1,2)*CSMIMAGES(3*NATOMS*(J2-1)+3*(J3-1)+2)157:      &                                +CSMPMAT(1,2)*CSMIMAGES(3*NATOMS*(J2-1)+3*(J3-1)+2)
195:          ENDIF201:          ENDIF
196:       ENDDO202:       ENDDO
197: C203: C
198: C       sf344> sometimes we can have a lower number of minima found than NSAVE. Resetting204: C       sf344> sometimes we can have a lower number of minima found than NSAVE. Resetting
199: C              NSAVE to the number of minima found should get rid of entries with null 205: C              NSAVE to the number of minima found should get rid of entries with null 
200: C              coordinates in the file 'lowest' (and other final output files)206: C              coordinates in the file 'lowest' (and other final output files)
201: C207: C
202: C  DJW - this may not work because we may not have found enough minima considered 208: C  DJW - this may not work because we may not have found enough minima considered 
203: C        different according to the EDIFF criterion.209: C        different according to the EDIFF criterion.
204: C210: C
205: !     IF (DEBUG) WRITE(MYUNIT,'(A,8I6)') 'finalq> NQ=',NQ(1:NPAR)211:       IF (DEBUG) WRITE(MYUNIT,'(A,8I6)') 'finalq> NQ=',NQ(1:NPAR)
206: !     IF (DEBUG) WRITE(MYUNIT,'(A,8I6)') 'finalq> NP=',NP212:       IF (DEBUG) WRITE(MYUNIT,'(A,8I6)') 'finalq> NP=',NP
207: !      WRITE(MYUNIT,'(A,8I6)') 'finalq> NQ=',NQ(1:NPAR)213: !      WRITE(MYUNIT,'(A,8I6)') 'finalq> NQ=',NQ(1:NPAR)
208: !      WRITE(MYUNIT,'(A,8I6)') 'finalq> NP=',NP214: !      WRITE(MYUNIT,'(A,8I6)') 'finalq> NP=',NP
209:       NSAVE=MIN(NSAVE,NQ(NP))215:       NSAVE=MIN(NSAVE,NQ(NP))
210: ! csw34> Re-sort the saved minima now that they have been tightly converged216: ! csw34> Re-sort the saved minima now that they have been tightly converged
211:       CALL GSORT2(NSAVE,NATOMSALLOC)217:       CALL GSORT2(NSAVE,NATOMSALLOC)
212: ! csw34> Print a list of sorted minima energies which will 100% match other output files218: ! csw34> Print a list of sorted minima energies which will 100% match other output files
213:       WRITE(MYUNIT,'(A)') 'After re-sorting, the lowest found minima are (lowest free energy subtracted if applicable):'219:       WRITE(MYUNIT,'(A)') 'After re-sorting, the lowest found minima are (lowest free energy subtracted if applicable):'
214:       DO J1=1,NSAVE220:       DO J1=1,NSAVE
215:          WRITE(MYUNIT,'(A,I6,A,G20.10)') 'Lowest Minimum ',J1,' Energy= ',QMIN(J1)221:          WRITE(MYUNIT,'(A,I6,A,G20.10)') 'Lowest Minimum ',J1,' Energy= ',QMIN(J1)
216:       ENDDO222:       ENDDO


r33135/gay-berne.f90 2017-08-07 17:30:35.601118940 +0100 r33134/gay-berne.f90 2017-08-07 17:30:46.421262651 +0100
5292:       MG = (1.D0 - LAMDA) * AEINV + LAMDA * BEINV5292:       MG = (1.D0 - LAMDA) * AEINV + LAMDA * BEINV
5293: 5293: 
5294:       CALL MTRXIN(MG, MGINV)5294:       CALL MTRXIN(MG, MGINV)
5295: 5295: 
5296:       MGINVR  =  MATMUL(MGINV, RIJ) 5296:       MGINVR  =  MATMUL(MGINV, RIJ) 
5297: 5297: 
5298:       SLMD =  - LAMDA * (1.D0 - LAMDA) * DOT_PRODUCT(RIJ,MGINVR)5298:       SLMD =  - LAMDA * (1.D0 - LAMDA) * DOT_PRODUCT(RIJ,MGINVR)
5299: 5299: 
5300:       RETURN5300:       RETURN
5301:       END SUBROUTINE OBJCTF5301:       END SUBROUTINE OBJCTF
5302:  
5303: SUBROUTINE GENERATECGDIMER 
5304: ! this will be useful if we have a reference dimer and would like to get the 
5305: ! coarse-grained coordinates for it (virus capsid protein dimers, for example), 
5306: ! by starting from the angle-axis information about the rigid monomer containing 
5307: ! an arbitrary number of ellipsoids. For this, we need as input the coordinate centres for both units, 
5308: ! and the rotation matrix describing the rotation of the first unit to the second one. Output  
5309: ! will be the angle-axis coordinates of the second unit. 
5310: ! Individual orientations of ellipsoids should go in the pysites.xyz file. 
5311: use rotations 
5312: implicit none 
5313: integer i,j,k, realnatoms, nlines 
5314: double precision :: y(12),atomblockcentre(2,3), rotationmatrix(3,3) 
5315:  
5316: open(255,file='coords',status='old') 
5317:  
5318: call determinelines(255,nlines) 
5319: if(nlines>4) write(*,*) 'ERROR - we should be generating a rigid body dimer, so we need 4 coordinates in the coords file' 
5320:  
5321: do i=1,nlines 
5322:    read(255,*) y(3*i-2), y(3*i-1), y(3*i) 
5323: end do 
5324:  
5325: close(255) 
5326:  
5327: open(256,file='rotationmatrix',status='old') 
5328:  do j=1,3 
5329:    read(256,*) rotationmatrix(1:3,j) 
5330:  end do 
5331:  write(*,*) 'read rotation matrix:' 
5332:  write(*,*) rotationmatrix(:,:) 
5333:  realnatoms=nlines/2 
5334:     y(4:6)=MATMUL(y(1:3),rotationmatrix)+y(4:6)  
5335:     y(3*2+3*REALNATOMS-2:3*2+3*REALNATOMS)=rot_rotate_aa(y(3*2+3*REALNATOMS-2:3*2+3*REALNATOMS),rot_mx2aa(rotationmatrix(:,:))) 
5336: write(*,*) 'finished generating dimer coordinates' 
5337: do i=1,nlines 
5338:    write(*,*) y(3*i-2), y(3*i-1), y(3*i) 
5339: end do 
5340:  
5341: contains 
5342: ! Returns the inverse of a matrix calculated by finding the LU 
5343: ! decomposition.  Depends on LAPACK. 
5344: function inv(A) result(Ainv) 
5345:   double precision, dimension(:,:), intent(in) :: A 
5346:   double precision, dimension(size(A,1),size(A,2)) :: Ainv 
5347:  
5348:   double precision, dimension(size(A,1)) :: work  ! work array for LAPACK 
5349:   integer, dimension(size(A,1)) :: ipiv   ! pivot indices 
5350:   integer :: n, info 
5351:  
5352:   ! External procedures defined in LAPACK 
5353:   external DGETRF 
5354:   external DGETRI 
5355:  
5356:   ! Store A in Ainv to prevent it from being overwritten by LAPACK 
5357:   Ainv = A 
5358:   n = size(A,1) 
5359:  
5360:   ! DGETRF computes an LU factorization of a general M-by-N matrix A 
5361:   ! using partial pivoting with row interchanges. 
5362:   call DGETRF(n, n, Ainv, n, ipiv, info) 
5363:  
5364:   if (info /= 0) then 
5365:      stop 'Matrix is numerically singular!' 
5366:   end if 
5367:  
5368:   ! DGETRI computes the inverse of a matrix using the LU factorization 
5369:   ! computed by DGETRF. 
5370:   call DGETRI(n, Ainv, n, ipiv, work, n, info) 
5371:  
5372:   if (info /= 0) then 
5373:      stop 'Matrix inversion failed!' 
5374:   end if 
5375: end function inv 
5376:  
5377:  
5378: END SUBROUTINE GENERATECGDIMER 
5379:  
5380:  
5381: SUBROUTINE DETERMINELINES(nunit,nlines) 
5382: implicit none 
5383: integer nunit, nlines, iostatus 
5384: character(len=10) check 
5385:  
5386: REWIND(nunit) 
5387:  
5388: nlines=0 
5389: do 
5390:   IF(iostatus<0) EXIT 
5391:   nlines = nlines + 1 
5392:   READ(nunit,*,iostat=iostatus) check 
5393: !  write(*,*) check,nunit 
5394: end do 
5395:   nlines = nlines - 1 
5396:   REWIND(nunit) 
5397: RETURN 
5398:  
5399:  
5400: END SUBROUTINE DETERMINELINES 
5401:  
5402:  


r33135/genrigid.f90 2017-08-07 17:30:35.825121915 +0100 r33134/genrigid.f90 2017-08-07 17:30:46.649265678 +0100
394:         ELSE       394:         ELSE       
395: ! csw34> if not, flag the current atom395: ! csw34> if not, flag the current atom
396:             RIGIDISRIGID(RIGIDGROUPS(J2,J1))=.TRUE.396:             RIGIDISRIGID(RIGIDGROUPS(J2,J1))=.TRUE.
397:             RB_BY_ATOM(RIGIDGROUPS(J2,J1)) = J1397:             RB_BY_ATOM(RIGIDGROUPS(J2,J1)) = J1
398:         ENDIF398:         ENDIF
399: ! vr274> Moved initialization of coordinates to GENRIGID_INITIALISE, here only read the setup399: ! vr274> Moved initialization of coordinates to GENRIGID_INITIALISE, here only read the setup
400: !        SITESRIGIDBODY(J2,:,J1) = COORDS(3*DUMMY-2:3*DUMMY,1)400: !        SITESRIGIDBODY(J2,:,J1) = COORDS(3*DUMMY-2:3*DUMMY,1)
401:      ENDDO401:      ENDDO
402:   ENDDO402:   ENDDO
403:   CLOSE(222)403:   CLOSE(222)
 404: 
404:   CALL GENRIGID_INITIALISE(INICOORDS)405:   CALL GENRIGID_INITIALISE(INICOORDS)
405: END SUBROUTINE GENRIGID_READ_FROM_FILE406: END SUBROUTINE GENRIGID_READ_FROM_FILE
406: 407: 
407: !-----------------------------------------------------------408: !-----------------------------------------------------------
408: 409: 
409: !-----------------------------------------------------------410: !-----------------------------------------------------------
410: 411: 
411: SUBROUTINE TRANSFORMRIGIDTOC (CMIN, CMAX, XCOORDS, XRIGIDCOORDS)412: SUBROUTINE TRANSFORMRIGIDTOC (CMIN, CMAX, XCOORDS, XRIGIDCOORDS)
412:       413:       
413:   USE COMMONS, ONLY: NATOMS414:   USE COMMONS, ONLY: NATOMS, ORTHO, BOXDERIVT
 415:   USE CARTDIST
414:   IMPLICIT NONE416:   IMPLICIT NONE
415:   417:   
416:   INTEGER :: J1, J2, J5, J7, J9418:   INTEGER :: J1, J2, J5, J7, J9
417:   INTEGER :: CMIN, CMAX419:   INTEGER :: CMIN, CMAX
418:   DOUBLE PRECISION :: P(3), RMI(3,3), DRMI1(3,3), DRMI2(3,3), DRMI3(3,3)420:   DOUBLE PRECISION :: P(3), RMI(3,3), DRMI1(3,3), DRMI2(3,3), DRMI3(3,3)
419:   DOUBLE PRECISION :: XRIGIDCOORDS(DEGFREEDOMS), XCOORDS(3*NATOMS)421:   DOUBLE PRECISION :: XRIGIDCOORDS(DEGFREEDOMS), XCOORDS(3*NATOMS)
 422:   DOUBLE PRECISION :: XRFRAC(3*NATOMS), H(3,3), H_GRAD(3,3,6) ! dj337: fractional rigidbody coords
420:   DOUBLE PRECISION :: COM(3) ! center of mass423:   DOUBLE PRECISION :: COM(3) ! center of mass
421:   LOGICAL          :: GTEST !, ATOMTEST424:   LOGICAL          :: GTEST !, ATOMTEST
422:   DOUBLE PRECISION :: MLATTICE(3,3)425:   DOUBLE PRECISION :: MLATTICE(3,3)
423:   426:   
424:   GTEST = .FALSE.427:   GTEST = .FALSE.
425: 428: 
 429:   ! dj337: convert rigidbody coords from fractional to absolute
 430:   if (boxderivt.and.rigidinit) then
 431:      xrfrac(1:degfreedoms) = xrigidcoords(1:degfreedoms)
 432:      if (ortho) then
 433:         call frac2cart_rb_ortho(nrigidbody, xrigidcoords, xrfrac)
 434:      else
 435:         call build_H(H, H_grad, .false.)
 436:         call frac2cart_rb_tri(nrigidbody, xrigidcoords, xrfrac, H)
 437:      endif
 438:   endif
 439: 
426: ! vr274 > are there additional lattice coordinates? If yes, setup transformation matrix440: ! vr274 > are there additional lattice coordinates? If yes, setup transformation matrix
427:   IF(HAS_LATTICE_COORDS) THEN441:   IF(HAS_LATTICE_COORDS) THEN
428:     CALL GET_LATTICE_MATRIX(XRIGIDCOORDS(DEGFREEDOMS-5:DEGFREEDOMS), MLATTICE)442:     CALL GET_LATTICE_MATRIX(XRIGIDCOORDS(DEGFREEDOMS-5:DEGFREEDOMS), MLATTICE)
429:   ELSE ! vr274 > otherwise identity matrix443:   ELSE ! vr274 > otherwise identity matrix
430:     MLATTICE = 0D0444:     MLATTICE = 0D0
431:     MLATTICE(1,1)=1d0445:     MLATTICE(1,1)=1d0
432:     MLATTICE(2,2)=1D0446:     MLATTICE(2,2)=1D0
433:     MLATTICE(3,3)=1D0447:     MLATTICE(3,3)=1D0
434:   ENDIF448:   ENDIF
435: 449: 
436:  
437:   ! hk286 > coord transformations for rigid bodies CMIN to CMAX450:   ! hk286 > coord transformations for rigid bodies CMIN to CMAX
438:   DO J1 = CMIN, CMAX451:   DO J1 = CMIN, CMAX
439:      J5   = 3*J1452:      J5   = 3*J1
440:      J7   = 3*NRIGIDBODY + J5453:      J7   = 3*NRIGIDBODY + J5
441:      P(:) = XRIGIDCOORDS(J7-2:J7)454:      P(:) = XRIGIDCOORDS(J7-2:J7)
442:      CALL RMDRVT(P, RMI, DRMI1, DRMI2, DRMI3, GTEST)455:      CALL RMDRVT(P, RMI, DRMI1, DRMI2, DRMI3, GTEST)
443: 456: 
444: ! vr274 > MLATTICE can have lattice transformation or be identity matrix457: ! vr274 > MLATTICE can have lattice transformation or be identity matrix
445:      COM = matmul(MLATTICE, XRIGIDCOORDS(J5-2:J5))458:      COM = matmul(MLATTICE, XRIGIDCOORDS(J5-2:J5))
446:      DO J2 = 1,  NSITEPERBODY(J1)459:      DO J2 = 1,  NSITEPERBODY(J1)
451:   ENDDO464:   ENDDO
452:   465:   
453: ! hk286 > now the single atoms466: ! hk286 > now the single atoms
454: ! vr274 > this copies lattice coordinates as well which is stored in last 2 atoms467: ! vr274 > this copies lattice coordinates as well which is stored in last 2 atoms
455:   IF (DEGFREEDOMS > 6 * NRIGIDBODY) THEN468:   IF (DEGFREEDOMS > 6 * NRIGIDBODY) THEN
456:      DO J1 = 1, (DEGFREEDOMS - 6*NRIGIDBODY)/3469:      DO J1 = 1, (DEGFREEDOMS - 6*NRIGIDBODY)/3
457:         J9 = RIGIDSINGLES(J1)470:         J9 = RIGIDSINGLES(J1)
458:         XCOORDS(3*J9-2:3*J9) = XRIGIDCOORDS(6*NRIGIDBODY + 3*J1-2:6*NRIGIDBODY + 3*J1)471:         XCOORDS(3*J9-2:3*J9) = XRIGIDCOORDS(6*NRIGIDBODY + 3*J1-2:6*NRIGIDBODY + 3*J1)
459:      ENDDO472:      ENDDO
460:   ENDIF473:   ENDIF
 474: 
 475:   ! dj337: restore rigid body coords as fractional
 476:   if (boxderivt.and.rigidinit) xrigidcoords(1:degfreedoms) = xrfrac(1:degfreedoms)  
461:       477:       
462: END SUBROUTINE TRANSFORMRIGIDTOC478: END SUBROUTINE TRANSFORMRIGIDTOC
463: 479: 
464: !----------------------------------------------------------480: !----------------------------------------------------------
465: 481: 
466: SUBROUTINE ROTATEINITIALREF ()482: SUBROUTINE ROTATEINITIALREF ()
467: IMPLICIT NONE483: IMPLICIT NONE
468: DOUBLE PRECISION :: P(3)484: DOUBLE PRECISION :: P(3)
469: INTEGER J1485: INTEGER J1
470: 486: 
492:   CALL RMDRVT(P, RMI, DRMI1, DRMI2, DRMI3, .FALSE.)  508:   CALL RMDRVT(P, RMI, DRMI1, DRMI2, DRMI3, .FALSE.)  
493:   DO J2 = 1, NSITEPERBODY(J1)509:   DO J2 = 1, NSITEPERBODY(J1)
494:      SITESRIGIDBODY(J2,:,J1) = MATMUL(RMI(:,:),SITESRIGIDBODY(J2,:,J1))510:      SITESRIGIDBODY(J2,:,J1) = MATMUL(RMI(:,:),SITESRIGIDBODY(J2,:,J1))
495:   ENDDO511:   ENDDO
496: 512: 
497: END SUBROUTINE REDEFINERIGIDREF513: END SUBROUTINE REDEFINERIGIDREF
498: 514: 
499: !----------------------------------------------------------515: !----------------------------------------------------------
500: 516: 
501: SUBROUTINE TRANSFORMCTORIGID (XCOORDS, XRIGIDCOORDS)517: SUBROUTINE TRANSFORMCTORIGID (XCOORDS, XRIGIDCOORDS)
502:   USE COMMONS, ONLY: NATOMS, PERMDIST, MYUNIT518:   USE COMMONS, ONLY: NATOMS, PERMDIST, MYUNIT, ORTHO, BOXDERIVT
503:   USE VEC3519:   USE VEC3
504:   USE ROTATIONS520:   USE ROTATIONS
 521:   USE CARTDIST
505:   IMPLICIT NONE522:   IMPLICIT NONE
506:   523:   
507:   INTEGER :: J1, J2, J9     !No of processor524:   INTEGER :: J1, J2, J9     !No of processor
508:   DOUBLE PRECISION :: P(3)525:   DOUBLE PRECISION :: P(3)
509:   DOUBLE PRECISION :: COM(3), PNORM, PT(3,3), PI(3,3), MASS526:   DOUBLE PRECISION :: COM(3), PNORM, PT(3,3), PI(3,3), MASS
510:   DOUBLE PRECISION :: XRIGIDCOORDS (DEGFREEDOMS), XCOORDS(3*NATOMS)527:   DOUBLE PRECISION :: XCOORDS(3*NATOMS), XRIGIDCOORDS(DEGFREEDOMS)
 528:   DOUBLE PRECISION :: XRFRAC(3*NATOMS) ! dj337: fractional rigidbody coords
 529:   DOUBLE PRECISION :: H(3,3), H_GRAD(3,3,6), H_INV(3,3) ! dj337: for fractional rb
511: 530: 
512: ! vr274 > lattice matrix and inverse531: ! vr274 > lattice matrix and inverse
513:   DOUBLE PRECISION MLATTICE(3,3), MLATTICEINV(3,3)532:   DOUBLE PRECISION MLATTICE(3,3), MLATTICEINV(3,3)
514:   INTEGER NLATTICECOORDS533:   INTEGER NLATTICECOORDS
515: 534: 
516: ! hk286 - extra variables for minpermdist535: ! hk286 - extra variables for minpermdist
517:   DOUBLE PRECISION :: D, DIST2, RMAT(3,3) 536:   DOUBLE PRECISION :: D, DIST2, RMAT(3,3) 
518:   DOUBLE PRECISION :: PP1(3*NATOMS), PP2(3*NATOMS)537:   DOUBLE PRECISION :: PP1(3*NATOMS), PP2(3*NATOMS)
519:   LOGICAL :: TEMPPERMDIST538:   LOGICAL :: TEMPPERMDIST
520: 539: 
521:   !print *, 'transforming to rigid' 
522:   !print *, 'xcoords received: ', xcoords(:3*natoms) 
523:  
524: ! vr274 > if has lattice coordinates, setup matrices540: ! vr274 > if has lattice coordinates, setup matrices
525:   IF(HAS_LATTICE_COORDS) THEN541:   IF(HAS_LATTICE_COORDS) THEN
526:     NLATTICECOORDS=6542:     NLATTICECOORDS=6
527:     CALL GET_LATTICE_MATRIX(XCOORDS(3*NATOMS-5:3*NATOMS),MLATTICE)543:     CALL GET_LATTICE_MATRIX(XCOORDS(3*NATOMS-5:3*NATOMS),MLATTICE)
528:   ELSE544:   ELSE
529:     NLATTICECOORDS=0545:     NLATTICECOORDS=0
530:     MLATTICE=0546:     MLATTICE=0
531:     MLATTICE(1,1)=1547:     MLATTICE(1,1)=1
532:     MLATTICE(2,2)=1548:     MLATTICE(2,2)=1
533:     MLATTICE(3,3)=1549:     MLATTICE(3,3)=1
579:         ! vr274 > added lattice stuff595:         ! vr274 > added lattice stuff
580:         XRIGIDCOORDS(6*NRIGIDBODY + 3*J1-2:6*NRIGIDBODY + 3*J1) = MATMUL(MLATTICEINV, XCOORDS(3*J9-2:3*J9))596:         XRIGIDCOORDS(6*NRIGIDBODY + 3*J1-2:6*NRIGIDBODY + 3*J1) = MATMUL(MLATTICEINV, XCOORDS(3*J9-2:3*J9))
581:      ENDDO597:      ENDDO
582:   ENDIF598:   ENDIF
583: 599: 
584: ! vr274 > copy lattice coords600: ! vr274 > copy lattice coords
585:   IF(HAS_LATTICE_COORDS) THEN601:   IF(HAS_LATTICE_COORDS) THEN
586:     XRIGIDCOORDS(DEGFREEDOMS - 5:DEGFREEDOMS) =  XCOORDS(3*NATOMS-5:3*NATOMS)602:     XRIGIDCOORDS(DEGFREEDOMS - 5:DEGFREEDOMS) =  XCOORDS(3*NATOMS-5:3*NATOMS)
587:   ENDIF603:   ENDIF
588: 604: 
589:   !print *, 'after being transformed:'605:   ! dj337: if computing box derivatives, convert rb coords to fractional
590:   !print *, xrigidcoords(:3*natoms)606:   if (boxderivt.and.rigidinit) then
 607:      if (ortho) then
 608:         call cart2frac_rb_ortho(nrigidbody, xrigidcoords, xrfrac)
 609:      else
 610:         call build_H(H, H_grad, .false.)
 611:         call inversematrix(H, H_inv)
 612:         call cart2frac_rb_tri(nrigidbody, xrigidcoords, xrfrac, H_inv)
 613:      endif
 614:      xrigidcoords(1:degfreedoms) = xrfrac(1:degfreedoms)
 615:   endif
591: 616: 
592: END SUBROUTINE TRANSFORMCTORIGID617: END SUBROUTINE TRANSFORMCTORIGID
593: 618: 
594: !-----------------------------------------------------------619: !-----------------------------------------------------------
595: 620: 
596: SUBROUTINE TRANSFORMCTORIGID_OLD (XCOORDS, XRIGIDCOORDS)621: SUBROUTINE TRANSFORMCTORIGID_OLD (XCOORDS, XRIGIDCOORDS)
597: 622: 
598:   USE COMMONS, ONLY: NATOMS623:   USE COMMONS, ONLY: NATOMS
599:   USE VEC3624:   USE VEC3
600:   IMPLICIT NONE625:   IMPLICIT NONE
833:       NLATTICECOORDS=6858:       NLATTICECOORDS=6
834:   ENDIF859:   ENDIF
835: 860: 
836:   GTEST = .TRUE.861:   GTEST = .TRUE.
837:   GR(:) = 0.0D0862:   GR(:) = 0.0D0
838:   863:   
839:   DO J1 = 1, NRIGIDBODY864:   DO J1 = 1, NRIGIDBODY
840:      865:      
841:      PI = XR(3*NRIGIDBODY+3*J1-2 : 3*NRIGIDBODY+3*J1)866:      PI = XR(3*NRIGIDBODY+3*J1-2 : 3*NRIGIDBODY+3*J1)
842:      CALL RMDRVT(PI, RMI, DRMI1, DRMI2, DRMI3, GTEST)867:      CALL RMDRVT(PI, RMI, DRMI1, DRMI2, DRMI3, GTEST)
843: 868:      
844:      DO J2 = 1, NSITEPERBODY(J1)869:      DO J2 = 1, NSITEPERBODY(J1)
845:         J9 = RIGIDGROUPS(J2, J1)870:         J9 = RIGIDGROUPS(J2, J1)
846: 871: 
847: ! hk286 > translation872: ! hk286 > translation
848:         GR(3*J1-2:3*J1) = GR(3*J1-2:3*J1) + G(3*J9-2:3*J9)873:         GR(3*J1-2:3*J1) = GR(3*J1-2:3*J1) + G(3*J9-2:3*J9)
849:         874:         
850: ! hk286 > rotation875: ! hk286 > rotation
851:         DR1(:) = MATMUL(DRMI1,SITESRIGIDBODY(J2,:,J1))876:         DR1(:) = MATMUL(DRMI1,SITESRIGIDBODY(J2,:,J1))
852:         DR2(:) = MATMUL(DRMI2,SITESRIGIDBODY(J2,:,J1))877:         DR2(:) = MATMUL(DRMI2,SITESRIGIDBODY(J2,:,J1))
853:         DR3(:) = MATMUL(DRMI3,SITESRIGIDBODY(J2,:,J1))878:         DR3(:) = MATMUL(DRMI3,SITESRIGIDBODY(J2,:,J1))
1023: !  ENDIF1048: !  ENDIF
1024: 1049: 
1025:   RMS=MAX(DSQRT(RMS/DEGFREEDOMS),1.0D-100)1050:   RMS=MAX(DSQRT(RMS/DEGFREEDOMS),1.0D-100)
1026:   !print *, 'rms: ', rms1051:   !print *, 'rms: ', rms
1027: 1052: 
1028: END SUBROUTINE AACONVERGENCE1053: END SUBROUTINE AACONVERGENCE
1029: 1054: 
1030: ! -------------------------------------------------------------1055: ! -------------------------------------------------------------
1031: ! dj337: second AACONVERGENCE subroutine for systems that do not have the gradient1056: ! dj337: second AACONVERGENCE subroutine for systems that do not have the gradient
1032: ! in Cartesian coordinates.1057: ! in Cartesian coordinates.
 1058: ! TODO: this is not yet working properly!
1033: 1059: 
1034: subroutine aaconvergence2(xr, gr, rms)1060: !subroutine aaconvergence2(xr, gr, rms)
1035: 1061: !
1036:   implicit none1062: !  implicit none
1037: 1063: !
1038:   integer                       :: j11064: !  integer                       :: j1
1039:   double precision, intent(in)  :: xr(degfreedoms), gr(degfreedoms)1065: !  double precision, intent(in)  :: xr(degfreedoms), gr(degfreedoms)
1040:   double precision              :: pi(3), rmi(3,3), drmi1(3,3), drmi2(3,3), drmi3(3,3)1066: !  double precision              :: pi(3), rmi(3,3), drmi1(3,3), drmi2(3,3), drmi3(3,3)
1041:   double precision              :: torque(3), mat1(3,3), mat2(3,3), mat3(3,3)1067: !  double precision              :: torque(3), mat1(3,3), mat2(3,3), mat3(3,3)
1042:   double precision, intent(out) :: rms1068: !  double precision, intent(out) :: rms
1043: 1069: !
1044:   rms = 0.0d01070: !  rms = 0.0d0
1045:  1071: ! 
1046:   ! iterate over rigid bodies 1072: !  ! iterate over rigid bodies 
1047:   do j1 = 1, nrigidbody1073: !  do j1 = 1, nrigidbody
1048:   1074: !  
1049:      ! compute RMS contribution due to translational degrees of freedom1075: !     ! compute RMS contribution due to translational degrees of freedom
1050:      rms = rms + 1.0d0/nsiteperbody(j1) * dot_product(gr(3*j1-2:3*j1), gr(3*j1-2:3*j1))1076: !     rms = rms + 1.0d0/nsiteperbody(j1) * dot_product(gr(3*j1-2:3*j1), gr(3*j1-2:3*j1))
1051:   1077: !  
1052:      ! compute RMS contribution due to rotational degrees of freedom1078: !     ! compute RMS contribution due to rotational degrees of freedom
1053:      ! convert AA gradient to instantaneous frame1079: !     ! convert AA gradient to instantaneous frame
1054:      torque(:) = 0.0d01080: !     torque(:) = 0.0d0
1055:      mat1(:,:) = 0.0d0; mat2(:,:) = 0.0d0; mat3(:,:) = 0.0d01081: !     mat1(:,:) = 0.0d0; mat2(:,:) = 0.0d0; mat3(:,:) = 0.0d0
1056:      pi = xr(3*nrigidbody+3*j1-2:3*nrigidbody+3*j1)1082: !     pi = xr(3*nrigidbody+3*j1-2:3*nrigidbody+3*j1)
1057:      call rmdrvt(pi, rmi, drmi1, drmi2, drmi3, .true.)1083: !     call rmdrvt(pi, rmi, drmi1, drmi2, drmi3, .true.)
1058:  1084: ! 
1059:      mat1 = matmul(drmi1, transpose(rmi))1085: !     mat1 = matmul(drmi1, transpose(rmi))
1060:      !print *, 'mat1: ', mat(:3,:3)1086: !     !print *, 'mat1: ', mat(:3,:3)
1061:      torque(1) = torque(1) + gr(3*nrigidbody+3*j1-2)*mat1(3,2)1087: !     torque(1) = torque(1) + gr(3*nrigidbody+3*j1-2)*mat1(3,2)
1062:      torque(2) = torque(2) + gr(3*nrigidbody+3*j1-2)*mat1(1,3)1088: !     torque(2) = torque(2) + gr(3*nrigidbody+3*j1-2)*mat1(1,3)
1063:      torque(3) = torque(3) + gr(3*nrigidbody+3*j1-2)*mat1(2,1)1089: !     torque(3) = torque(3) + gr(3*nrigidbody+3*j1-2)*mat1(2,1)
1064:   1090: !  
1065:      mat2 = matmul(drmi2, transpose(rmi))1091: !     mat2 = matmul(drmi2, transpose(rmi))
1066:      !print *, 'mat2: ', mat(:3,:3)1092: !     !print *, 'mat2: ', mat(:3,:3)
1067:      torque(1) = torque(1) + gr(3*nrigidbody+3*j1-1)*mat2(3,2)1093: !     torque(1) = torque(1) + gr(3*nrigidbody+3*j1-1)*mat2(3,2)
1068:      torque(2) = torque(2) + gr(3*nrigidbody+3*j1-1)*mat2(1,3)1094: !     torque(2) = torque(2) + gr(3*nrigidbody+3*j1-1)*mat2(1,3)
1069:      torque(3) = torque(3) + gr(3*nrigidbody+3*j1-1)*mat2(2,1)1095: !     torque(3) = torque(3) + gr(3*nrigidbody+3*j1-1)*mat2(2,1)
1070:   1096: !  
1071:      mat3 = matmul(drmi3, transpose(rmi))1097: !     mat3 = matmul(drmi3, transpose(rmi))
1072:      !print *, 'mat3: ', mat(:3,:3)1098: !     !print *, 'mat3: ', mat(:3,:3)
1073:      torque(1) = torque(1) + gr(3*nrigidbody+3*j1)*mat3(3,2)1099: !     torque(1) = torque(1) + gr(3*nrigidbody+3*j1)*mat3(3,2)
1074:      torque(2) = torque(2) + gr(3*nrigidbody+3*j1)*mat3(1,3)1100: !     torque(2) = torque(2) + gr(3*nrigidbody+3*j1)*mat3(1,3)
1075:      torque(3) = torque(3) + gr(3*nrigidbody+3*j1)*mat3(2,1)1101: !     torque(3) = torque(3) + gr(3*nrigidbody+3*j1)*mat3(2,1)
1076: 1102: !
1077:      !print *, 'index: ', j11103: !     !print *, 'index: ', j1
1078:      !print *, 'rmi: ', rmi(:3,:3)1104: !     !print *, 'rmi: ', rmi(:3,:3)
1079:      !print *, 'inertia: ', iinverse(j1,:3,:3)1105: !     !print *, 'inertia: ', iinverse(j1,:3,:3)
1080:      torque = matmul(transpose(rmi), torque)1106: !     torque = matmul(transpose(rmi), torque)
1081:      !print *, j1, 'grad: ', gr(3*nrigidbody+3*j1-2:3*nrigidbody+3*j1)1107: !     !print *, j1, 'grad: ', gr(3*nrigidbody+3*j1-2:3*nrigidbody+3*j1)
1082:      !print *, j1, 'torque: ', torque(:3) 1108: !     !print *, j1, 'torque: ', torque(:3) 
1083:      rms = rms + dot_product(torque, matmul(iinverse(j1, :, :), torque))1109: !     rms = rms + dot_product(torque, matmul(iinverse(j1, :, :), torque))
1084:   1110: !  
1085:   enddo1111: !  enddo
1086:   1112: !  
1087:   rms = max(dsqrt(rms/(degfreedoms)), 1.0d-100)1113: !  rms = max(dsqrt(rms/(degfreedoms)), 1.0d-100)
1088: 1114: !
1089: end subroutine aaconvergence2 1115: !end subroutine aaconvergence2 
1090: 1116: 
1091: !--------------------------------------------------------------1117: !--------------------------------------------------------------
1092: 1118: 
1093: ! hk286 > Often we want to check if the atoms grouped in a rigid body has moved or not1119: ! hk286 > Often we want to check if the atoms grouped in a rigid body has moved or not
1094: ! hk286 > They should not if everything is done correctly1120: ! hk286 > They should not if everything is done correctly
1095: ! hk286 > REDEFINESITEST = .FALSE. then it prints to standard output1121: ! hk286 > REDEFINESITEST = .FALSE. then it prints to standard output
1096: ! hk286 > REDEFINESITEST = .TRUE. then regroup atoms, SITESRIGIDBODY rewritten1122: ! hk286 > REDEFINESITEST = .TRUE. then regroup atoms, SITESRIGIDBODY rewritten
1097: 1123: 
1098: SUBROUTINE CHECKSITES (REDEFINESITEST, COORDS)1124: SUBROUTINE CHECKSITES (REDEFINESITEST, COORDS)
1099:       1125:       
1257:   IMPLICIT NONE1283:   IMPLICIT NONE
1258:   DOUBLE PRECISION :: A (3,3), DET1284:   DOUBLE PRECISION :: A (3,3), DET
1259: 1285: 
1260:   DET = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) - A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)) + A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)) 1286:   DET = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) - A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)) + A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)) 
1261: 1287: 
1262: END SUBROUTINE RBDET1288: END SUBROUTINE RBDET
1263: 1289: 
1264: SUBROUTINE INVERSEMATRIX(A, AINVERSE)1290: SUBROUTINE INVERSEMATRIX(A, AINVERSE)
1265:   1291:   
1266:   IMPLICIT NONE1292:   IMPLICIT NONE
1267:   DOUBLE PRECISION :: A (3,3), AINVERSE(3,3), DET1293:   DOUBLE PRECISION, INTENT(IN)  :: A(3,3)
 1294:   DOUBLE PRECISION, INTENT(OUT) :: AINVERSE(3,3)
 1295:   DOUBLE PRECISION              :: DET
1268: 1296: 
1269:   DET = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) - A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)) + A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)) 1297:   DET = A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2)) - A(1,2)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)) + A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)) 
1270:   AINVERSE(1,1) = A(2,2)*A(3,3)-A(2,3)*A(3,2)1298:   AINVERSE(1,1) = A(2,2)*A(3,3)-A(2,3)*A(3,2)
1271:   AINVERSE(1,2) = A(3,2)*A(1,3)-A(3,3)*A(1,2)1299:   AINVERSE(1,2) = A(3,2)*A(1,3)-A(3,3)*A(1,2)
1272:   AINVERSE(1,3) = A(2,3)*A(1,2)-A(2,2)*A(1,3)1300:   AINVERSE(1,3) = A(2,3)*A(1,2)-A(2,2)*A(1,3)
1273:   AINVERSE(2,1) = A(3,1)*A(2,3)-A(3,3)*A(2,1)1301:   AINVERSE(2,1) = A(3,1)*A(2,3)-A(3,3)*A(2,1)
1274:   AINVERSE(2,2) = A(1,1)*A(3,3)-A(1,3)*A(3,1)1302:   AINVERSE(2,2) = A(1,1)*A(3,3)-A(1,3)*A(3,1)
1275:   AINVERSE(2,3) = A(2,1)*A(1,3)-A(2,3)*A(1,1)1303:   AINVERSE(2,3) = A(2,1)*A(1,3)-A(2,3)*A(1,1)
1276:   AINVERSE(3,1) = A(3,2)*A(2,1)-A(3,1)*A(2,2)1304:   AINVERSE(3,1) = A(3,2)*A(2,1)-A(3,1)*A(2,2)
1277:   AINVERSE(3,2) = A(3,1)*A(1,2)-A(3,2)*A(1,1)1305:   AINVERSE(3,2) = A(3,1)*A(1,2)-A(3,2)*A(1,1)
1527: DOUBLE PRECISION :: RANDOMPHI, RANDOMTHETA, RANDOMPSI, ST, CT, SPH, CPH, SPS, CPS1555: DOUBLE PRECISION :: RANDOMPHI, RANDOMTHETA, RANDOMPSI, ST, CT, SPH, CPH, SPS, CPS
1528: DOUBLE PRECISION, INTENT(INOUT) :: XCOORDS(3*NATOMS)1556: DOUBLE PRECISION, INTENT(INOUT) :: XCOORDS(3*NATOMS)
1529: DOUBLE PRECISION, INTENT(IN) :: ROTATEFACTOR1557: DOUBLE PRECISION, INTENT(IN) :: ROTATEFACTOR
1530: 1558: 
1531: ROTATIONMATRIX(:,:) = 0.0D01559: ROTATIONMATRIX(:,:) = 0.0D0
1532: TOROTATE(:) = 0.0D01560: TOROTATE(:) = 0.0D0
1533: ! Define some constants1561: ! Define some constants
1534: PI=ATAN(1.0D0)*41562: PI=ATAN(1.0D0)*4
1535: TWOPI=2.0D0*PI1563: TWOPI=2.0D0*PI
1536: 1564: 
1537: !do j1 = 1, nrigidbody 
1538: !   do j2 = 1, nsiteperbody(j1) 
1539: !      j3 = rigidgroups(j2, j1) 
1540: !      print *, xcoords(3*j3-2:3*j3) 
1541: !   enddo 
1542: !enddo 
1543:  
1544: ! Loop over all rigid bodies1565: ! Loop over all rigid bodies
1545: DO J1 = 1, NRIGIDBODY1566: DO J1 = 1, NRIGIDBODY
1546:    IF (.NOT.FROZENRIGIDBODY(J1)) THEN1567:    IF (.NOT.FROZENRIGIDBODY(J1)) THEN
1547:       COM = 0.0D01568:       COM = 0.0D0
1548:       MASS = 0.0D01569:       MASS = 0.0D0
1549: 1570: 
1550: ! For each rigid body, calculate center of mass1571: ! For each rigid body, calculate center of mass
1551:       DO J2 = 1, NSITEPERBODY(J1)1572:       DO J2 = 1, NSITEPERBODY(J1)
1552:          J3 = RIGIDGROUPS(J2, J1)1573:          J3 = RIGIDGROUPS(J2, J1)
1553:          COM = COM + XCOORDS(3*J3-2:3*J3)*GR_WEIGHTS(RIGIDGROUPS(J2,J1))1574:          COM = COM + XCOORDS(3*J3-2:3*J3)*GR_WEIGHTS(RIGIDGROUPS(J2,J1))
1592:       ENDDO1613:       ENDDO
1593: 1614: 
1594: ! Translate the rigid body centre of mass back to its old position1615: ! Translate the rigid body centre of mass back to its old position
1595:       DO J2 = 1, NSITEPERBODY(J1)1616:       DO J2 = 1, NSITEPERBODY(J1)
1596:          J3 = RIGIDGROUPS(J2, J1)1617:          J3 = RIGIDGROUPS(J2, J1)
1597:          XCOORDS(3*J3-2:3*J3) = XCOORDS(3*J3-2:3*J3) + COM1618:          XCOORDS(3*J3-2:3*J3) = XCOORDS(3*J3-2:3*J3) + COM
1598:       ENDDO1619:       ENDDO
1599:    ENDIF1620:    ENDIF
1600: ENDDO1621: ENDDO
1601: 1622: 
1602: !do j1 = 1, nrigidbody 
1603: !   do j2 = 1, nsiteperbody(j1) 
1604: !      j3 = rigidgroups(j2, j1) 
1605: !      print *, xcoords(3*j3-2:3*j3) 
1606: !   enddo 
1607: !enddo 
1608:  
1609: END SUBROUTINE GENRIGID_ROTATE1623: END SUBROUTINE GENRIGID_ROTATE
1610: 1624: 
1611: ! mo361> random rotation move for rigid bodies1625: ! mo361> random rotation move for rigid bodies
1612: SUBROUTINE GENRIGID_TRANSLATE(XCOORDS, TRANSLATEFACTOR)1626: SUBROUTINE GENRIGID_TRANSLATE(XCOORDS, TRANSLATEFACTOR)
1613: 1627: 
1614: USE COMMONS, ONLY: NATOMS1628: USE COMMONS, ONLY: NATOMS
1615: IMPLICIT NONE1629: IMPLICIT NONE
1616: 1630: 
1617: INTEGER :: J1, J2, J3  1631: INTEGER :: J1, J2, J3  
1618: DOUBLE PRECISION DPRAND1632: DOUBLE PRECISION DPRAND
1619: DOUBLE PRECISION, INTENT(INOUT) :: XCOORDS(3*NATOMS)1633: DOUBLE PRECISION, INTENT(INOUT) :: XCOORDS(3*NATOMS)
1620: DOUBLE PRECISION, INTENT(IN) :: TRANSLATEFACTOR1634: DOUBLE PRECISION, INTENT(IN) :: TRANSLATEFACTOR
1621: DOUBLE PRECISION:: TRANSLATEVECTOR(3),LENGTH1635: DOUBLE PRECISION:: TRANSLATEVECTOR(3),LENGTH
1622: 1636: 
1623: !print *, 'into translate: ' 
1624: !do j1 = 1, nrigidbody 
1625: !   do j2 = 1, nsiteperbody(j1) 
1626: !      j3 = rigidgroups(j2, j1) 
1627: !      print *, xcoords(3*j3-2:3*j3) 
1628: !   enddo 
1629: !enddo 
1630:  
1631: ! Loop over all rigid bodies1637: ! Loop over all rigid bodies
1632: DO J1 = 1, NRIGIDBODY1638: DO J1 = 1, NRIGIDBODY
1633:    IF (.NOT.FROZENRIGIDBODY(J1)) THEN1639:    IF (.NOT.FROZENRIGIDBODY(J1)) THEN
1634:       DO J2=1,31640:       DO J2=1,3
1635:          TRANSLATEVECTOR(J2)=2.0*(DPRAND()-0.5)*TRANSLATEFACTOR1641:          TRANSLATEVECTOR(J2)=2.0*(DPRAND()-0.5)*TRANSLATEFACTOR
1636:       ENDDO1642:       ENDDO
1637:       LENGTH = DSQRT(TRANSLATEVECTOR(1)**2+TRANSLATEVECTOR(3)**2+TRANSLATEVECTOR(3)**2)1643:       LENGTH = DSQRT(TRANSLATEVECTOR(1)**2+TRANSLATEVECTOR(3)**2+TRANSLATEVECTOR(3)**2)
1638:    1644:    
1639: ! Move the rigid body1645: ! Move the rigid body
1640:       DO J2 = 1, NSITEPERBODY(J1)1646:       DO J2 = 1, NSITEPERBODY(J1)
1641:          J3 = RIGIDGROUPS(J2, J1)1647:          J3 = RIGIDGROUPS(J2, J1)
1642:          XCOORDS(3*J3-2:3*J3) = XCOORDS(3*J3-2:3*J3) + TRANSLATEVECTOR1648:          XCOORDS(3*J3-2:3*J3) = XCOORDS(3*J3-2:3*J3) + TRANSLATEVECTOR
1643:       ENDDO1649:       ENDDO
1644:    ENDIF1650:    ENDIF
1645: ENDDO1651: ENDDO
1646: 1652: 
1647: !print *, 'translated!' 
1648: ! 
1649: !print *, 'out of translate: ' 
1650: !do j1 = 1, nrigidbody 
1651: !   do j2 = 1, nsiteperbody(j1) 
1652: !      j3 = rigidgroups(j2, j1) 
1653: !      print *, xcoords(3*j3-2:3*j3) 
1654: !   enddo 
1655: !enddo 
1656:  
1657: END SUBROUTINE GENRIGID_TRANSLATE1653: END SUBROUTINE GENRIGID_TRANSLATE
1658: 1654: 
1659: ! csw34> subroutine to update the reference coordinates for the rigid bodies using 1655: ! csw34> subroutine to update the reference coordinates for the rigid bodies using 
1660: ! the NATOMS coordinates in XCOORDS. Note that the rigid body coordinates are relative1656: ! the NATOMS coordinates in XCOORDS. Note that the rigid body coordinates are relative
1661: ! to the COM of each rigid body. 1657: ! to the COM of each rigid body. 
1662: SUBROUTINE GENRIGID_UPDATE_REFERENCE(XCOORDS)1658: SUBROUTINE GENRIGID_UPDATE_REFERENCE(XCOORDS)
1663:   USE COMMONS, ONLY: NATOMS1659:   USE COMMONS, ONLY: NATOMS
1664:   IMPLICIT NONE1660:   IMPLICIT NONE
1665:   INTEGER :: J1, J2, DUMMY1661:   INTEGER :: J1, J2, DUMMY
1666:   DOUBLE PRECISION, INTENT(IN) :: XCOORDS(3*NATOMS)1662:   DOUBLE PRECISION, INTENT(IN) :: XCOORDS(3*NATOMS)


r33135/io1.f 2017-08-07 17:30:36.049124890 +0100 r33134/io1.f 2017-08-07 17:30:46.881268760 +0100
115:                    READ(COORDS_UNIT,*) COORDS(J1,JP)115:                    READ(COORDS_UNIT,*) COORDS(J1,JP)
116:                ENDDO116:                ENDDO
117:             ENDDO117:             ENDDO
118:          ELSEIF (MLQT) THEN ! for this ML it is one variable per line118:          ELSEIF (MLQT) THEN ! for this ML it is one variable per line
119:             REWIND(COORDS_UNIT)119:             REWIND(COORDS_UNIT)
120:             DO JP=1,NPAR120:             DO JP=1,NPAR
121:                DO J1=1,NATOMS121:                DO J1=1,NATOMS
122:                    READ(COORDS_UNIT,*) COORDS(J1,JP)122:                    READ(COORDS_UNIT,*) COORDS(J1,JP)
123:                ENDDO123:                ENDDO
124:             ENDDO124:             ENDDO
125:          ELSEIF (ORBITALS) THEN ! for this orbital landscape it is one variable per line 
126:             REWIND(COORDS_UNIT) 
127:             DO JP=1,NPAR 
128:                DO J1=1,NATOMS 
129:                    READ(COORDS_UNIT,*) COORDS(J1,JP) 
130:                ENDDO 
131:             ENDDO 
132:          ELSE125:          ELSE
133:             REWIND(COORDS_UNIT)126:             REWIND(COORDS_UNIT)
134:             DO JP=1,NPAR127:             DO JP=1,NPAR
135:                DO J1=1,NATOMS128:                DO J1=1,NATOMS
136:                   J2=3*(J1-1)129:                   J2=3*(J1-1)
137:                    READ(COORDS_UNIT,*) COORDS(J2+1,JP), COORDS(J2+2,JP), COORDS(J2+3,JP)130:                    READ(COORDS_UNIT,*) COORDS(J2+1,JP), COORDS(J2+2,JP), COORDS(J2+3,JP)
138:                ENDDO131:                ENDDO
139:             ENDDO132:             ENDDO
140:          ENDIF133:          ENDIF
141:          CLOSE(COORDS_UNIT)134:          CLOSE(COORDS_UNIT)
202: 195: 
203:       IF (.NOT.SEEDT.AND..NOT.AMHT.AND..NOT.SUPPRESST) THEN196:       IF (.NOT.SEEDT.AND..NOT.AMHT.AND..NOT.SUPPRESST) THEN
204:          WRITE(MYUNIT,20) 197:          WRITE(MYUNIT,20) 
205: 20       FORMAT('Initial coordinates:')198: 20       FORMAT('Initial coordinates:')
206:          IF (MPIT) THEN199:          IF (MPIT) THEN
207:             WRITE(MYUNIT,30) (COORDS(J1,MYNODE+1),J1=1,3*NATOMS)200:             WRITE(MYUNIT,30) (COORDS(J1,MYNODE+1),J1=1,3*NATOMS)
208:          ELSEIF (MLP3T.OR.MLPVB3T) THEN 201:          ELSEIF (MLP3T.OR.MLPVB3T) THEN 
209:             WRITE(MYUNIT,'(G20.10)') (COORDS(J1,MYNODE+1),J1=1,NATOMS)202:             WRITE(MYUNIT,'(G20.10)') (COORDS(J1,MYNODE+1),J1=1,NATOMS)
210:          ELSEIF (MLQT) THEN 203:          ELSEIF (MLQT) THEN 
211:             WRITE(MYUNIT,'(G20.10)') (COORDS(J1,MYNODE+1),J1=1,NATOMS)204:             WRITE(MYUNIT,'(G20.10)') (COORDS(J1,MYNODE+1),J1=1,NATOMS)
212:          ELSEIF (ORBITALS) THEN  
213:             WRITE(MYUNIT,'(G20.10)') (COORDS(J1,MYNODE+1),J1=1,NATOMS) 
214:          ELSE 205:          ELSE 
215:            DO JP=1,NPAR206:            DO JP=1,NPAR
216:                WRITE(MYUNIT,30) (COORDS(J1,JP),J1=1,3*NATOMS)207:                WRITE(MYUNIT,30) (COORDS(J1,JP),J1=1,3*NATOMS)
217: 30             FORMAT(3F20.10)208: 30             FORMAT(3F20.10)
218:             ENDDO209:             ENDDO
219:          ENDIF210:          ENDIF
220:       ENDIF211:       ENDIF
221: 212: 
222:       IF (MSORIGT) THEN213:       IF (MSORIGT) THEN
223:          WRITE(MYUNIT,'(I4,A)') NATOMS,' M and S silicon atoms'214:          WRITE(MYUNIT,'(I4,A)') NATOMS,' M and S silicon atoms'
723:       ELSEIF (MKTRAPT) THEN714:       ELSEIF (MKTRAPT) THEN
724:          WRITE(MYUNIT,'(I4,A)') NATOMS,' MK trapped ions'715:          WRITE(MYUNIT,'(I4,A)') NATOMS,' MK trapped ions'
725:       ELSEIF (DJWRBT) THEN716:       ELSEIF (DJWRBT) THEN
726:          IF (DJWRBID.EQ.1) THEN717:          IF (DJWRBID.EQ.1) THEN
727:             WRITE(MYUNIT,'(3(I4,A))') NATOMS,' sites for ',NRIGIDBODY,' rigid bodies - DJW potential ',DJWRBID718:             WRITE(MYUNIT,'(3(I4,A))') NATOMS,' sites for ',NRIGIDBODY,' rigid bodies - DJW potential ',DJWRBID
728:             WRITE(MYUNIT,'(2(I4,A))') NRIGIDBODY-NHEXAMERS,' pentamers and ',NHEXAMERS,' hexamers'719:             WRITE(MYUNIT,'(2(I4,A))') NRIGIDBODY-NHEXAMERS,' pentamers and ',NHEXAMERS,' hexamers'
729:             WRITE(MYUNIT,'(A,4G20.10)') 'rho, eps, sigma and pentamer radius=',CAPSIDRHO,CAPSIDEPS,SIGMAPENT,RADPENT720:             WRITE(MYUNIT,'(A,4G20.10)') 'rho, eps, sigma and pentamer radius=',CAPSIDRHO,CAPSIDEPS,SIGMAPENT,RADPENT
730:             WRITE(MYUNIT,'(A,4G20.10)') 'hexamer sigma, radius and hex/pent sigma=',SIGMAHEX,RADHEX,SIGMAPH721:             WRITE(MYUNIT,'(A,4G20.10)') 'hexamer sigma, radius and hex/pent sigma=',SIGMAHEX,RADHEX,SIGMAPH
731:          ENDIF722:          ENDIF
732:       ELSEIF (MLPVB3T) THEN723:       ELSEIF (MLPVB3T) THEN
733:          IF (MLPVB3NNT) THEN 
734:             DO J1=1,NATOMS 
735:                IF (FROZEN(J1)) COORDS(J1,1)=0.0D0 ! for frozen zero nearest-neighbour setup 
736:             ENDDO 
737:          ENDIF 
738:          WRITE(MYUNIT,'(I4,A)') NATOMS,' link weights for MLPVB3'724:          WRITE(MYUNIT,'(I4,A)') NATOMS,' link weights for MLPVB3'
739:       ELSEIF (MLP3T) THEN725:       ELSEIF (MLP3T) THEN
740:          WRITE(MYUNIT,'(I4,A)') NATOMS,' link weights for MLP3'726:          WRITE(MYUNIT,'(I4,A)') NATOMS,' link weights for MLP3'
741:       ELSEIF (MLQT) THEN727:       ELSEIF (MLQT) THEN
742:          WRITE(MYUNIT,'(I4,A)') NATOMS,' variables for ML quadratic'728:          WRITE(MYUNIT,'(I4,A)') NATOMS,' variables for ML quadratic'
743:       ELSEIF (ORBITALS) THEN 
744:          WRITE(MYUNIT,'(I4,A)') NATOMS,' rotations for orbital landscape' 
745:       ELSEIF  (LJADDT) THEN729:       ELSEIF  (LJADDT) THEN
746:          IF (SORTT) THEN730:          IF (SORTT) THEN
747:             WRITE(MYUNIT,'(A)') 'Turning off SORT option for LJADD'731:             WRITE(MYUNIT,'(A)') 'Turning off SORT option for LJADD'
748:             SORTT=.FALSE.732:             SORTT=.FALSE.
749:          ENDIF733:          ENDIF
750:          WRITE(MYUNIT,'(I4,A)') NATOMS,' LJ addressable atoms'734:          WRITE(MYUNIT,'(I4,A)') NATOMS,' LJ addressable atoms'
751:       ELSE735:       ELSE
752:          WRITE(MYUNIT,'(I4,A)') NATOMS,' LJ atoms'736:          WRITE(MYUNIT,'(I4,A)') NATOMS,' LJ atoms'
753:       ENDIF737:       ENDIF
754:       IF (PYGPERIODICT.OR.PYBINARYT) CALL INITIALISEPYGPERIODIC738:       IF (PYGPERIODICT.OR.PYBINARYT) CALL INITIALISEPYGPERIODIC
769:          WRITE(MYUNIT, '(A,I6,A)') 'Searching for approximate symmetry elements every ',NSYMINTERVAL,' steps'753:          WRITE(MYUNIT, '(A,I6,A)') 'Searching for approximate symmetry elements every ',NSYMINTERVAL,' steps'
770:          WRITE(MYUNIT, '(A,5F15.5)') 'Distance tolerances: ',SYMTOL1,SYMTOL2,SYMTOL3,SYMTOL4,SYMTOL5754:          WRITE(MYUNIT, '(A,5F15.5)') 'Distance tolerances: ',SYMTOL1,SYMTOL2,SYMTOL3,SYMTOL4,SYMTOL5
771:          WRITE(MYUNIT, '(A,F15.5)') 'Threshold for distinguishing transformation matrices: ',MATDIFF755:          WRITE(MYUNIT, '(A,F15.5)') 'Threshold for distinguishing transformation matrices: ',MATDIFF
772:          WRITE(MYUNIT,'(A,F15.5)') 'Exponential factor in core-weighted centre of mass calculation: ',DISTFAC756:          WRITE(MYUNIT,'(A,F15.5)') 'Exponential factor in core-weighted centre of mass calculation: ',DISTFAC
773:          WRITE(MYUNIT, '(A,I5)') 'Maximum number of quenches for floater/hole permutations=',NSYMQMAX757:          WRITE(MYUNIT, '(A,I5)') 'Maximum number of quenches for floater/hole permutations=',NSYMQMAX
774:          IF (MOVESHELLT) WRITE(MYUNIT,'(A,I8,A,F12.5)') 'Shell moves allowed in blocks of ',SHELLMOVEMAX,' with probability ',758:          IF (MOVESHELLT) WRITE(MYUNIT,'(A,I8,A,F12.5)') 'Shell moves allowed in blocks of ',SHELLMOVEMAX,' with probability ',
775:      &                        SHELLPROB759:      &                        SHELLPROB
776:       ENDIF760:       ENDIF
777:       IF (DEBUG.OR.CHECKMARKOVT) WRITE(MYUNIT,'(A,I6,A)') 'io1> checking the energy of the saved coordinates in the chain'761:       IF (DEBUG.OR.CHECKMARKOVT) WRITE(MYUNIT,'(A,I6,A)') 'io1> checking the energy of the saved coordinates in the chain'
778:       IF (FREEZE) THEN762:       IF (FREEZE) THEN
779:          IF (MLQT.OR.MLPVB3T.OR.MLP3T.OR.ORBITALS) THEN763:          IF (MLQT.OR.MLPVB3T.OR.MLP3T) THEN
780:             WRITE(MYUNIT,'(A,I6,A)') 'io1> ', NFREEZE,' variables will be frozen:'764:             WRITE(MYUNIT,'(A,I6,A)') 'io1> ', NFREEZE,' variables will be frozen:'
781:          ELSE765:          ELSE
782:             WRITE(MYUNIT,'(A,I6,A)') 'io1> ', NFREEZE,' atoms will be frozen:'766:             WRITE(MYUNIT,'(A,I6,A)') 'io1> ', NFREEZE,' atoms will be frozen:'
783:          ENDIF767:          ENDIF
784:          DO J1=1,NATOMS768:          DO J1=1,NATOMS
785:             IF (FROZEN(J1)) WRITE(MYUNIT,'(I6)') J1769:             IF (FROZEN(J1)) WRITE(MYUNIT,'(I6)') J1
786:          ENDDO770:          ENDDO
787:       ENDIF771:       ENDIF
788:       IF (HARMONICF) THEN772:       IF (HARMONICF) THEN
789:          WRITE(MYUNIT,'(A,F12.4)') 'io1> harmonically constrained atoms: strength = ', HARMONICSTR773:          WRITE(MYUNIT,'(A,F12.4)') 'io1> harmonically constrained atoms: strength = ', HARMONICSTR
918: !            WRITE(MYUNIT, '(A,G15.5,A,G15.5)') 'Maximum step size scaled by estimated nearest neighbour distance of ',902: !            WRITE(MYUNIT, '(A,G15.5,A,G15.5)') 'Maximum step size scaled by estimated nearest neighbour distance of ',
919: !    &                    0.677441D0-0.0037582*NATOMS+9.40318D-6*NATOMS**2-6.21931D-9*NATOMS**3,' to give ',STEP(1)903: !    &                    0.677441D0-0.0037582*NATOMS+9.40318D-6*NATOMS**2-6.21931D-9*NATOMS**3,' to give ',STEP(1)
920:          ELSEIF (MULLERBROWNT) THEN 904:          ELSEIF (MULLERBROWNT) THEN 
921:             RADIUS=100.0D0905:             RADIUS=100.0D0
922:          ELSE 906:          ELSE 
923:             RADIUS=RADIUS*2.0D0**(1.0D0/6.0D0)907:             RADIUS=RADIUS*2.0D0**(1.0D0/6.0D0)
924:          ENDIF908:          ENDIF
925:       ENDIF909:       ENDIF
926:       IF ((.NOT.PERIODIC).AND.(.NOT.AMBER).AND.(.NOT.BLNT).AND.(.NOT.MULLERBROWNT).AND.(.NOT.MODEL1T).AND.(.NOT.PERCOLATET) 910:       IF ((.NOT.PERIODIC).AND.(.NOT.AMBER).AND.(.NOT.BLNT).AND.(.NOT.MULLERBROWNT).AND.(.NOT.MODEL1T).AND.(.NOT.PERCOLATET) 
927:      &                    .AND.(.NOT.QCIPOTT).AND.(.NOT.INTCONSTRAINTT).AND.(.NOT.MLP3T).AND.(.NOT.MKTRAPT).AND.(.NOT.MLQT)911:      &                    .AND.(.NOT.QCIPOTT).AND.(.NOT.INTCONSTRAINTT).AND.(.NOT.MLP3T).AND.(.NOT.MKTRAPT).AND.(.NOT.MLQT)
928:      &                    .AND.(.NOT.MLPVB3T).AND.(.NOT.ORBITALS)) 912:      &                    .AND.(.NOT.MLPVB3T)) 
929:      1                    WRITE(MYUNIT,'(A,F20.10)') 'Container radius=',RADIUS913:      1                    WRITE(MYUNIT,'(A,F20.10)') 'Container radius=',RADIUS
930:       RADIUS=RADIUS**2914:       RADIUS=RADIUS**2
931:       IF (PERCOLATET) WRITE(MYUNIT,'(A,F20.10)') 'Checking for percolated structure, cutoff=',PERCCUT915:       IF (PERCOLATET) WRITE(MYUNIT,'(A,F20.10)') 'Checking for percolated structure, cutoff=',PERCCUT
932:       PERCCUT=PERCCUT**2916:       PERCCUT=PERCCUT**2
933:       IF (NPAR.GT.1) THEN917:       IF (NPAR.GT.1) THEN
934:          WRITE(MYUNIT,'(I2,A)') NPAR,' parallel runs'918:          WRITE(MYUNIT,'(I2,A)') NPAR,' parallel runs'
935:          IF (TABOOT) WRITE(MYUNIT,'(A,I4,A)') 'Taboo lists contain the lowest ',NTAB,' minima'919:          IF (TABOOT) WRITE(MYUNIT,'(A,I4,A)') 'Taboo lists contain the lowest ',NTAB,' minima'
936:       ELSE IF (TABOOT) THEN920:       ELSE IF (TABOOT) THEN
937:          WRITE(MYUNIT,'(A,I4,A)') 'Taboo list contains the lowest ',NTAB,' minima'921:          WRITE(MYUNIT,'(A,I4,A)') 'Taboo list contains the lowest ',NTAB,' minima'
938:       ENDIF922:       ENDIF


r33135/keywords.f 2017-08-07 17:30:36.277127919 +0100 r33134/keywords.f 2017-08-07 17:30:47.117271893 +0100
 27:       USE TWIST_MOD 27:       USE TWIST_MOD
 28: !       sf344> AMBER additions 28: !       sf344> AMBER additions
 29:       USE modamber9, only : coords1,amberstr,amberstr1,mdstept,inpcrd,amberenergiest, nocistransdna, nocistransrna, 29:       USE modamber9, only : coords1,amberstr,amberstr1,mdstept,inpcrd,amberenergiest, nocistransdna, nocistransrna,
 30:      &                      uachiral, ligrotscale, setchiral, STEEREDMINT, SMINATOMA, SMINATOMB, SMINK, SMINKINC, 30:      &                      uachiral, ligrotscale, setchiral, STEEREDMINT, SMINATOMA, SMINATOMB, SMINK, SMINKINC,
 31:      &                      SMINDISTSTART, SMINDISTFINISH, natomsina, natomsinb, natomsinc, atomsinalist, atomsinblist, 31:      &                      SMINDISTSTART, SMINDISTFINISH, natomsina, natomsinb, natomsinc, atomsinalist, atomsinblist,
 32:      &                      atomsinclist, atomsinalistlogical, atomsinblistlogical, atomsinclistlogical, ligcartstep, 32:      &                      atomsinclist, atomsinalistlogical, atomsinblistlogical, atomsinclistlogical, ligcartstep,
 33:      &                      ligtransstep, ligmovefreq, amchnmax, amchnmin, amchpmax, amchpmin, rotamert, rotmaxchange, 33:      &                      ligtransstep, ligmovefreq, amchnmax, amchnmin, amchpmax, amchpmin, rotamert, rotmaxchange,
 34:      &                      rotcentre, rotpselect, rotoccuw, rotcutoff, setchiralgeneric, PRMTOP, IGB, RGBMAX, CUT, 34:      &                      rotcentre, rotpselect, rotoccuw, rotcutoff, setchiralgeneric, PRMTOP, IGB, RGBMAX, CUT,
 35:      &                      SALTCON, macroiont, nmacroions, macroiondist 35:      &                      SALTCON, macroiont, nmacroions, macroiondist
 36:       USE modamber 36:       USE modamber
 37:       USE AMBER12_MUTATIONS, ONLY : AMBERMUTATION_SETUP 
 38:       USE PORFUNCS 37:       USE PORFUNCS
 39:       USE MYGA_PARAMS 38:       USE MYGA_PARAMS
 40:       USE BGUPMOD 39:       USE BGUPMOD
 41:       USE GLJYMOD 40:       USE GLJYMOD
 42:       USE CHIRO_MODULE, ONLY: CHIRO_SIGMA, CHIRO_MU, CHIRO_GAMMA, CHIRO_L 41:       USE CHIRO_MODULE, ONLY: CHIRO_SIGMA, CHIRO_MU, CHIRO_GAMMA, CHIRO_L
 43:       USE CONVEX_POLYHEDRA_MODULE, ONLY: INITIALISE_POLYHEDRA, K_COMPRESS, K_OVERLAP 42:       USE CONVEX_POLYHEDRA_MODULE, ONLY: INITIALISE_POLYHEDRA, K_COMPRESS, K_OVERLAP
 44:       USE LJ_GAUSS_MOD, ONLY: LJ_GAUSS_MODE, LJ_GAUSS_RCUT, LJ_GAUSS_EPS, 43:       USE LJ_GAUSS_MOD, ONLY: LJ_GAUSS_MODE, LJ_GAUSS_RCUT, LJ_GAUSS_EPS,
 45:      &                        LJ_GAUSS_R0, LJ_GAUSS_SIGMASQ, LJ_GAUSS_PARAMS, 44:      &                        LJ_GAUSS_R0, LJ_GAUSS_SIGMASQ, LJ_GAUSS_PARAMS,
 46:      &                        LJ_GAUSS_INITIALISE 45:      &                        LJ_GAUSS_INITIALISE
 47:       USE OPP_MOD, ONLY: OPP_MODE, OPP_RCUT, OPP_K, OPP_PHI, OPP_PARAMS, 
 48:      &                   OPP_INITIALISE 
 49:       USE MBPOLMOD, ONLY: MBPOLINIT 46:       USE MBPOLMOD, ONLY: MBPOLINIT
 50:       USE SWMOD, ONLY: SWINIT, MWINIT 47:       USE SWMOD, ONLY: SWINIT, MWINIT
 51:       USE AMBER12_INTERFACE_MOD, ONLY : AMBER12_GET_COORDS 48:       USE AMBER12_INTERFACE_MOD, ONLY : AMBER12_GET_COORDS
 52: !     &                                 AMBER12_ATOMSS, AMBER12_SETUP, 49: !     &                                 AMBER12_ATOMSS, AMBER12_SETUP,
 53: !     &                                 AMBER12_RESIDUES, 50: !     &                                 AMBER12_RESIDUES,
 54: !     &                                 POPULATE_ATOM_DATA 51: !     &                                 POPULATE_ATOM_DATA
 55:       USE CHIRALITY, ONLY : CIS_TRANS_TOL 52:       USE CHIRALITY, ONLY : CIS_TRANS_TOL
 56:       USE ISO_C_BINDING, ONLY: C_NULL_CHAR 53:       USE ISO_C_BINDING, ONLY: C_NULL_CHAR
 57:       USE PARSE_POT_PARAMS, ONLY : PARSE_MGUPTA_PARAMS, PARSE_MSC_PARAMS, 54:       USE PARSE_POT_PARAMS, ONLY : PARSE_MGUPTA_PARAMS, PARSE_MSC_PARAMS,
 58:      &     PARSE_MLJ_PARAMS 55:      &     PARSE_MLJ_PARAMS
 59:       USE ROTAMER, ONLY: ROTAMER_MOVET, ROTAMER_SCRIPT, ROTAMER_INIT 56:       USE ROTAMER, ONLY: ROTAMER_MOVET, ROTAMER_SCRIPT, ROTAMER_INIT
 60:       USE HINGE_MOVES, ONLY: HINGE_INITIALISE 57:       USE HINGE_MOVES, ONLY: HINGE_INITIALISE
 61:       USE MOLECULAR_DYNAMICS, ONLY : MDT, MD_TSTEP, MD_GAMMA, MD_NWAIT, MD_NFREQ, MD_NSTEPS 58:       USE MOLECULAR_DYNAMICS, ONLY : MDT, MD_TSTEP, MD_GAMMA, MD_NWAIT, MD_NFREQ, MD_NSTEPS
 62:       USE OPEP_INTERFACE_MOD, ONLY : OPEP_INIT 59:       USE OPEP_INTERFACE_MOD, ONLY : OPEP_INIT
 63:       USE ORBITALS_MOD, ONLY: ORBITALS_INIT 
 64:       USE EWALD 60:       USE EWALD
 65:        61:       
 66:       IMPLICIT NONE 62:       IMPLICIT NONE
 67:  63: 
 68:       DOUBLE PRECISION, ALLOCATABLE :: MLPMEAN(:), MLQMEAN(:) 64:       DOUBLE PRECISION, ALLOCATABLE :: MLPMEAN(:), MLQMEAN(:)
 69:       DOUBLE PRECISION, ALLOCATABLE :: MLPDISTHI(:), MLPDISTHO(:)    
 70:       INTEGER, ALLOCATABLE :: MLPINDEXI(:), MLPINDEXO(:) 
 71:       INTEGER K1, I1 
 72:       INTEGER ITEM, NITEMS, LOC, LINE, NCR, NERROR, LAST, IX, J1, JP, NPCOUNT, NDUMMY, J2, J3 65:       INTEGER ITEM, NITEMS, LOC, LINE, NCR, NERROR, LAST, IX, J1, JP, NPCOUNT, NDUMMY, J2, J3
 73:       INTEGER DATA_UNIT, FUNIT 66:       INTEGER DATA_UNIT, FUNIT
 74:       INTEGER MOVABLEATOMINDEX 67:       INTEGER MOVABLEATOMINDEX
 75:       LOGICAL CAT, YESNO, PERMFILE, CONFILE 68:       LOGICAL CAT, YESNO, PERMFILE, CONFILE
 76:       COMMON /BUFINF/ ITEM, NITEMS, LOC(80), LINE, SKIPBL, CLEAR, NCR, 69:       COMMON /BUFINF/ ITEM, NITEMS, LOC(80), LINE, SKIPBL, CLEAR, NCR,
 77:      &                NERROR, ECHO, LAST, CAT 70:      &                NERROR, ECHO, LAST, CAT
 78:        DOUBLE PRECISION XX, ROH, ROM, WTHETA 71:        DOUBLE PRECISION XX, ROH, ROM, WTHETA
 79:       LOGICAL END, SKIPBL, CLEAR, ECHO 72:       LOGICAL END, SKIPBL, CLEAR, ECHO
 80:       CHARACTER WORD*16,PBC*3,WORD2*10 73:       CHARACTER WORD*16,PBC*3,WORD2*10
 81:       DOUBLE PRECISION EAMLJA0, EAMLJBETA, EAMLJZ0, DUMMY 74:       DOUBLE PRECISION EAMLJA0, EAMLJBETA, EAMLJZ0, DUMMY
100:       CHARACTER(LEN=100) TOPFILE,PARFILE 93:       CHARACTER(LEN=100) TOPFILE,PARFILE
101:       CHARACTER(LEN=20) UNSTRING 94:       CHARACTER(LEN=20) UNSTRING
102:       DOUBLE PRECISION LJREPBB, LJATTBB, LJREPLL, LJATTLL, LJREPNN, LJATTNN, 95:       DOUBLE PRECISION LJREPBB, LJATTBB, LJREPLL, LJATTLL, LJREPNN, LJATTNN,
103:      &                 HABLN, HBBLN, HCBLN, HDBLN, EABLN, EBBLN, ECBLN, EDBLN, TABLN, TBBLN, TCBLN, TDBLN 96:      &                 HABLN, HBBLN, HCBLN, HDBLN, EABLN, EBBLN, ECBLN, EDBLN, TABLN, TBBLN, TCBLN, TDBLN
104:       DOUBLE PRECISION LJREPBL, LJATTBL, LJREPBN, LJATTBN, LJREPLN, LJATTLN 97:       DOUBLE PRECISION LJREPBL, LJATTBL, LJREPBN, LJATTBN, LJREPLN, LJATTLN
105:  98: 
106: !     DC430 > 99: !     DC430 >
107:       DOUBLE PRECISION :: LPL, LPR100:       DOUBLE PRECISION :: LPL, LPR
108:       LOGICAL          :: RBSYMTEST     ! jdf43>101:       LOGICAL          :: RBSYMTEST     ! jdf43>
109: 102: 
110: !      DOUBLE PRECISION :: VOL ! dj337103:       DOUBLE PRECISION :: VOL ! dj337
111: !104: !
112: !       sf344> added stuff105: !       sf344> added stuff
113: !106: !
114:       CHARACTER(LEN=10) check1107:       CHARACTER(LEN=10) check1
115:       CHARACTER(LEN=1) readswitch108:       CHARACTER(LEN=1) readswitch
116:       CHARACTER(LEN=4) J1CHAR109:       CHARACTER(LEN=4) J1CHAR
117:       CHARACTER(LEN=20) J2CHAR110:       CHARACTER(LEN=20) J2CHAR
118:       INTEGER iostatus, groupsize, groupatom,groupoffset,axis1,axis2,EOF111:       INTEGER iostatus, groupsize, groupatom,groupoffset,axis1,axis2,EOF
119:       INTEGER LUNIT, GETUNIT112:       INTEGER LUNIT, GETUNIT
120: 113: 
807: 800: 
808:       CAPSID=.FALSE.801:       CAPSID=.FALSE.
809:       STRANDT=.FALSE.802:       STRANDT=.FALSE.
810:       PAHT=.FALSE.803:       PAHT=.FALSE.
811:       TIP=.FALSE.804:       TIP=.FALSE.
812:       TTM3T=.FALSE.805:       TTM3T=.FALSE.
813:       QUADT=.FALSE.806:       QUADT=.FALSE.
814:       STOCKT=.FALSE.807:       STOCKT=.FALSE.
815:       LJCOULT=.FALSE.808:       LJCOULT=.FALSE.
816:       LJ_GAUSST=.FALSE.809:       LJ_GAUSST=.FALSE.
817:       OPPT=.FALSE. 
818:       COULN=0810:       COULN=0
819:       COULQ=0.0D0811:       COULQ=0.0D0
820:       COULSWAP = 0.0D0812:       COULSWAP = 0.0D0
821:       COULTEMP = 0.0D0813:       COULTEMP = 0.0D0
822:       GAYBERNET=.FALSE.814:       GAYBERNET=.FALSE.
823:       ELLIPSOIDT=.FALSE.815:       ELLIPSOIDT=.FALSE.
824:       PYGPERIODICT=.FALSE.816:       PYGPERIODICT=.FALSE.
825:       LJCAPSIDT=.FALSE.817:       LJCAPSIDT=.FALSE.
826:       PYBINARYT=.FALSE.818:       PYBINARYT=.FALSE.
827:       pyt = .false.819:       pyt = .false.
1001:       ACKLANDT=.FALSE.993:       ACKLANDT=.FALSE.
1002:       ACKLANDID=5994:       ACKLANDID=5
1003:       ACK1=.FALSE.995:       ACK1=.FALSE.
1004:       ACK2=.FALSE.996:       ACK2=.FALSE.
1005: 997: 
1006:       STEEREDMINT=.FALSE.998:       STEEREDMINT=.FALSE.
1007:       DF1T=.FALSE.999:       DF1T=.FALSE.
1008:       PULLT=.FALSE.1000:       PULLT=.FALSE.
1009:       CSMT=.FALSE.1001:       CSMT=.FALSE.
1010:       CSMGUIDET=.FALSE.1002:       CSMGUIDET=.FALSE.
1011:       LJADD3GUIDET=.FALSE. 
1012:       CSMEPS=1.0D-61003:       CSMEPS=1.0D-6
1013:       CSMSTEPS=11004:       CSMSTEPS=1
1014:       CSMQUENCHES=11005:       CSMQUENCHES=1
1015:       CSMMAXIT=01006:       CSMMAXIT=0
1016:       CHECKMARKOVT=.FALSE.1007:       CHECKMARKOVT=.FALSE.
1017:       PERCOLATET=.FALSE.1008:       PERCOLATET=.FALSE.
1018:       PERCCUT=1.0D1001009:       PERCCUT=1.0D100
1019:       PERCGROUPCUT=1.0D1001010:       PERCGROUPCUT=1.0D100
1020:       PERCGROUPT=.FALSE.1011:       PERCGROUPT=.FALSE.
1021:       PERCGROUPRESEEDT=.FALSE.1012:       PERCGROUPRESEEDT=.FALSE.
1055:       BENZRIGIDEWALDT = .FALSE.1046:       BENZRIGIDEWALDT = .FALSE.
1056: 1047: 
1057: ! dj337: Ewald summation1048: ! dj337: Ewald summation
1058:       ORTHO = .TRUE.1049:       ORTHO = .TRUE.
1059:       EWALDT = .FALSE.1050:       EWALDT = .FALSE.
1060:       EWALDN = 11051:       EWALDN = 1
1061:       EWALDREALC = 10.0D01052:       EWALDREALC = 10.0D0
1062:       EWALDRECIPC = 3.0D01053:       EWALDRECIPC = 3.0D0
1063:       RSPEED = 1.0D01054:       RSPEED = 1.0D0
1064: 1055: 
 1056: ! dj337: box derivatives
 1057:       BOXDERIVT = .FALSE.
 1058:       BOXSTEPFREQ = 1
 1059: 
1065: !--------------------------------!1060: !--------------------------------!
1066: ! hk286 > Generalised Thomson    !1061: ! hk286 > Generalised Thomson    !
1067: !--------------------------------!1062: !--------------------------------!
1068:       GTHOMSONT = .FALSE.1063:       GTHOMSONT = .FALSE.
1069:       GTHOMPOT = 11064:       GTHOMPOT = 1
1070: 1065: 
1071: ! hk286 > Damped group moves1066: ! hk286 > Damped group moves
1072:       DAMPEDGMOVET = .FALSE.1067:       DAMPEDGMOVET = .FALSE.
1073:       DMOVEFREQ = 11068:       DMOVEFREQ = 1
1074: 1069: 
1114:       MWPOTT=.FALSE.1109:       MWPOTT=.FALSE.
1115:       SWPOTT=.FALSE.1110:       SWPOTT=.FALSE.
1116: ! jdf43> SUPPRESS1111: ! jdf43> SUPPRESS
1117:       SUPPRESST=.FALSE.1112:       SUPPRESST=.FALSE.
1118: ! jdf43> MFET1113: ! jdf43> MFET
1119:       MFETT=.FALSE.1114:       MFETT=.FALSE.
1120: ! jdf43> POLIR1115: ! jdf43> POLIR
1121:       POLIRT=.FALSE.1116:       POLIRT=.FALSE.
1122: ! jdf43> MBPOL1117: ! jdf43> MBPOL
1123:       MBPOLT=.FALSE.1118:       MBPOLT=.FALSE.
1124:       RIGIDMBPOLT=.FALSE. 
1125:       MOLECULART=.FALSE.1119:       MOLECULART=.FALSE.
1126: ! jdf43>1120: ! jdf43>
1127:       REPMATCHT=.FALSE.1121:       REPMATCHT=.FALSE.
1128: 1122: 
1129:       UNIFORMMOVE=.FALSE.1123:       UNIFORMMOVE=.FALSE.
1130:       ORBITTOL=1.0D-31124:       ORBITTOL=1.0D-3
1131:       NOINVERSION=.FALSE.1125:       NOINVERSION=.FALSE.
1132: !cv320> rigid body watermethane1126: !
1133:       WATERMETHANET=.FALSE. 
1134:       CLATHRATET= .FALSE. 
1135: ! ds656> Parallelised generalised basin-hopping1127: ! ds656> Parallelised generalised basin-hopping
1136:       GBHT=.FALSE.1128:       GBHT=.FALSE.
1137: 1129: 
1138: ! General mixed LJ systems1130: ! General mixed LJ systems
1139:       GLJT=.FALSE.1131:       GLJT=.FALSE.
1140: ! ds656> Multicomponent LJ system (different implementation to GLJ!)1132: ! ds656> Multicomponent LJ system (different implementation to GLJ!)
1141:       MLJT=.FALSE.1133:       MLJT=.FALSE.
1142: 1134: 
1143: ! khs26> Free energy basin-hopping stuff1135: ! khs26> Free energy basin-hopping stuff
1144:       FEBHT = .FALSE.1136:       FEBHT = .FALSE.
1185: !     SIGMAPH=0.5D0*(SIGMA + SIGMAHEX)1177: !     SIGMAPH=0.5D0*(SIGMA + SIGMAHEX)
1186: !     CAPSIDEPS=0.4D01178: !     CAPSIDEPS=0.4D0
1187: 1179: 
1188: !1180: !
1189: ! Neural network potential1181: ! Neural network potential
1190: !1182: !
1191:       MLP3T=.FALSE.1183:       MLP3T=.FALSE.
1192:       MLPB3T=.FALSE.1184:       MLPB3T=.FALSE.
1193:       MLPB3NEWT=.FALSE.1185:       MLPB3NEWT=.FALSE.
1194:       MLPVB3T=.FALSE.1186:       MLPVB3T=.FALSE.
1195:       MLPVB3NNT=.FALSE. 
1196:       NOREGBIAS=.FALSE.1187:       NOREGBIAS=.FALSE.
1197:       MLPNEWREG=.FALSE.1188:       MLPNEWREG=.FALSE.
1198:       MLPDONE=.FALSE.1189:       MLPDONE=.FALSE.
1199:       MLPNORM=.FALSE.1190:       MLPNORM=.FALSE.
1200:       MLPLAMBDA=0.0D01191:       MLPLAMBDA=0.0D0
1201:       MLPNEIGH=1 
1202: !1192: !
1203: ! ML quadratic function1193: ! ML quadratic function
1204: !1194: !
1205:       MLQT=.FALSE.1195:       MLQT=.FALSE.
1206:       MLQPROB=.FALSE.1196:       MLQPROB=.FALSE.
1207:       MLQDONE=.FALSE.1197:       MLQDONE=.FALSE.
1208:       MLQNORM=.FALSE.1198:       MLQNORM=.FALSE.
1209:       MLQLAMBDA=0.0D01199:       MLQLAMBDA=0.0D0
1210:       MLQSTART=11200:       MLQSTART=1
1211: 1201: 
1212:       LJADDT=.FALSE.1202:       LJADDT=.FALSE.
1213:       LJADD2T=.FALSE.1203:       LJADD2T=.FALSE.
1214:       LJADD3T=.FALSE.1204:       LJADD3T=.FALSE.
1215:       LJADD4T=.FALSE.1205:       LJADD4T=.FALSE.
1216:       NADDTARGET=01206:       NADDTARGET=1
1217:       REORDERADDT=.FALSE.1207:       REORDERADDT=.FALSE.
1218:       PYADDT=.FALSE.1208:       PYADDT=.FALSE.
1219:       PYADD2T=.FALSE.1209:       PYADD2T=.FALSE.
1220:       ORBITALS=.FALSE. 
1221: 1210: 
1222:       DUMPMQT=.FALSE.1211:       DUMPMQT=.FALSE.
1223: ! jk669 SQNM keywords1212: ! jk669 SQNM keywords
1224:       SQNMT=.FALSE.1213:       SQNMT=.FALSE.
1225:       SQNM_HISTMAX=20 !defualt1214:       SQNM_HISTMAX=20 !defualt
1226:       SQNM_DEBUGT=.FALSE.1215:       SQNM_DEBUGT=.FALSE.
1227:       SQNM_DEBUGRUN=0 !defaul 0 means debug all runs1216:       SQNM_DEBUGRUN=0 !defaul 0 means debug all runs
1228:       SQNM_DEBUGLEVEL=0 !how much debug data to print 1217:       SQNM_DEBUGLEVEL=0 !how much debug data to print 
1229:       SQNM_WRITEMAX=10 !how many lines to print out. default is 101218:       SQNM_WRITEMAX=10 !how many lines to print out. default is 10
1230:       SQNM_BIOT=.TRUE.1219:       SQNM_BIOT=.TRUE.
1231: 1220: 
1232: ! OPEP stuff1221: ! OPEP stuff
1233:       OPEPT = .FALSE.1222:       OPEPT = .FALSE.
1234:       OPEP_RNAT = .FALSE.1223:       OPEP_RNAT = .FALSE.
1235: 1224: 
1236: ! cs675 ORBITALS stuff 
1237:       ORBITALS = .FALSE. 
1238:       ORBVAREXPONENT = -1!default to easily identifiable (quasi-)nonsense value. 
1239:  
1240: ! AMBER mutations 
1241:       AMBERMUTATIONT = .FALSE. 
1242:       MUTATIONFREQ = 1000 
1243:       MUTTESTSTEPS = 50 
1244:       NMUTATION = 0 
1245:       MUTUNIT = GETUNIT() 
1246:       AMBERMUTIGB = 2 
1247:       AMBERMUTFF = 14 
1248:       MUTENERGY = 1 
1249:       MUTTERMID = 0 
1250:  
1251:       CALL FILE_OPEN('data', DATA_UNIT, .FALSE.)1225:       CALL FILE_OPEN('data', DATA_UNIT, .FALSE.)
1252: 1226: 
1253: !      OPEN (5,FILE='data',STATUS='OLD')1227: !      OPEN (5,FILE='data',STATUS='OLD')
1254: 1228: 
1255: !190   CALL INPUT(END,5)1229: !190   CALL INPUT(END,5)
1256: 190   CALL INPUT(END, DATA_UNIT)1230: 190   CALL INPUT(END, DATA_UNIT)
1257:       IF (.NOT. END) THEN1231:       IF (.NOT. END) THEN
1258:         CALL READU(WORD)1232:         CALL READU(WORD)
1259:       ENDIF1233:       ENDIF
1260:       IF (END .OR. WORD .EQ. 'STOP') THEN1234:       IF (END .OR. WORD .EQ. 'STOP') THEN
2057:         AMBER12T = .TRUE.2031:         AMBER12T = .TRUE.
2058:         SETCHIRAL = .TRUE.2032:         SETCHIRAL = .TRUE.
2059:         IF(.NOT.ALLOCATED(COORDS1)) ALLOCATE(COORDS1(3*NATOMS))2033:         IF(.NOT.ALLOCATED(COORDS1)) ALLOCATE(COORDS1(3*NATOMS))
2060:         IF(ALLOCATED(COORDS)) DEALLOCATE(COORDS)2034:         IF(ALLOCATED(COORDS)) DEALLOCATE(COORDS)
2061:         ! Read the coords from AMBER12 into COORDS1(:)2035:         ! Read the coords from AMBER12 into COORDS1(:)
2062:         CALL AMBER12_GET_COORDS(NATOMS, COORDS1(:))2036:         CALL AMBER12_GET_COORDS(NATOMS, COORDS1(:))
2063:         ALLOCATE(COORDS(3*NATOMS,NPAR))2037:         ALLOCATE(COORDS(3*NATOMS,NPAR))
2064:         DO J1=1,NPAR2038:         DO J1=1,NPAR
2065:            COORDS(:,J1) = COORDS1(:)2039:            COORDS(:,J1) = COORDS1(:)
2066:         END DO2040:         END DO
2067: ! 
2068: ! kr366> AMBER mutation steps 
2069: ! 
2070:       ELSE IF (WORD.EQ.'AMBERMUTATION') THEN 
2071:         AMBERMUTATIONT = .TRUE. 
2072:         CALL READI(MUTATIONFREQ) 
2073:         CALL READI(MUTTESTSTEPS) 
2074:         AMBER12T=.TRUE. 
2075:         SETCHIRAL=.TRUE. 
2076:         IF(.NOT.ALLOCATED(COORDS1)) ALLOCATE(COORDS1(3*NATOMS)) 
2077:         IF(ALLOCATED(COORDS)) DEALLOCATE(COORDS) 
2078:         ALLOCATE(COORDS(3*NATOMS,NPAR)) 
2079:         CALL AMBER12_GET_COORDS(NATOMS,COORDS1(:)) 
2080:         DO J1=1,NPAR 
2081:            COORDS(:,J1) = COORDS1(:) 
2082:         END DO 
2083:         OPEN(MUTUNIT,FILE='BHmutation.log',STATUS='UNKNOWN') 
2084:         CALL AMBERMUTATION_SETUP()  !we initialise the group rotations here as well 
2085:          
2086:       ELSE IF (WORD.EQ.'AMBERMUTIGB') THEN 
2087:         CALL READI(AMBERMUTIGB) 
2088:         IF (AMBERMUTIGB.EQ.2) THEN 
2089:            WRITE(MYUNIT,'(A)') 'keyword> use igb2 with mbondi2 to create topology files for mutations' 
2090:         ELSE IF (AMBERMUTIGB.EQ.8) THEN 
2091:            WRITE(MYUNIT,'(A)') 'keyword> use igb8 with mbondi3 to create topology files for mutations' 
2092:         ELSE 
2093:            WRITE(MYUNIT,'(A)') 'keyword> invalid choice for igb' 
2094:            STOP 
2095:         ENDIF 
2096:  
2097:       ELSE IF (WORD.EQ.'AMBERMUTFF') THEN 
2098:         CALL READI(AMBERMUTFF) 
2099:         IF (AMBERMUTFF.EQ.14) THEN 
2100:            WRITE(MYUNIT,'(A)') 'keyword> use ff14SB force field for mutations' 
2101:         ELSE IF (AMBERMUTFF.EQ.99) THEN 
2102:            WRITE(MYUNIT,'(A)') 'keyword> use ff99SB force field for mutations' 
2103:         ELSE 
2104:            WRITE(MYUNIT,'(A)') 'keyword> invalid force field choice' 
2105:            STOP 
2106:         ENDIF 
2107:        
2108:       ELSE IF (WORD.EQ.'AMBERMUTENERGY') THEN 
2109:         CALL READI(MUTENERGY) 
2110:         CALL READI(MUTTERMID) 
2111:         IF (MUTENERGY.EQ.1) THEN 
2112:            WRITE(MYUNIT,'(A)') 'keyword> use random numbers to score mutations' 
2113:         ELSE IF (MUTENERGY.EQ.2) THEN 
2114:            WRITE(MYUNIT,'(A)') 'keyword> use decomposed energy to score mutations' 
2115:         ELSE IF (MUTENERGY.EQ.3) THEN 
2116:            WRITE(MYUNIT,'(A)') 'keyword> use interaction energy between parts to score mutations' 
2117:            WRITE(MYUNIT,'(A,I6)') 'keyword> first component ends at residue ' , MUTTERMID 
2118:         ELSE 
2119:            WRITE(MYUNIT,'(A)') 'keyword> option not available for scoring mutation' 
2120:            STOP 
2121:         ENDIF 
2122: 2041: 
2123:       ELSE IF (WORD.EQ.'AMBER9') THEN2042:       ELSE IF (WORD.EQ.'AMBER9') THEN
2124:         AMBERT=.TRUE.2043:         AMBERT=.TRUE.
2125:         WRITE(MYUNIT,'(A)') 'keyword> RADIUS set to 999 for AMBER9 run'2044:         WRITE(MYUNIT,'(A)') 'keyword> RADIUS set to 999 for AMBER9 run'
2126:         RADIUS=9992045:         RADIUS=999
2127: 2046: 
2128: !2047: !
2129: ! csw34> if residues are frozen with FREEZERES, call the amber routine2048: ! csw34> if residues are frozen with FREEZERES, call the amber routine
2130: ! to fill the FROZEN array correctly (in amberinterface.f)2049: ! to fill the FROZEN array correctly (in amberinterface.f)
2131: !2050: !
2155:              WRITE(MYUNIT,'(A)') 'keywords> input coordinates for AMBER9 system will be read from ', trim(adjustl(amberstr))2074:              WRITE(MYUNIT,'(A)') 'keywords> input coordinates for AMBER9 system will be read from ', trim(adjustl(amberstr))
2156:              CALL amber_readcoords(amberstr)2075:              CALL amber_readcoords(amberstr)
2157:          END IF2076:          END IF
2158:         ELSE IF(NITEMS==3) then2077:         ELSE IF(NITEMS==3) then
2159:          CALL READA(amberstr)2078:          CALL READA(amberstr)
2160:          CALL READA(amberstr1)2079:          CALL READA(amberstr1)
2161:          WRITE(MYUNIT,'(A)') 'keywords> input coordinates for AMBER9 system will be read from ', trim(adjustl(amberstr)),2080:          WRITE(MYUNIT,'(A)') 'keywords> input coordinates for AMBER9 system will be read from ', trim(adjustl(amberstr)),
2162:      &                              'type: ', trim(adjustl(amberstr1))2081:      &                              'type: ', trim(adjustl(amberstr1))
2163:           IF(trim(adjustl(amberstr1)).EQ.'inpcrd') then2082:           IF(trim(adjustl(amberstr1)).EQ.'inpcrd') then
2164:                inpcrd=amberstr2083:                inpcrd=amberstr
2165:               call amberinterface(natom,2,inpcrd,MYUNIT)2084:                call amberinterface(natom,2,inpcrd,MYUNIT)
2166:            WRITE(MYUNIT,'(A)') 'keywords> reading AMBER inpcrd coordinate format'2085:            WRITE(MYUNIT,'(A)') 'keywords> reading AMBER inpcrd coordinate format'
2167:           ELSE2086:           ELSE
2168:            WRITE(MYUNIT,'(A)') 'keywords> ERROR - no other types defined currently than inpcrd'2087:            WRITE(MYUNIT,'(A)') 'keywords> ERROR - no other types defined currently than inpcrd'
2169:            STOP2088:            STOP
2170:           END IF2089:           END IF
2171:         END IF2090:         END IF
2172:                IF(.NOT.ALLOCATED(COORDS1)) ALLOCATE(COORDS1(3*NATOM))2091:                IF(.NOT.ALLOCATED(COORDS1)) ALLOCATE(COORDS1(3*NATOM))
2173:                IF(.NOT.ALLOCATED(MOVABLEATOMLIST)) ALLOCATE(MOVABLEATOMLIST(NATOMS))2092:                IF(.NOT.ALLOCATED(MOVABLEATOMLIST)) ALLOCATE(MOVABLEATOMLIST(NATOMS))
2174:                IF(ALLOCATED(COORDS)) DEALLOCATE(COORDS)2093:                IF(ALLOCATED(COORDS)) DEALLOCATE(COORDS)
2175:                ALLOCATE(COORDS(3*NATOM,NPAR))2094:                ALLOCATE(COORDS(3*NATOM,NPAR))
2328:       ELSE IF (WORD.EQ.'NOREGBIAS') THEN2247:       ELSE IF (WORD.EQ.'NOREGBIAS') THEN
2329:          NOREGBIAS=.TRUE.2248:          NOREGBIAS=.TRUE.
2330:       ELSE IF ((WORD.EQ.'MLPVB3').OR.(WORD.EQ.'MLPVB3NN')) THEN2249:       ELSE IF ((WORD.EQ.'MLPVB3').OR.(WORD.EQ.'MLPVB3NN')) THEN
2331:          MLPVB3T=.TRUE.2250:          MLPVB3T=.TRUE.
2332:          CALL READI(MLPIN)      ! number of inputs (data items after outcome)2251:          CALL READI(MLPIN)      ! number of inputs (data items after outcome)
2333:          CALL READI(MLPSTART) ! starting position in data list, not counting outcome2252:          CALL READI(MLPSTART) ! starting position in data list, not counting outcome
2334:          CALL READI(MLPHIDDEN)2253:          CALL READI(MLPHIDDEN)
2335:          CALL READI(MLPOUT)2254:          CALL READI(MLPOUT)
2336:          CALL READI(MLPDATA)2255:          CALL READI(MLPDATA)
2337:          IF (NITEMS.GT.5) CALL READF(MLPLAMBDA)2256:          IF (NITEMS.GT.5) CALL READF(MLPLAMBDA)
2338:          IF ((WORD.EQ.'MLPVB3NN').AND.(NITEMS.GT.6)) CALL READI(MLPNEIGH) 
2339:          IF (WORD.EQ.'MLPVB3NN') MLPVB3NNT=.TRUE. 
2340:          WRITE(MYUNIT,'(A,5I8,G20.10)') ' keywords> MLP3 vector bias nodes and Nin, Ninstart, Nhidden, Nout, Ndata, lambda=',2257:          WRITE(MYUNIT,'(A,5I8,G20.10)') ' keywords> MLP3 vector bias nodes and Nin, Ninstart, Nhidden, Nout, Ndata, lambda=',
2341:      &                    MLPIN,MLPSTART,MLPHIDDEN,MLPOUT,MLPDATA,MLPLAMBDA2258:      &                    MLPIN,MLPSTART,MLPHIDDEN,MLPOUT,MLPDATA,MLPLAMBDA
2342:          IF (WORD.EQ.'MLPVB3NN') WRITE(MYUNIT,'(A,I8)') ' keywords> Nearest-neighbours=',MLPNEIGH 
2343:          NMLP=MLPHIDDEN*(MLPIN+MLPOUT)+MLPHIDDEN+MLPOUT2259:          NMLP=MLPHIDDEN*(MLPIN+MLPOUT)+MLPHIDDEN+MLPOUT
2344:          IF (NMLP.NE.NATOMS) THEN2260:          IF (NMLP.NE.NATOMS) THEN
2345:             WRITE(MYUNIT,'(A,2I8)') 'keywords> ERROR *** NATOMS,NMLP=',NATOMS,NMLP2261:             WRITE(MYUNIT,'(A,2I8)') 'keywords> ERROR *** NATOMS,NMLP=',NATOMS,NMLP
2346:             STOP2262:             STOP
2347:          ENDIF2263:          ENDIF
2348:          LUNIT=GETUNIT()2264:          LUNIT=GETUNIT()
2349:          OPEN(LUNIT,FILE='MLPdata',STATUS='OLD')2265:          OPEN(LUNIT,FILE='MLPdata',STATUS='OLD')
2350:          ALLOCATE(MLPDAT(MLPDATA,MLPIN),MLPOUTCOME(MLPDATA),MLPMEAN(MLPIN))2266:          ALLOCATE(MLPDAT(MLPDATA,MLPIN),MLPOUTCOME(MLPDATA),MLPMEAN(MLPIN))
2351:          MLPMEAN(1:MLPIN)=0.0D02267:          MLPMEAN(1:MLPIN)=0.0D0
2352:          DO J1=1,MLPDATA2268:          DO J1=1,MLPDATA
2372: !2288: !
2373: ! Variables are ordered2289: ! Variables are ordered
2374: ! w^2_{jk} at (j-1)*MLPIN+k2290: ! w^2_{jk} at (j-1)*MLPIN+k
2375: !   up to MLPHIDDEN*MLPIN, then2291: !   up to MLPHIDDEN*MLPIN, then
2376: ! w^1_{ij} at MLPHIDDEN*MLPIN + (i-1)*MLPHIDDEN+j2292: ! w^1_{ij} at MLPHIDDEN*MLPIN + (i-1)*MLPHIDDEN+j
2377: !   up to MLPHIDDEN*MLPIN + MLPOUT*MLPHIDDEN2293: !   up to MLPHIDDEN*MLPIN + MLPOUT*MLPHIDDEN
2378: ! w^bh_j at MLPHIDDEN*(MLPIN+MLPOUT)+1 to MLPHIDDEN*(MLPIN+MLPOUT)+MLPHIDDEN2294: ! w^bh_j at MLPHIDDEN*(MLPIN+MLPOUT)+1 to MLPHIDDEN*(MLPIN+MLPOUT)+MLPHIDDEN
2379: ! w^bo_i at MLPHIDDEN*(MLPIN+MLPOUT)+MLPHIDDEN+1 to MLPHIDDEN*(MLPIN+MLPOUT)+MLPHIDDEN+MLPOUT2295: ! w^bo_i at MLPHIDDEN*(MLPIN+MLPOUT)+MLPHIDDEN+1 to MLPHIDDEN*(MLPIN+MLPOUT)+MLPHIDDEN+MLPOUT
2380: !2296: !
2381:          IF (WORD.EQ.'MLPVB3NN') THEN2297:          IF (WORD.EQ.'MLPVB3NN') THEN
2382:             ALLOCATE( MLPDISTHI(MLPIN), MLPDISTHO(MLPOUT), MLPINDEXI(MLPIN), MLPINDEXO(MLPOUT)) 
2383:             WRITE(MYUNIT,'(A)') 'Original nearest-neighbour fomulation:' 
2384:             FREEZE=.TRUE.2298:             FREEZE=.TRUE.
2385:             NFREEZE=MLPHIDDEN*(MLPIN+MLPOUT)-2*MLPHIDDEN2299:             NFREEZE=MLPHIDDEN*(MLPIN+MLPOUT)-2*MLPHIDDEN
2386:             FROZEN(1:MLPHIDDEN*(MLPIN+MLPOUT))=.TRUE.2300:             FROZEN(1:MLPHIDDEN*(MLPIN+MLPOUT))=.TRUE.
2387:             DO J1=1,MLPHIDDEN2301:             DO J1=1,MLPHIDDEN
2388:                J2=NINT(1.0D0*(MLPHIDDEN+J1*(MLPIN-1)-MLPIN)/(MLPHIDDEN-1)) ! unfrozen weight for hidden node J1 to input2302:                J2=NINT(1.0D0*(MLPHIDDEN+J1*(MLPIN-1)-MLPIN)/(MLPHIDDEN-1)) ! unfrozen weight for hidden node J1 to input
2389:                J3=(J1-1)*MLPIN+J22303:                J3=(J1-1)*MLPIN+J2
2390:                FROZEN(J3)=.FALSE.2304:                FROZEN(J3)=.FALSE.
2391:                WRITE(MYUNIT, '(A,I10,A,I10,A,I10)') 'keywords> Unfrozen weight ',J3,' input ',J2,' to hidden node ',J12305:                WRITE(MYUNIT, '(A,I10,A,I10,A,I10)') 'keywords> Unfrozen weight ',J3,' input ',J2,' to hidden node ',J1
2392:                J2=NINT(1.0D0*(MLPHIDDEN+J1*(MLPOUT-1)-MLPOUT)/(MLPHIDDEN-1)) ! unfrozen weight for hidden node J1 to output2306:                J2=NINT(1.0D0*(MLPHIDDEN+J1*(MLPOUT-1)-MLPOUT)/(MLPHIDDEN-1)) ! unfrozen weight for hidden node J1 to output
2393:                J3=MLPHIDDEN*MLPIN+(J2-1)*MLPHIDDEN+J12307:                J3=MLPHIDDEN*MLPIN+(J2-1)*MLPHIDDEN+J1
2394:                WRITE(MYUNIT, '(A,I10,A,I10,A,I10)') 'keywords> Unfrozen weight ',J3,' hidden node ',J1,' to output ',J22308:                WRITE(MYUNIT, '(A,I10,A,I10,A,I10)') 'keywords> Unfrozen weight ',J3,' hidden node ',J1,' to output ',J2
2395:                FROZEN(J3)=.FALSE.2309:                FROZEN(J3)=.FALSE.
2396:             ENDDO2310:             ENDDO
2397:             WRITE(MYUNIT,'(A,I6,A)') 'keywords> New nearest-neighbour formulation with ',MLPNEIGH,' neighbours'  
2398:             NFREEZE=MLPHIDDEN*(MLPIN+MLPOUT) 
2399:             FROZEN(1:MLPHIDDEN*(MLPIN+MLPOUT))=.TRUE. 
2400:             DO J1=1,MLPHIDDEN 
2401: ! 
2402: ! Distances from hidden J1 to all input nodes for 
2403: ! w^2_{J1 K1} at (J1-1)*MLPIN+K1 up to MLPHIDDEN*MLPIN 
2404: ! 
2405:                DO K1=1,MLPIN 
2406:                   MLPINDEXI(K1)=K1 
2407:                   MLPDISTHI(K1)=( (J1-1.0D0)/(MLPHIDDEN-1.0D0) - (K1-1.0D0)/(MLPIN-1.0D0) )**2 - K1*1.0D-6 ! to break degeneracy 
2408:                ENDDO 
2409:                CALL SORT4(MLPIN,MLPIN,MLPDISTHI,MLPINDEXI) 
2410:                DO J2=1,MIN(MLPNEIGH,MLPIN) 
2411:                   WRITE(MYUNIT,'(A,I8,A,I8,A,I8,A,G20.10)') 'hidden ',J1,' input neighbour ',J2,' is ',MLPINDEXI(J2),' distance ', 
2412:      &                                                      MLPDISTHI(J2) 
2413:                   J3=(J1-1)*MLPIN+MLPINDEXI(J2) 
2414:                   FROZEN(J3)=.FALSE. 
2415:                   NFREEZE=NFREEZE-1 
2416:                ENDDO 
2417: ! 
2418: ! Distances from hidden J1 to all output nodes for 
2419: ! w^1_{I1 J1} at MLPHIDDEN*MLPIN + (I1-1)*MLPHIDDEN+J1 up to MLPHIDDEN*MLPIN + MLPOUT*MLPHIDDEN 
2420: ! 
2421:                DO I1=1,MLPOUT 
2422:                   MLPINDEXO(I1)=I1 
2423:                   MLPDISTHO(I1)=( (J1-1.0D0)/(MLPHIDDEN-1.0D0) - (I1-1.0D0)/(MLPOUT-1.0D0) )**2 - I1*1.0D-6 ! to break degeneracy 
2424:                ENDDO 
2425:                CALL SORT4(MLPOUT,MLPOUT,MLPDISTHO,MLPINDEXO) 
2426:                DO J2=1,MIN(MLPNEIGH,MLPOUT) 
2427:                   WRITE(MYUNIT,'(A,I8,A,I8,A,I8,A,G20.10)') 'hidden ',J1,' output neighbour ',J2,' is ',MLPINDEXO(J2),' distance ', 
2428:      &                                                      MLPDISTHO(J2) 
2429:                   J3=MLPHIDDEN*MLPIN+(MLPINDEXO(J2)-1)*MLPHIDDEN+J1 
2430:                   FROZEN(J3)=.FALSE. 
2431:                   NFREEZE=NFREEZE-1 
2432:                ENDDO 
2433:             ENDDO 
2434:             DEALLOCATE( MLPDISTHI, MLPDISTHO, MLPINDEXI, MLPINDEXO) 
2435:          ENDIF2311:          ENDIF
2436: 2312: 
2437:       ELSE IF (WORD.EQ.'MLPNEWREG') THEN2313:       ELSE IF (WORD.EQ.'MLPNEWREG') THEN
2438:          MLPNEWREG=.TRUE.2314:          MLPNEWREG=.TRUE.
2439:          WRITE(MYUNIT,'(A)') 'keyword> Including reciprocals in regularisation'2315:          WRITE(MYUNIT,'(A)') 'keyword> Including reciprocals in regularisation'
2440: !2316: !
2441: ! MLPNORM directs OPTIM to rescale the input data columns by dividing each one by the2317: ! MLPNORM directs OPTIM to rescale the input data columns by dividing each one by the
2442: ! average of the mean magnitude2318: ! average of the mean magnitude
2443: ! Arranged so that MLPNORM can come before of after MLPB3/MLP32319: ! Arranged so that MLPNORM can come before of after MLPB3/MLP3
2444: !2320: !
2445:       ELSE IF (WORD.EQ.'MLPNORM') THEN2321:       ELSE IF (WORD.EQ.'MLPNORM') THEN
2446:          MLPNORM=.TRUE.2322:          MLPNORM=.TRUE.
2447:          IF (MLPDONE) THEN2323:          IF (MLPDONE) THEN
2448:             WRITE(*,'(A)') 'keyword> ERROR *** please put MLPNORM before MLP keyword in odata to ensure correct i/o'2324:             LUNIT=GETUNIT()
2449:             STOP2325:             OPEN(LUNIT,FILE='MLPdata',STATUS='OLD')
2450: 2326:             ALLOCATE(MLPMEAN(MLPIN))
2451: !           LUNIT=GETUNIT()2327:             MLPMEAN(1:MLPIN)=0.0D0
2452: !           OPEN(LUNIT,FILE='MLPdata',STATUS='OLD')2328:             DO J1=1,MLPDATA
2453: !           ALLOCATE(MLPMEAN(MLPIN))2329:                READ(LUNIT,*) MLPDAT(J1,1:MLPIN),MLPOUTCOME(J1)
2454: !           MLPMEAN(1:MLPIN)=0.0D02330:                MLPOUTCOME(J1)=MLPOUTCOME(J1)+1 ! to shift the range to start from 1 instead of zero
2455: !           DO J1=1,MLPDATA2331:                DO J2=1,MLPIN
2456: !              READ(LUNIT,*) MLPDAT(J1,1:MLPIN),MLPOUTCOME(J1)2332:                   MLPMEAN(J2)=MLPMEAN(J2)+ABS(MLPDAT(J1,J2))
2457: !              MLPOUTCOME(J1)=MLPOUTCOME(J1)+1 ! to shift the range to start from 1 instead of zero2333:                ENDDO
2458: !              DO J2=1,MLPIN2334:             ENDDO
2459: !                 MLPMEAN(J2)=MLPMEAN(J2)+ABS(MLPDAT(J1,J2))2335:             CLOSE(LUNIT)
2460: !              ENDDO2336:             MLPMEAN(1:MLPIN)=MLPMEAN(1:MLPIN)/MLPDATA
2461: !           ENDDO2337:             WRITE(MYUNIT,'(A)') 'keyword> Rescaling inputs by mean absolute values:'
2462: !           CLOSE(LUNIT)2338:             WRITE(MYUNIT,'(6G20.10)') MLPMEAN(1:MLPIN)
2463: !           MLPMEAN(1:MLPIN)=MLPMEAN(1:MLPIN)/MLPDATA2339:             DO J1=1,MLPIN
2464: !           WRITE(MYUNIT,'(A)') 'keyword> Rescaling inputs by mean absolute values:'2340:                MLPDAT(1:MLPDATA,J1)=MLPDAT(1:MLPDATA,J1)/MLPMEAN(J1)
2465: !           WRITE(MYUNIT,'(6G20.10)') MLPMEAN(1:MLPIN)2341:             ENDDO
2466: !           DO J1=1,MLPIN2342:             DEALLOCATE(MLPMEAN)
2467: !              MLPDAT(1:MLPDATA,J1)=MLPDAT(1:MLPDATA,J1)/MLPMEAN(J1) 
2468: !           ENDDO 
2469: !           DEALLOCATE(MLPMEAN) 
2470:          ENDIF2343:          ENDIF
2471:       ELSE IF (WORD.EQ.'MLQ') THEN2344:       ELSE IF (WORD.EQ.'MLQ') THEN
2472:          MLQT=.TRUE.2345:          MLQT=.TRUE.
2473:          CALL READI(MLQIN)      ! number of inputs (data items after outcome)2346:          CALL READI(MLQIN)      ! number of inputs (data items after outcome)
2474:          CALL READI(MLQSTART) ! starting position in data list, not counting outcome2347:          CALL READI(MLQSTART) ! starting position in data list, not counting outcome
2475:          CALL READI(MLQOUT)2348:          CALL READI(MLQOUT)
2476:          CALL READI(MLQDATA)2349:          CALL READI(MLQDATA)
2477:          IF (NITEMS.GT.4) CALL READF(MLQLAMBDA)2350:          IF (NITEMS.GT.4) CALL READF(MLQLAMBDA)
2478:          WRITE(MYUNIT,'(A,4I8,G20.10)') ' keywords> MLQ Nin, Ninstart, Nout, Ndata, lambda=',2351:          WRITE(MYUNIT,'(A,4I8,G20.10)') ' keywords> MLQ Nin, Ninstart, Nout, Ndata, lambda=',
2479:      &                                MLQIN,MLQSTART,MLQOUT,MLQDATA,MLQLAMBDA2352:      &                                MLQIN,MLQSTART,MLQOUT,MLQDATA,MLQLAMBDA
3694:          IF (NITEMS.GT.2) CALL READF(EAMP)3567:          IF (NITEMS.GT.2) CALL READF(EAMP)
3695: 3568: 
3696: ! Commenting out this AMBER keyword that should be used only with PNM's hand-coded AMBER3569: ! Commenting out this AMBER keyword that should be used only with PNM's hand-coded AMBER
3697: !      ELSE IF (WORD.EQ.'FAKEWATER') THEN3570: !      ELSE IF (WORD.EQ.'FAKEWATER') THEN
3698: !         FAKEWATER=.TRUE.3571: !         FAKEWATER=.TRUE.
3699: !         WRITE (MYUNIT,'(A)') '**********************************************************'3572: !         WRITE (MYUNIT,'(A)') '**********************************************************'
3700: !         WRITE (MYUNIT,'(A)') '* DISTANCE DEPENDENT DIELECTRIC BEING USED - FAKE WATER! *'3573: !         WRITE (MYUNIT,'(A)') '* DISTANCE DEPENDENT DIELECTRIC BEING USED - FAKE WATER! *'
3701: !         WRITE (MYUNIT,'(A)') '**********************************************************'3574: !         WRITE (MYUNIT,'(A)') '**********************************************************'
3702: 3575: 
3703: ! ----------------------------------------------------------------------------------------3576: ! ----------------------------------------------------------------------------------------
 3577: ! dj337: box derivatives keyword
 3578:       ELSE IF (WORD.EQ.'BOXDERIV') THEN
 3579:          BOXDERIVT = .TRUE.
 3580: 
 3581:          ! read box lengths
 3582:          IF (NITEMS.GT.1) CALL READF(XX)
 3583:          BOX_PARAMS(1) = XX
 3584:          IF (NITEMS.GT.2) CALL READF(XX)
 3585:          BOX_PARAMS(2) = XX
 3586:          IF (NITEMS.GT.3) CALL READF(XX)
 3587:          BOX_PARAMS(3) = XX
 3588: 
 3589:          ! read angles if provided
 3590:          IF (NITEMS.GT.4) THEN
 3591:             ! not orthorhombic
 3592:             ORTHO = .FALSE.
 3593: